Changeset 12050

May 14, 2009, 10:59:49 AM (11 years ago)

Tighten up proclaim/declaim error checking, both runtime and compile time

5 edited


  • branches/working-0711/ccl/compiler/nx0.lisp

    r12048 r12050  
    10771077(defun %proclaim-optimize (specs &aux q v)
    1078  (dolist (spec specs)
    1079   (if (atom spec)
    1080    (setq q spec v 3)
    1081    (setq q (%car spec) v (cadr spec)))
    1082   (when (and (fixnump v) (<= 0 v 3))
    1083    (if (eq q 'speed)
    1084     (setq *nx-speed* v)
    1085     (if (eq q 'space)
    1086      (setq *nx-space* v)
    1087      (if (eq q 'compilation-speed)
    1088       (setq *nx-cspeed* v)
    1089       (if (eq q 'safety)
    1090        (setq *nx-safety* v)
    1091        (if (eq q 'debug)
    1092          (setq *nx-debug* v)))))))))
     1078  (dolist (spec specs)
     1079    (if (atom spec)
     1080      (setq q spec v 3)
     1081      (setq q (%car spec) v (cadr spec)))
     1082    (or (and (fixnump v)
     1083             (<= 0 v 3)
     1084             (case q
     1085               (speed (setq *nx-speed* v))
     1086               (space (setq *nx-space* v))
     1087               (compilation-speed (setq *nx-cspeed* v))
     1088               (safety (setq *nx-safety* v))
     1089               (debug (setq *nx-debug* v))))
     1090        (bad-proclaim-spec `(optimize ,spec)))))
    10941092(defun nx-lexical-finfo (sym &optional (env *nx-lexical-environment*))
  • branches/working-0711/ccl/level-1/l1-aprims.lisp

    r12048 r12050  
    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))
  • branches/working-0711/ccl/level-1/l1-readloop.lisp

    r12048 r12050  
    592592            (info (if (listp defs) (assq sym defs) (gethash sym defs))))
    593593       (and info (def-info.function-p (cdr info)) info)))))
    595 (defun maybe-setf-function-name (name)
    596   (if (and (consp name) (eq (car name) 'setf))
    597     (setf-function-name (cadr name))
    598     name))
    600595;;; Must differ from -something-, but not sure what ...
  • branches/working-0711/ccl/level-1/l1-utils.lisp

    r12048 r12050  
    534534    (type (apply #'proclaim-type (%cdr spec)))
    535535    (ftype (apply #'proclaim-ftype (%cdr spec)))
    536     ;(function (proclaim-ftype (cons 'function (cddr spec)) (cadr spec)))
    537     (t (unless (memq (%car spec) *nx-known-declarations*) ;not really right...
     536    (function (apply #'proclaim-type spec))
     537    (t (unless (memq (%car spec) *nx-known-declarations*)
    538538         ;; Any type name is now (ANSI CL) a valid declaration.  Any symbol could become a type.
    539539         (if (symbolp (%car spec))
    541541           (warn "Unknown declaration specifier(s) in ~S" spec))))))
     543(defun bad-proclaim-spec (spec)
     544  (signal-program-error "Invalid declaration specifier ~s" spec))
    543546(defun proclaim-type (type &rest vars)
    544547  (declare (dynamic-extent vars))
     548  ;; Called too early to use (every #'symbolp vars)
     549  (unless (loop for v in vars always (symbolp v)) (bad-proclaim-spec `(,type ,@vars)))
     550  (when *type-system-initialized*
     551    ;; Check the type.  This will signal program-error's in case of invalid types, let it.
     552    (handler-case (specifier-type type)
     553      (parse-unknown-type (c)
     554        (warn "Undefined type ~s in declaration specifier ~s"
     555              (parse-unknown-type-specifier c) `(,type ,@vars)))))
    545556  (dolist (var vars)
    546     (if (symbolp var)
    547       (let ((spec (assq var *nx-proclaimed-types*)))
    548         ;; Check the type.  This will signal program-error's in case of invalid types, let it.
    549         (when *type-system-initialized*
    550           (handler-case (specifier-type type)
    551             (parse-unknown-type (c)
    552               (warn "Undefined type ~s declaration for ~S" (parse-unknown-type-specifier c) var))))
    553         (if spec
    554           (rplacd spec type)
    555           (push (cons var type) *nx-proclaimed-types*)))
    556       (warn "Invalid type declaration for ~S" var))))
     557    (let ((spec (assq var *nx-proclaimed-types*)))
     558      (if spec
     559        (rplacd spec type)
     560        (push (cons var type) *nx-proclaimed-types*)))))
    558562(defun proclaim-ftype (ftype &rest names)
    559563  (declare (dynamic-extent names))
     564  (unless (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) names)
     565    (bad-proclaim-spec `(ftype ,ftype ,@names)))
    560566  (unless *nx-proclaimed-ftypes*
    561567    (setq *nx-proclaimed-ftypes* (make-hash-table :test #'eq)))
     568  ;; Check the type.  This will signal program-error's in case of invalid types, let it.
     569  ;; TODO: should also check it for being a function type.
     570  (handler-case (specifier-type ftype)
     571    (parse-unknown-type (c)
     572      (warn "Undefined type ~s in declaration specifier ~s"
     573            (parse-unknown-type-specifier c) `(ftype ,ftype ,@names))))
    562574  (dolist (name names)
    563     (setf (gethash (ensure-valid-function-name name) *nx-proclaimed-ftypes*) ftype)))
     575    (setf (gethash (maybe-setf-function-name name) *nx-proclaimed-ftypes*) ftype)))
    572584(defun proclaim-special (&rest vars)
    573585  (declare (dynamic-extent vars))
     586  (unless (every #'symbolp vars) (bad-proclaim-spec `(special ,@vars)))
    574587  (dolist (sym vars) (%proclaim-special sym)))
    577590(defun proclaim-notspecial (&rest vars)
    578591  (declare (dynamic-extent vars))
     592  (unless (every #'symbolp vars) (bad-proclaim-spec `(special ,@vars)))
    579593  (dolist (sym vars) (%proclaim-notspecial sym)))
    584598  ;;first arg...
    585599  (unless (or (eq nil t-or-nil) (eq t t-or-nil)) (report-bad-arg t-or-nil '(member t nil)))
     600  (unless (loop for v in names always (or (symbolp v) (setf-function-name-p v)))
     601    (bad-proclaim-spec `(,(if t-or-nil 'inline 'notinline) ,@names)))
    586602  (dolist (name names)
    587     (setq name (ensure-valid-function-name name))
     603    (setq name (maybe-setf-function-name name))
    588604    (if (listp *nx-proclaimed-inline*)
    589605      (setq *nx-proclaimed-inline*
    590606          (alist-adjoin name
    591607                        (or t-or-nil (if (compiler-special-form-p name) t))
    592                         *nx-proclaimed-inline*))     
     608                        *nx-proclaimed-inline*))
    593609      (setf (gethash name *nx-proclaimed-inline*)
    594610            (or t-or-nil (if (compiler-special-form-p name) t))))))
    596612(defun proclaim-declaration (&rest syms)
    597613  (declare (dynamic-extent syms))
     614  (unless (every #'symbolp syms) (bad-proclaim-spec `(declaration ,@syms)))
    598615  (dolist (sym syms)
    599616    (when (type-specifier-p sym)
    613630  ;;first arg...
    614631  (unless (or (eq nil t-or-nil) (eq t t-or-nil)) (report-bad-arg t-or-nil '(member t nil)))
     632  (unless (every #'symbolp syms) (bad-proclaim-spec `(,(if t-or-nil 'ignore 'unignore) ,@syms)))
    615633  (dolist (sym syms)
    616634    (setq *nx-proclaimed-ignore*
  • branches/working-0711/ccl/lib/nfcomp.lisp

    r12048 r12050  
    830830(defun fcomp-proclaim-type (type syms env)
    831   (dolist (sym syms)
    832     (if (symbolp sym)
    833       (progn
    834         (specifier-type-if-known type env :whine t)
    835         (push (cons sym type) *nx-compile-time-types*))
    836       (nx-bad-decls `(type ,type ,sym)))))
     831  (if (every #'symbolp syms)
     832    (progn
     833      (specifier-type-if-known type env :whine t)
     834      (dolist (sym syms)
     835        (push (cons sym type) *nx-compile-time-types*)))
     836    (nx-bad-decls `(,type ,@syms))))
    838838(defun compile-time-proclamation (specs env &aux  sym (defenv (definition-environment env)))
    844844         (fcomp-proclaim-type (car spec) (cdr spec) env))
    845845        (special
    846          (dolist (sym spec)
    847            (push (cons (require-type sym 'symbol) nil) (defenv.specials defenv))))
     846         (if (every #'symbolp spec)
     847           (dolist (sym spec)
     848             (push (cons sym nil) (defenv.specials defenv)))
     849           (nx-bad-decls `(,sym ,@spec))))
    848850        (notspecial
    849          (let ((specials (defenv.specials defenv)))
    850            (dolist (sym spec (setf (defenv.specials defenv) specials))
    851              (let ((pair (assq sym specials)))
    852                (when pair (setq specials (nremove pair specials)))))))
     851         (if (every #'symbolp spec)
     852           (let ((specials (defenv.specials defenv)))
     853             (dolist (sym spec (setf (defenv.specials defenv) specials))
     854               (let ((pair (assq sym specials)))
     855                 (when pair (setq specials (nremove pair specials))))))
     856           (nx-bad-decls `(,sym ,@spec))))
    853857        (optimize
    854          (%proclaim-optimize spec))
     858           (handler-case (%proclaim-optimize spec)
     859             (program-error () (nx-bad-decls `(,sym ,@spec)))))
    855860        (inline
    856          (dolist (sym spec)
    857            (push (cons (maybe-setf-function-name sym) (cons 'inline 'inline)) (lexenv.fdecls defenv))))
     861         (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) spec)
     862           (dolist (sym spec)
     863             (push (cons (maybe-setf-function-name sym) (cons 'inline 'inline)) (lexenv.fdecls defenv)))
     864           (nx-bad-decls `(,sym ,@spec))))
    858865        (notinline
    859          (dolist (sym spec)
    860            (unless (compiler-special-form-p sym)
    861              (push (cons (maybe-setf-function-name sym) (cons 'inline 'notinline)) (lexenv.fdecls defenv)))))
     866         (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) spec)
     867           (dolist (sym spec)
     868             (unless (compiler-special-form-p sym)
     869               (push (cons (maybe-setf-function-name sym) (cons 'inline 'notinline)) (lexenv.fdecls defenv))))
     870           (nx-bad-decls `(,sym ,@spec))))
    862871        (declaration
    863          (dolist (sym spec)
    864            (pushnew (require-type sym 'symbol) *nx-known-declarations*)))
     872         (if (every #'symbolp spec)
     873           (dolist (sym spec)
     874             (pushnew sym *nx-known-declarations*))
     875           (nx-bad-decls `(,sym ,@spec))))
    865876        (ignore
    866          (dolist (sym spec)
    867            (push (cons (require-type sym 'symbol) t) *nx-proclaimed-ignore*)))
     877         (if (every #'symbolp spec)
     878           (dolist (sym spec)
     879             (push (cons sym t) *nx-proclaimed-ignore*))
     880           (nx-bad-decls `(,sym ,@spec))))
    868881        (unignore
    869          (dolist (sym spec)
    870            (push (cons (require-type sym 'symbol) nil) *nx-proclaimed-ignore*)))
     882         (if (every #'symbolp spec)
     883           (dolist (sym spec)
     884             (push (cons sym nil) *nx-proclaimed-ignore*))
     885           (nx-bad-decls `(,sym ,@spec))))
    871886        (ftype
    872887         (let ((ftype (car spec))
    873888               (fnames (cdr spec)))
    874            ;; ----- this part may be redundant, now that the lexenv.fdecls part is being done
    875            (if (and (consp ftype)
    876                     (consp fnames)
    877                     (eq (%car ftype) 'function))
    878              (dolist (fname fnames)
    879                (note-function-info fname nil env)))
    880            (dolist (fname fnames)
    881              (push (list* (maybe-setf-function-name fname) sym ftype) (lexenv.fdecls defenv)))))
     889           (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) fnames)
     890             (when (specifier-type-if-known ftype env :whine t)
     891               ;; ----- this part may be redundant, now that the lexenv.fdecls part is being done
     892               (if (and (consp ftype)
     893                        (consp fnames)
     894                        (eq (%car ftype) 'function))
     895                 (dolist (fname fnames)
     896                   (note-function-info fname nil env)))
     897               (dolist (fname fnames)
     898                 (push (list* (maybe-setf-function-name fname) sym ftype) (lexenv.fdecls defenv))))
     899             (nx-bad-decls `(ftype ,@spec)))))
    882900        (otherwise
    883901         (unless (memq sym *nx-known-declarations*)
    885903           (if (symbolp sym)
    886904             (fcomp-proclaim-type sym spec env)
    887              (nx-bad-decls `(,sym ,spec)))))))))
     905             (nx-bad-decls `(,sym ,@spec)))))))))
    889907(defun fcomp-load-%defun (form env)
Note: See TracChangeset for help on using the changeset viewer.