Changeset 12050


Ignore:
Timestamp:
May 14, 2009, 10:59:49 AM (10 years ago)
Author:
gz
Message:

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

Location:
branches/working-0711/ccl
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/nx0.lisp

    r12048 r12050  
    10761076
    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)))))
    10931091
    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))))
     297
     298
     299(defun maybe-setf-function-name (name)
     300  (if (and (consp name) (eq (car name) 'setf))
     301    (setf-function-name (cadr name))
     302    name))
    297303
    298304
  • 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)))))
    594 
    595 (defun maybe-setf-function-name (name)
    596   (if (and (consp name) (eq (car name) 'setf))
    597     (setf-function-name (cadr name))
    598     name))
    599594
    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))))))
    542542
     543(defun bad-proclaim-spec (spec)
     544  (signal-program-error "Invalid declaration specifier ~s" spec))
     545
    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*)))))
    557561
    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)))
    564576
    565577
     
    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)))
    575588
     
    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)))
    580594
     
    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  
    829829
    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))))
    837837
    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)))))))))
    888906
    889907(defun fcomp-load-%defun (form env)
Note: See TracChangeset for help on using the changeset viewer.