From: Christophe R. <cr...@us...> - 2014-01-22 12:18:36
|
The branch "master" has been updated in SBCL: via 659a6262af7cb0bfc899bb93951349d54745c27d (commit) from 2fe4c715db2906fa9fcc833b265d2d912487c7f0 (commit) - Log ----------------------------------------------------------------- commit 659a6262af7cb0bfc899bb93951349d54745c27d Author: Jan Moringen <jmo...@te...> Date: Tue Jul 16 19:44:56 2013 +0200 Add PROCLAIM-[F]TYPE; use in PROCLAIM and PREINFORM-COMPILER-ABOUT-ACCESSORS * New functions have been PROCLAIM-[F]TYPE extracted from PROCLAIM * PROCLAIM could be slightly simplified * FIXME about not being able to use TYPE-PROCLAMATION-MISMATCH has been resolved * As suggested in a FIXME comment, PREINFORM-COMPILER-ABOUT-ACCESSORS now uses PROCLAIM-FTYPE instead of duplicating the logic * The proclamation-related condition hierarchy now looks like this condition-----------------------+---------------+ | | | | | | proclamation-mismatch style-warning error | | | | | | | | type-p-m ftype-p-m-----------------+ | | | | | | | +-----------|-------+ | | | | | | | | type-p-m-warning ftype-p-m-warning ftype-p-m-error Report functions of these condition are more regular now and should work a bit better in logical blocks --- package-data-list.lisp-expr | 9 +++ src/code/condition.lisp | 60 +++++++++++++----- src/code/target-error.lisp | 5 +- src/compiler/proclaim.lisp | 148 +++++++++++++++++++++---------------------- src/pcl/defclass.lisp | 29 +++----- 5 files changed, 135 insertions(+), 116 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 612236d..76315d7 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -321,6 +321,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "PRIMITIVE-TYPE-OR-LOSE" "PRIMITIVE-TYPE-VOP" "PRIMITIVE-TYPE-NAME" "PRIMITIVE-TYPE-INDIRECT-CELL-TYPE" + "PROCLAIM-FTYPE" "PROCLAIM-TYPE" "PUSH-VALUES" "READ-PACKED-BIT-VECTOR" "READ-VAR-INTEGER" "READ-VAR-STRING" #!+inline-constants "REGISTER-INLINE-CONSTANT" @@ -1972,8 +1973,16 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "CHARACTER-DECODING-ERROR-IN-COMMENT" "DEPRECATED-EVAL-WHEN-SITUATIONS" "PROCLAMATION-MISMATCH" + "PROCLAMATION-MISMATCH-NAME" + "PROCLAMATION-MISMATCH-NEW" + "PROCLAMATION-MISMATCH-OLD" "TYPE-PROCLAMATION-MISMATCH" + "TYPE-PROCLAMATION-MISMATCH-WARNING" + "TYPE-PROCLAMATION-MISMATCH-WARN" "FTYPE-PROCLAMATION-MISMATCH" + "FTYPE-PROCLAMATION-MISMATCH-WARNING" + "FTYPE-PROCLAMATION-MISMATCH-WARN" + "FTYPE-PROCLAMATION-MISMATCH-ERROR" "!COLD-INIT" "!UNINTERN-INIT-ONLY-STUFF" "!GLOBALDB-COLD-INIT" "!FDEFN-COLD-INIT" diff --git a/src/code/condition.lisp b/src/code/condition.lisp index a87ec25..c791fc7 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -1565,30 +1565,56 @@ the usual naming convention (names like *FOO*) for special variables" (format stream "using deprecated EVAL-WHEN situation names~{ ~S~}" (deprecated-eval-when-situations-situations warning))))) -(define-condition proclamation-mismatch (style-warning) - ((name :initarg :name :reader proclamation-mismatch-name) +(define-condition proclamation-mismatch (condition) + ((kind :initarg :kind :reader proclamation-mismatch-kind) + (description :initarg :description :reader proclamation-mismatch-description :initform nil) + (name :initarg :name :reader proclamation-mismatch-name) (old :initarg :old :reader proclamation-mismatch-old) - (new :initarg :new :reader proclamation-mismatch-new))) + (new :initarg :new :reader proclamation-mismatch-new)) + (:report + (lambda (condition stream) + ;; if we later decide we want package-qualified names, bind + ;; *PACKAGE* to (find-package "KEYWORD") here. + (format stream + "~@<The new ~A proclamation for~@[ ~A~] ~S~ + ~@:_~2@T~S~@:_~ + does not match the old ~4:*~A~3* proclamation~ + ~@:_~2@T~S~@:>" + (proclamation-mismatch-kind condition) + (proclamation-mismatch-description condition) + (proclamation-mismatch-name condition) + (proclamation-mismatch-new condition) + (proclamation-mismatch-old condition))))) (define-condition type-proclamation-mismatch (proclamation-mismatch) () - (:report (lambda (warning stream) - (format stream - "The new TYPE proclamation~% ~S for ~S does not ~ - match the old TYPE proclamation ~S" - (proclamation-mismatch-new warning) - (proclamation-mismatch-name warning) - (proclamation-mismatch-old warning))))) + (:default-initargs :kind 'type)) + +(define-condition type-proclamation-mismatch-warning (style-warning + type-proclamation-mismatch) + ()) + +(defun type-proclamation-mismatch-warn (name old new &optional description) + (warn 'type-proclamation-mismatch-warning + :name name :old old :new new :description description)) (define-condition ftype-proclamation-mismatch (proclamation-mismatch) () - (:report (lambda (warning stream) - (format stream - "The new FTYPE proclamation~% ~S for ~S does not ~ - match the old FTYPE proclamation ~S" - (proclamation-mismatch-new warning) - (proclamation-mismatch-name warning) - (proclamation-mismatch-old warning))))) + (:default-initargs :kind 'ftype)) + +(define-condition ftype-proclamation-mismatch-warning (style-warning + ftype-proclamation-mismatch) + ()) + +(defun ftype-proclamation-mismatch-warn (name old new &optional description) + (warn 'ftype-proclamation-mismatch-warning + :name name :old old :new new :description description)) + +(define-condition ftype-proclamation-mismatch-error (error + ftype-proclamation-mismatch) + () + (:default-initargs :kind 'ftype :description "known function")) + ;;;; deprecation conditions diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp index d92a978..4997513 100644 --- a/src/code/target-error.lisp +++ b/src/code/target-error.lisp @@ -122,12 +122,9 @@ restarts associated with CONDITION (or with no condition) will be returned." (named-restart-p (restart) (when (eq identifier (restart-name restart)) (return-from %find-restart restart)))) - ;; TODO Question for reviewer: does the compiler infer this dx - ;; automatically? + ;; KLUDGE: can the compiler infer this dx automatically? (declare (truly-dynamic-extent #'eq-restart-p #'named-restart-p)) (if (typep identifier 'restart) - ;; TODO Questions for reviewer: - ;; ;; The code under #+previous-... below breaks the abstraction ;; introduced by MAP-RESTARTS, but is about twice as ;; fast as #+equivalent-... . Also, it is a common case due to diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 755467a..e649377 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -162,31 +162,74 @@ (!cold-init-forms (setf *queued-proclaims* nil)) (!defun-from-collected-cold-init-forms !early-proclaim-cold-init) +(defun proclaim-type (name type where-from) + (unless (symbolp name) + (error "Cannot proclaim TYPE of a non-symbol: ~S" name)) + + (with-single-package-locked-error + (:symbol name "globally declaring the TYPE of ~A") + (when (eq (info :variable :where-from name) :declared) + (let ((old-type (info :variable :type name))) + (when (type/= type old-type) + (type-proclamation-mismatch-warn + name (type-specifier old-type) (type-specifier type))))) + (setf (info :variable :type name) type + (info :variable :where-from name) where-from))) + +(defun proclaim-ftype (name type where-from) + (unless (legal-fun-name-p name) + (error "Cannot declare FTYPE of illegal function name ~S" name)) + (unless (csubtypep type (specifier-type 'function)) + (error "Not a function type: ~S" (type-specifier type))) + + (with-single-package-locked-error + (:symbol name "globally declaring the FTYPE of ~A") + (when (eq (info :function :where-from name) :declared) + (let ((old-type (info :function :type name))) + (cond + ((not (type/= type old-type))) ; not changed + ((not (info :function :info name)) ; not a known function + (ftype-proclamation-mismatch-warn + name (type-specifier old-type) (type-specifier type))) + ((csubtypep type old-type)) ; tighten known function type + (t + (cerror "Continue" + 'ftype-proclamation-mismatch-error + :name name + :old (type-specifier old-type) + :new (type-specifier type)))))) + ;; Now references to this function shouldn't be warned about as + ;; undefined, since even if we haven't seen a definition yet, we + ;; know one is planned. + ;; + ;; Other consequences of we-know-you're-a-function-now are + ;; appropriate too, e.g. any MACRO-FUNCTION goes away. + (proclaim-as-fun-name name) + (note-name-defined name :function) + + ;; The actual type declaration. + (setf (info :function :type name) type + (info :function :where-from name) where-from))) + (defun sb!xc:proclaim (raw-form) #+sb-xc (/show0 "entering PROCLAIM, RAW-FORM=..") #+sb-xc (/hexstr raw-form) - (let* ((form (canonized-decl-spec raw-form)) - (kind (first form)) - (args (rest form))) + (destructuring-bind (&whole form &optional kind &rest args) + (canonized-decl-spec raw-form) (case kind ((special global) - (flet ((make-special (name old) - (unless (member old '(:special :unknown)) - (error "Cannot proclaim a ~(~A~) variable special: ~S" old name)) - (with-single-package-locked-error - (:symbol name "globally declaring ~A special") - (setf (info :variable :kind name) :special))) - (make-global (name old) - (unless (member old '(:global :unknown)) - (error "Cannot proclaim a ~(~A~) variable global: ~S" old name)) - (with-single-package-locked-error - (:symbol name "globally declaring ~A global") - (setf (info :variable :kind name) :global)))) - (let ((fun (if (eq 'special kind) #'make-special #'make-global))) - (dolist (name args) - (unless (symbolp name) - (error "Can't declare a non-symbol as ~S: ~S" kind name)) - (funcall fun name (info :variable :kind name)))))) + (let ((kind/keyword (ecase kind + (special :special) + (global :global)))) + (dolist (name args) + (unless (symbolp name) + (error "Can't declare a non-symbol as ~(~A~): ~S" kind name)) + (let ((old (info :variable :kind name))) + (unless (member old (list kind/keyword :unknown)) + (error "Cannot proclaim a ~(~A~) variable ~(~A~): ~S" old kind name))) + (with-single-package-locked-error + (:symbol name "globally declaring ~A ~(~A~)" kind) + (setf (info :variable :kind name) kind/keyword))))) (always-bound (dolist (name args) (unless (symbolp name) @@ -198,63 +241,14 @@ (with-single-package-locked-error (:symbol name "globally declaring ~A always bound") (setf (info :variable :always-bound name) t)))) - (type + ((type ftype) (if *type-system-initialized* - (let ((type (specifier-type (first args)))) - (dolist (name (rest args)) - (unless (symbolp name) - (error "can't declare TYPE of a non-symbol: ~S" name)) - (with-single-package-locked-error - (:symbol name "globally declaring the type of ~A")) - (when (eq (info :variable :where-from name) :declared) - (let ((old-type (info :variable :type name))) - (when (type/= type old-type) - ;; FIXME: changing to TYPE-PROCLAMATION-MISMATCH - ;; broke late-proclaim.lisp. - (style-warn - "~@<new TYPE proclamation for ~S~@:_ ~S~@:_~ - does not match the old TYPE proclamation:~@:_ ~S~@:>" - name (type-specifier type) (type-specifier old-type))))) - (setf (info :variable :type name) type) - (setf (info :variable :where-from name) :declared))) - (push raw-form *queued-proclaims*))) - (ftype - (if *type-system-initialized* - (let ((ctype (specifier-type (first args)))) - (unless (csubtypep ctype (specifier-type 'function)) - (error "not a function type: ~S" (first args))) - (dolist (name (rest args)) - (with-single-package-locked-error - (:symbol name "globally declaring the ftype of ~A") - (when (eq (info :function :where-from name) :declared) - (let ((old-type (info :function :type name))) - (when (type/= ctype old-type) - ;; FIXME: changing to FTYPE-PROCLAMATION-MISMATCH - ;; broke late-proclaim.lisp. - (if (info :function :info name) - ;; Allow for tightening of known function types - (unless (csubtypep ctype old-type) - (cerror "Continue" - "~@<new FTYPE proclamation for known function ~S~@:_ ~S~@:_~ - does not match its old FTYPE:~@:_ ~S~@:>" - name (type-specifier ctype) (type-specifier old-type))) - (#+sb-xc-host warn - #-sb-xc-host style-warn - "~@<new FTYPE proclamation for ~S~@:_ ~S~@:_~ - does not match the old FTYPE proclamation:~@:_ ~S~@:>" - name (type-specifier ctype) (type-specifier old-type)))))) - ;; Now references to this function shouldn't be warned - ;; about as undefined, since even if we haven't seen a - ;; definition yet, we know one is planned. - ;; - ;; Other consequences of we-know-you're-a-function-now - ;; are appropriate too, e.g. any MACRO-FUNCTION goes away. - (proclaim-as-fun-name name) - (note-name-defined name :function) - - ;; the actual type declaration - (setf (info :function :type name) ctype - (info :function :where-from name) :declared)))) + (destructuring-bind (type &rest names) args + (let ((ctype (specifier-type type))) + (dolist (name names) + (ecase kind + (type (proclaim-type name ctype :declared)) + (ftype (proclaim-ftype name ctype :declared)))))) (push raw-form *queued-proclaims*))) (freeze-type (dolist (type args) @@ -279,7 +273,7 @@ (process-package-lock-decl form *disabled-package-locks*))) ((inline notinline maybe-inline) (dolist (name args) - ; since implicitly it is a function, also scrubs *FREE-FUNS* + ;; since implicitly it is a function, also scrubs *FREE-FUNS* (proclaim-as-fun-name name) (setf (info :function :inlinep name) (ecase kind diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 33bfd0b..3d9f179 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -307,26 +307,19 @@ (values)) (defun preinform-compiler-about-accessors (readers writers slots) - (flet ((inform (name type) - ;; FIXME: This matches what PROCLAIM FTYPE does, except - ;; that :WHERE-FROM is :DEFINED, not :DECLARED, and should - ;; probably be factored into a common function -- eg. - ;; (%proclaim-ftype name declared-or-defined). - (when (eq (info :function :where-from name) :assumed) - (proclaim-as-fun-name name) - (note-name-defined name :function) - (setf (info :function :where-from name) :defined - (info :function :type name) type)))) + (flet ((inform (names type &key key) + (mapc (lambda (name) + (let ((name (if key (funcall key name) name))) + (when (eq (info :function :where-from name) :assumed) + (sb-c:proclaim-ftype name type :defined)))) + names))) (let ((rtype (specifier-type '(function (t) t))) (wtype (specifier-type '(function (t t) t)))) - (dolist (reader readers) - (inform reader rtype)) - (dolist (writer writers) - (inform writer wtype)) - (dolist (slot slots) - (inform (slot-reader-name slot) rtype) - (inform (slot-boundp-name slot) rtype) - (inform (slot-writer-name slot) wtype))))) + (inform readers rtype) + (inform writers wtype) + (inform slots rtype :key #'slot-reader-name) + (inform slots rtype :key #'slot-boundp-name) + (inform slots wtype :key #'slot-writer-name)))) ;;; This is the early definition of LOAD-DEFCLASS. It just collects up ;;; all the class definitions in a list. Later, in braid1.lisp, these ----------------------------------------------------------------------- hooks/post-receive -- SBCL |