Changeset 12069

May 15, 2009, 3:18:52 PM (10 years ago)

merge r12050

5 edited


  • trunk/source/compiler/nx0.lisp

    r12045 r12069  
    10701070(defun %proclaim-optimize (specs &aux q v)
    1071  (dolist (spec specs)
    1072   (if (atom spec)
    1073    (setq q spec v 3)
    1074    (setq q (%car spec) v (cadr spec)))
    1075   (when (and (fixnump v) (<= 0 v 3))
    1076    (if (eq q 'speed)
    1077     (setq *nx-speed* v)
    1078     (if (eq q 'space)
    1079      (setq *nx-space* v)
    1080      (if (eq q 'compilation-speed)
    1081       (setq *nx-cspeed* v)
    1082       (if (eq q 'safety)
    1083        (setq *nx-safety* v)
    1084        (if (eq q 'debug)
    1085          (setq *nx-debug* v)))))))))
     1071  (dolist (spec specs)
     1072    (if (atom spec)
     1073      (setq q spec v 3)
     1074      (setq q (%car spec) v (cadr spec)))
     1075    (or (and (fixnump v)
     1076             (<= 0 v 3)
     1077             (case q
     1078               (speed (setq *nx-speed* v))
     1079               (space (setq *nx-space* v))
     1080               (compilation-speed (setq *nx-cspeed* v))
     1081               (safety (setq *nx-safety* v))
     1082               (debug (setq *nx-debug* v))))
     1083        (bad-proclaim-spec `(optimize ,spec)))))
    10871085(defun nx-lexical-finfo (sym &optional (env *nx-lexical-environment*))
  • trunk/source/level-1/l1-aprims.lisp

    r11958 r12069  
    295295  (multiple-value-bind (valid-p nm) (valid-function-name-p name)
    296296    (if valid-p nm (error "Invalid function name ~s." name))))
     299(defun maybe-setf-function-name (name)
     300  (if (and (consp name) (eq (car name) 'setf))
     301    (setf-function-name (cadr name))
     302    name))
  • trunk/source/level-1/l1-readloop.lisp

    r12045 r12069  
    587587            (info (if (listp defs) (assq sym defs) (gethash sym defs))))
    588588       (and info (def-info.function-p (cdr info)) info)))))
    590 (defun maybe-setf-function-name (name)
    591   (if (and (consp name) (eq (car name) 'setf))
    592     (setf-function-name (cadr name))
    593     name))
    595590;;; Must differ from -something-, but not sure what ...
  • trunk/source/level-1/l1-utils.lisp

    r12045 r12069  
    535535    (type (apply #'proclaim-type (%cdr spec)))
    536536    (ftype (apply #'proclaim-ftype (%cdr spec)))
    537     ;(function (proclaim-ftype (cons 'function (cddr spec)) (cadr spec)))
    538     (t (unless (memq (%car spec) *nx-known-declarations*) ;not really right...
     537    (function (apply #'proclaim-type spec))
     538    (t (unless (memq (%car spec) *nx-known-declarations*)
    539539         ;; Any type name is now (ANSI CL) a valid declaration.  Any symbol could become a type.
    540540         (if (symbolp (%car spec))
    542542           (warn "Unknown declaration specifier(s) in ~S" spec))))))
     544(defun bad-proclaim-spec (spec)
     545  (signal-program-error "Invalid declaration specifier ~s" spec))
    544547(defun proclaim-type (type &rest vars)
    545548  (declare (dynamic-extent vars))
     549  ;; Called too early to use (every #'symbolp vars)
     550  (unless (loop for v in vars always (symbolp v)) (bad-proclaim-spec `(,type ,@vars)))
     551  (when *type-system-initialized*
     552    ;; Check the type.  This will signal program-error's in case of invalid types, let it.
     553    (handler-case (specifier-type type)
     554      (parse-unknown-type (c)
     555        (warn "Undefined type ~s in declaration specifier ~s"
     556              (parse-unknown-type-specifier c) `(,type ,@vars)))))
    546557  (dolist (var vars)
    547     (if (symbolp var)
    548       (let ((spec (assq var *nx-proclaimed-types*)))
    549         ;; Check the type.  This will signal program-error's in case of invalid types, let it.
    550         (when *type-system-initialized*
    551           (handler-case (specifier-type type)
    552             (parse-unknown-type (c)
    553               (warn "Undefined type ~s declaration for ~S" (parse-unknown-type-specifier c) var))))
    554         (if spec
    555           (rplacd spec type)
    556           (push (cons var type) *nx-proclaimed-types*)))
    557       (warn "Invalid type declaration for ~S" var))))
     558    (let ((spec (assq var *nx-proclaimed-types*)))
     559      (if spec
     560        (rplacd spec type)
     561        (push (cons var type) *nx-proclaimed-types*)))))
    559563(defun proclaim-ftype (ftype &rest names)
    560564  (declare (dynamic-extent names))
     565  (unless (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) names)
     566    (bad-proclaim-spec `(ftype ,ftype ,@names)))
    561567  (unless *nx-proclaimed-ftypes*
    562568    (setq *nx-proclaimed-ftypes* (make-hash-table :test #'eq)))
     569  ;; Check the type.  This will signal program-error's in case of invalid types, let it.
     570  ;; TODO: should also check it for being a function type.
     571  (handler-case (specifier-type ftype)
     572    (parse-unknown-type (c)
     573      (warn "Undefined type ~s in declaration specifier ~s"
     574            (parse-unknown-type-specifier c) `(ftype ,ftype ,@names))))
    563575  (dolist (name names)
    564     (setf (gethash (ensure-valid-function-name name) *nx-proclaimed-ftypes*) ftype)))
     576    (setf (gethash (maybe-setf-function-name name) *nx-proclaimed-ftypes*) ftype)))
    573585(defun proclaim-special (&rest vars)
    574586  (declare (dynamic-extent vars))
     587  (unless (every #'symbolp vars) (bad-proclaim-spec `(special ,@vars)))
    575588  (dolist (sym vars) (%proclaim-special sym)))
    578591(defun proclaim-notspecial (&rest vars)
    579592  (declare (dynamic-extent vars))
     593  (unless (every #'symbolp vars) (bad-proclaim-spec `(special ,@vars)))
    580594  (dolist (sym vars) (%proclaim-notspecial sym)))
    585599  ;;first arg...
    586600  (unless (or (eq nil t-or-nil) (eq t t-or-nil)) (report-bad-arg t-or-nil '(member t nil)))
     601  (unless (loop for v in names always (or (symbolp v) (setf-function-name-p v)))
     602    (bad-proclaim-spec `(,(if t-or-nil 'inline 'notinline) ,@names)))
    587603  (dolist (name names)
    588     (setq name (ensure-valid-function-name name))
     604    (setq name (maybe-setf-function-name name))
    589605    (if (listp *nx-proclaimed-inline*)
    590606      (setq *nx-proclaimed-inline*
    591607          (alist-adjoin name
    592608                        (or t-or-nil (if (compiler-special-form-p name) t))
    593                         *nx-proclaimed-inline*))     
     609                        *nx-proclaimed-inline*))
    594610      (setf (gethash name *nx-proclaimed-inline*)
    595611            (or t-or-nil (if (compiler-special-form-p name) t))))))
    597613(defun proclaim-declaration (&rest syms)
    598614  (declare (dynamic-extent syms))
     615  (unless (every #'symbolp syms) (bad-proclaim-spec `(declaration ,@syms)))
    599616  (dolist (sym syms)
    600617    (when (type-specifier-p sym)
    614631  ;;first arg...
    615632  (unless (or (eq nil t-or-nil) (eq t t-or-nil)) (report-bad-arg t-or-nil '(member t nil)))
     633  (unless (every #'symbolp syms) (bad-proclaim-spec `(,(if t-or-nil 'ignore 'unignore) ,@syms)))
    616634  (dolist (sym syms)
    617635    (setq *nx-proclaimed-ignore*
  • trunk/source/lib/nfcomp.lisp

    r12045 r12069  
    766766(defun fcomp-proclaim-type (type syms env)
    767   (dolist (sym syms)
    768     (if (symbolp sym)
    769       (progn
    770         (specifier-type-if-known type env :whine t)
    771         (push (cons sym type) *nx-compile-time-types*))
    772       (nx-bad-decls `(type ,type ,sym)))))
     767  (if (every #'symbolp syms)
     768    (progn
     769      (specifier-type-if-known type env :whine t)
     770      (dolist (sym syms)
     771        (push (cons sym type) *nx-compile-time-types*)))
     772    (nx-bad-decls `(,type ,@syms))))
    774774(defun compile-time-proclamation (specs env &aux  sym (defenv (definition-environment env)))
    780780         (fcomp-proclaim-type (car spec) (cdr spec) env))
    781781        (special
    782          (dolist (sym spec)
    783            (push (cons (require-type sym 'symbol) nil) (defenv.specials defenv))))
     782         (if (every #'symbolp spec)
     783           (dolist (sym spec)
     784             (push (cons sym nil) (defenv.specials defenv)))
     785           (nx-bad-decls `(,sym ,@spec))))
    784786        (notspecial
    785          (let ((specials (defenv.specials defenv)))
    786            (dolist (sym spec (setf (defenv.specials defenv) specials))
    787              (let ((pair (assq sym specials)))
    788                (when pair (setq specials (nremove pair specials)))))))
     787         (if (every #'symbolp spec)
     788           (let ((specials (defenv.specials defenv)))
     789             (dolist (sym spec (setf (defenv.specials defenv) specials))
     790               (let ((pair (assq sym specials)))
     791                 (when pair (setq specials (nremove pair specials))))))
     792           (nx-bad-decls `(,sym ,@spec))))
    789793        (optimize
    790          (%proclaim-optimize spec))
     794           (handler-case (%proclaim-optimize spec)
     795             (program-error () (nx-bad-decls `(,sym ,@spec)))))
    791796        (inline
    792          (dolist (sym spec)
    793            (push (cons (maybe-setf-function-name sym) (cons 'inline 'inline)) (lexenv.fdecls defenv))))
     797         (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) spec)
     798           (dolist (sym spec)
     799             (push (cons (maybe-setf-function-name sym) (cons 'inline 'inline)) (lexenv.fdecls defenv)))
     800           (nx-bad-decls `(,sym ,@spec))))
    794801        (notinline
    795          (dolist (sym spec)
    796            (unless (compiler-special-form-p sym)
    797              (push (cons (maybe-setf-function-name sym) (cons 'inline 'notinline)) (lexenv.fdecls defenv)))))
     802         (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) spec)
     803           (dolist (sym spec)
     804             (unless (compiler-special-form-p sym)
     805               (push (cons (maybe-setf-function-name sym) (cons 'inline 'notinline)) (lexenv.fdecls defenv))))
     806           (nx-bad-decls `(,sym ,@spec))))
    798807        (declaration
    799          (dolist (sym spec)
    800            (pushnew (require-type sym 'symbol) *nx-known-declarations*)))
     808         (if (every #'symbolp spec)
     809           (dolist (sym spec)
     810             (pushnew sym *nx-known-declarations*))
     811           (nx-bad-decls `(,sym ,@spec))))
    801812        (ignore
    802          (dolist (sym spec)
    803            (push (cons (require-type sym 'symbol) t) *nx-proclaimed-ignore*)))
     813         (if (every #'symbolp spec)
     814           (dolist (sym spec)
     815             (push (cons sym t) *nx-proclaimed-ignore*))
     816           (nx-bad-decls `(,sym ,@spec))))
    804817        (unignore
    805          (dolist (sym spec)
    806            (push (cons (require-type sym 'symbol) nil) *nx-proclaimed-ignore*)))
     818         (if (every #'symbolp spec)
     819           (dolist (sym spec)
     820             (push (cons sym nil) *nx-proclaimed-ignore*))
     821           (nx-bad-decls `(,sym ,@spec))))
    807822        (ftype
    808823         (let ((ftype (car spec))
    809824               (fnames (cdr spec)))
    810            ;; ----- this part may be redundant, now that the lexenv.fdecls part is being done
    811            (if (and (consp ftype)
    812                     (consp fnames)
    813                     (eq (%car ftype) 'function))
    814              (dolist (fname fnames)
    815                (note-function-info fname nil env)))
    816            (dolist (fname fnames)
    817              (push (list* (maybe-setf-function-name fname) sym ftype) (lexenv.fdecls defenv)))))
     825           (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) fnames)
     826             (when (specifier-type-if-known ftype env :whine t)
     827               ;; ----- this part may be redundant, now that the lexenv.fdecls part is being done
     828               (if (and (consp ftype)
     829                        (consp fnames)
     830                        (eq (%car ftype) 'function))
     831                 (dolist (fname fnames)
     832                   (note-function-info fname nil env)))
     833               (dolist (fname fnames)
     834                 (push (list* (maybe-setf-function-name fname) sym ftype) (lexenv.fdecls defenv))))
     835             (nx-bad-decls `(ftype ,@spec)))))
    818836        (otherwise
    819837         (unless (memq sym *nx-known-declarations*)
    821839           (if (symbolp sym)
    822840             (fcomp-proclaim-type sym spec env)
    823              (nx-bad-decls `(,sym ,spec)))))))))
     841             (nx-bad-decls `(,sym ,@spec)))))))))
    825843(defun fcomp-load-%defun (form env)
Note: See TracChangeset for help on using the changeset viewer.