X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=a1d40d5f6d42e915814104b6a20da133f1d91ff7;hb=54da325f13fb41669869aea688ae195426c0e231;hp=7592df61085d53e3bdd8f8e27ec64aa2f454fcd3;hpb=c593dc26733b179db6c12c7085ed76b762ac256b;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 7592df6..a1d40d5 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -13,26 +13,6 @@ (in-package "SB!KERNEL") -;;;; miscellaneous support utilities - -;;; Signalling an error when trying to print an error condition is -;;; generally a PITA, so whatever the failure encountered when -;;; wondering about FILE-POSITION within a condition printer, 'tis -;;; better silently to give up than to try to complain. -(defun file-position-or-nil-for-error (stream &optional (pos nil posp)) - ;; Arguably FILE-POSITION shouldn't be signalling errors at all; but - ;; "NIL if this cannot be determined" in the ANSI spec doesn't seem - ;; absolutely unambiguously to prohibit errors when, e.g., STREAM - ;; has been closed so that FILE-POSITION is a nonsense question. So - ;; my (WHN) impression is that the conservative approach is to - ;; IGNORE-ERRORS. (I encountered this failure from within a homebrew - ;; defsystemish operation where the ERROR-STREAM had been CL:CLOSEd, - ;; I think by nonlocally exiting through a WITH-OPEN-FILE, by the - ;; time an error was reported.) - (if posp - (ignore-errors (file-position stream pos)) - (ignore-errors (file-position stream)))) - ;;;; the CONDITION class (/show0 "condition.lisp 20") @@ -51,8 +31,13 @@ (class-slots nil :type list) ;; report function or NIL (report nil :type (or function null)) - ;; list of alternating initargs and initforms - (default-initargs () :type list) + ;; list of specifications of the form + ;; + ;; (INITARG INITFORM THUNK) + ;; + ;; where THUNK, when called without arguments, returns the value for + ;; INITARG. + (direct-default-initargs () :type list) ;; class precedence list as a list of CLASS objects, with all ;; non-CONDITION classes removed (cpl () :type list) @@ -74,9 +59,6 @@ :metaclass-constructor make-condition-classoid :dd-type structure) -(defun make-condition-object (actual-initargs) - (%make-condition-object actual-initargs nil)) - (defstruct (condition-slot (:copier nil)) (name (missing-arg) :type symbol) ;; list of all applicable initargs @@ -86,12 +68,13 @@ (writers (missing-arg) :type list) ;; true if :INITFORM was specified (initform-p (missing-arg) :type (member t nil)) - ;; If this is a function, call it with no args. Otherwise, it's the - ;; actual value. - (initform (missing-arg) :type t) + ;; the initform if :INITFORM was specified, otherwise NIL + (initform nil :type t) + ;; if this is a function, call it with no args to get the initform value + (initfunction (missing-arg) :type t) ;; allocation of this slot, or NIL until defaulted (allocation nil :type (member :instance :class nil)) - ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value. + ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value (cell nil :type (or cons null)) ;; slot documentation (documentation nil :type (or string null))) @@ -171,7 +154,12 @@ ;;; The current code doesn't seem to quite match that. (def!method print-object ((x condition) stream) (if *print-escape* - (print-unreadable-object (x stream :type t :identity t)) + (if (and (typep x 'simple-condition) (slot-value x 'format-control)) + (print-unreadable-object (x stream :type t :identity t) + (write (simple-condition-format-control x) + :stream stream + :lines 1)) + (print-unreadable-object (x stream :type t :identity t))) ;; KLUDGE: A comment from CMU CL here said ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of ;; superclasses in define-condition call! @@ -188,21 +176,21 @@ (defun find-slot-default (class slot) (let ((initargs (condition-slot-initargs slot)) (cpl (condition-classoid-cpl class))) + ;; When CLASS or a superclass has a default initarg for SLOT, use + ;; that. (dolist (class cpl) - (let ((default-initargs (condition-classoid-default-initargs class))) + (let ((direct-default-initargs + (condition-classoid-direct-default-initargs class))) (dolist (initarg initargs) - (let ((val (getf default-initargs initarg *empty-condition-slot*))) - (unless (eq val *empty-condition-slot*) - (return-from find-slot-default - (if (functionp val) - (funcall val) - val))))))) + (let ((initfunction (third (assoc initarg direct-default-initargs)))) + (when initfunction + (return-from find-slot-default (funcall initfunction))))))) + ;; Otherwise use the initform of SLOT, if there is one. (if (condition-slot-initform-p slot) - (let ((initform (condition-slot-initform slot))) - (if (functionp initform) - (funcall initform) - initform)) + (let ((initfun (condition-slot-initfunction slot))) + (aver (functionp initfun)) + (funcall initfun)) (error "unbound condition slot: ~S" (condition-slot-name slot))))) (defun find-condition-class-slot (condition-class slot-name) @@ -248,18 +236,15 @@ ;;;; MAKE-CONDITION -(defun make-condition (type &rest args) - #!+sb-doc - "Make an instance of a condition object using the specified initargs." - ;; Note: ANSI specifies no exceptional situations in this function. - ;; signalling simple-type-error would not be wrong. - (let* ((type (or (and (symbolp type) (find-classoid type nil)) - type)) +(defun allocate-condition (type &rest initargs) + (let* ((type (if (symbolp type) + (find-classoid type nil) + type)) (class (typecase type (condition-classoid type) (class - ;; Punt to CLOS. - (return-from make-condition (apply #'make-instance type args))) + (return-from allocate-condition + (apply #'allocate-condition (class-name type) initargs))) (classoid (error 'simple-type-error :datum type @@ -270,25 +255,40 @@ (error 'simple-type-error :datum type :expected-type 'condition-class - :format-control "Bad type argument:~% ~S" + :format-control + "~s does not designate a condition class." :format-arguments (list type))))) - (res (make-condition-object args))) - (setf (%instance-layout res) (classoid-layout class)) + (condition (%make-condition-object initargs '()))) + (setf (%instance-layout condition) (classoid-layout class)) + (values condition class))) + +(defun make-condition (type &rest initargs) + #!+sb-doc + "Make an instance of a condition object using the specified initargs." + ;; Note: ANSI specifies no exceptional situations in this function. + ;; signalling simple-type-error would not be wrong. + (multiple-value-bind (condition class) + (apply #'allocate-condition type initargs) + ;; Set any class slots with initargs present in this call. (dolist (cslot (condition-classoid-class-slots class)) (dolist (initarg (condition-slot-initargs cslot)) - (let ((val (getf args initarg *empty-condition-slot*))) + (let ((val (getf initargs initarg *empty-condition-slot*))) (unless (eq val *empty-condition-slot*) (setf (car (condition-slot-cell cslot)) val))))) + ;; Default any slots with non-constant defaults now. (dolist (hslot (condition-classoid-hairy-slots class)) (when (dolist (initarg (condition-slot-initargs hslot) t) - (unless (eq (getf args initarg *empty-condition-slot*) + (unless (eq (getf initargs initarg *empty-condition-slot*) *empty-condition-slot*) (return nil))) - (setf (getf (condition-assigned-slots res) (condition-slot-name hslot)) + (setf (getf (condition-assigned-slots condition) + (condition-slot-name hslot)) (find-slot-default class hslot)))) - res)) + + condition)) + ;;;; DEFINE-CONDITION @@ -364,7 +364,9 @@ (setf (condition-slot-initform-p found) (condition-slot-initform-p sslot)) (setf (condition-slot-initform found) - (condition-slot-initform sslot))) + (condition-slot-initform sslot)) + (setf (condition-slot-initfunction sslot) + (condition-slot-initfunction found))) (unless (condition-slot-allocation found) (setf (condition-slot-allocation found) (condition-slot-allocation sslot)))) @@ -393,8 +395,12 @@ (defvar *define-condition-hooks* nil) +(defun %set-condition-report (name report) + (setf (condition-classoid-report (find-classoid name)) + report)) + (defun %define-condition (name parent-types layout slots documentation - report default-initargs all-readers all-writers + direct-default-initargs all-readers all-writers source-location) (with-single-package-locked-error (:symbol name "defining ~A as a condition") @@ -403,10 +409,9 @@ (setf (layout-source-location layout) source-location)) (let ((class (find-classoid name))) - (setf (condition-classoid-slots class) slots) - (setf (condition-classoid-report class) report) - (setf (condition-classoid-default-initargs class) default-initargs) - (setf (fdocumentation name 'type) documentation) + (setf (condition-classoid-slots class) slots + (condition-classoid-direct-default-initargs class) direct-default-initargs + (fdocumentation name 'type) documentation) (dolist (slot slots) @@ -419,28 +424,29 @@ ;; Compute effective slots and set up the class and hairy slots ;; (subsets of the effective slots.) + (setf (condition-classoid-hairy-slots class) '()) (let ((eslots (compute-effective-slots class)) (e-def-initargs (reduce #'append - (mapcar #'condition-classoid-default-initargs - (condition-classoid-cpl class))))) + (mapcar #'condition-classoid-direct-default-initargs + (condition-classoid-cpl class))))) (dolist (slot eslots) (ecase (condition-slot-allocation slot) (:class (unless (condition-slot-cell slot) (setf (condition-slot-cell slot) (list (if (condition-slot-initform-p slot) - (let ((initform (condition-slot-initform slot))) - (if (functionp initform) - (funcall initform) - initform)) + (let ((initfun (condition-slot-initfunction slot))) + (aver (functionp initfun)) + (funcall initfun)) *empty-condition-slot*)))) (push slot (condition-classoid-class-slots class))) ((:instance nil) (setf (condition-slot-allocation slot) :instance) - (when (or (functionp (condition-slot-initform slot)) + ;; FIXME: isn't this "always hairy"? + (when (or (functionp (condition-slot-initfunction slot)) (dolist (initarg (condition-slot-initargs slot) nil) - (when (functionp (getf e-def-initargs initarg)) + (when (functionp (third (assoc initarg e-def-initargs))) (return t)))) (push slot (condition-classoid-hairy-slots class))))))) (when (boundp '*define-condition-hooks*) @@ -472,7 +478,7 @@ (layout (find-condition-layout name parent-types)) (documentation nil) (report nil) - (default-initargs ())) + (direct-default-initargs ())) (collect ((slots) (all-readers nil append) (all-writers nil append)) @@ -528,10 +534,10 @@ :writers ',(writers) :initform-p ',initform-p :documentation ',documentation - :initform - ,(if (sb!xc:constantp initform) - `',(constant-form-value initform) - `#'(lambda () ,initform))))))) + :initform ,(when initform-p `',initform) + :initfunction ,(when initform-p + `#'(lambda () ,initform)) + :allocation ',allocation))))) (dolist (option options) (unless (consp option) @@ -543,20 +549,14 @@ (setq report (if (stringp arg) `#'(lambda (condition stream) - (declare (ignore condition)) - (write-string ,arg stream)) + (declare (ignore condition)) + (write-string ,arg stream)) `#'(lambda (condition stream) - (funcall #',arg condition stream)))))) + (funcall #',arg condition stream)))))) (:default-initargs - (do ((initargs (rest option) (cddr initargs))) - ((endp initargs)) - (let ((val (second initargs))) - (setq default-initargs - (list* `',(first initargs) - (if (sb!xc:constantp val) - `',(constant-form-value val) - `#'(lambda () ,val)) - default-initargs))))) + (doplist (initarg initform) (rest option) + (push ``(,',initarg ,',initform ,#'(lambda () ,initform)) + direct-default-initargs))) (t (error "unknown option: ~S" (first option))))) @@ -570,25 +570,16 @@ ',layout (list ,@(slots)) ,documentation - ,report - (list ,@default-initargs) + (list ,@direct-default-initargs) ',(all-readers) ',(all-writers) - (sb!c:source-location))))))) - -;;;; DESCRIBE on CONDITIONs - -;;; a function to be used as the guts of DESCRIBE-OBJECT (CONDITION T) -;;; eventually (once we get CLOS up and running so that we can define -;;; methods) -(defun describe-condition (condition stream) - (format stream - "~&~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>~%" - condition - (type-of condition) - (concatenate 'list - (condition-actual-initargs condition) - (condition-assigned-slots condition)))) + (sb!c:source-location)) + ;; This needs to be after %DEFINE-CONDITION in case :REPORT + ;; is a lambda referring to condition slot accessors: + ;; they're not proclaimed as functions before it has run if + ;; we're under EVAL or loaded as source. + (%set-condition-report ',name ,report) + ',name))))) ;;;; various CONDITIONs specified by ANSI @@ -600,18 +591,21 @@ (define-condition style-warning (warning) ()) (defun simple-condition-printer (condition stream) - (apply #'format - stream - (simple-condition-format-control condition) - (simple-condition-format-arguments condition))) + (let ((control (simple-condition-format-control condition))) + (if control + (apply #'format stream + control + (simple-condition-format-arguments condition)) + (error "No format-control for ~S" condition)))) (define-condition simple-condition () ((format-control :reader simple-condition-format-control :initarg :format-control + :initform nil :type format-control) (format-arguments :reader simple-condition-format-arguments :initarg :format-arguments - :initform '() + :initform nil :type list)) (:report simple-condition-printer)) @@ -631,10 +625,34 @@ (type-error-datum condition) (type-error-expected-type condition))))) +(def!method print-object ((condition type-error) stream) + (if (and *print-escape* + (slot-boundp condition 'expected-type) + (slot-boundp condition 'datum)) + (flet ((maybe-string (thing) + (ignore-errors + (write-to-string thing :lines 1 :readably nil :array nil :pretty t)))) + (let ((type (maybe-string (type-error-expected-type condition))) + (datum (maybe-string (type-error-datum condition)))) + (if (and type datum) + (print-unreadable-object (condition stream :type t) + (format stream "~@" type datum)) + (call-next-method)))) + (call-next-method))) + ;;; not specified by ANSI, but too useful not to have around. (define-condition simple-style-warning (simple-condition style-warning) ()) (define-condition simple-type-error (simple-condition type-error) ()) +;; Can't have a function called SIMPLE-TYPE-ERROR or TYPE-ERROR... +(declaim (ftype (sfunction (t t t &rest t) nil) bad-type)) +(defun bad-type (datum type control &rest arguments) + (error 'simple-type-error + :datum datum + :expected-type type + :format-control control + :format-arguments arguments)) + (define-condition program-error (error) ()) (define-condition parse-error (error) ()) (define-condition control-error (error) ()) @@ -681,9 +699,10 @@ (define-condition undefined-function (cell-error) () (:report (lambda (condition stream) - (format stream - "The function ~S is undefined." - (cell-error-name condition))))) + (let ((*package* (find-package :keyword))) + (format stream + "The function ~S is undefined." + (cell-error-name condition)))))) (define-condition special-form-function (undefined-function) () (:report @@ -747,45 +766,17 @@ ;;; ;;; When SIMPLE, we expect and use SIMPLE-CONDITION-ish FORMAT-CONTROL ;;; and FORMAT-ARGS slots. -(defun %report-reader-error (condition stream &key simple) - (let* ((error-stream (stream-error-stream condition)) - (pos (file-position-or-nil-for-error error-stream))) - (let (lineno colno) - (when (and pos - (< pos sb!xc:array-dimension-limit) - ;; KLUDGE: lseek() (which is what FILE-POSITION - ;; reduces to on file-streams) is undefined on - ;; "some devices", which in practice means that it - ;; can claim to succeed on /dev/stdin on Darwin - ;; and Solaris. This is obviously bad news, - ;; because the READ-SEQUENCE below will then - ;; block, not complete, and the report will never - ;; be printed. As a workaround, we exclude - ;; interactive streams from this attempt to report - ;; positions. -- CSR, 2003-08-21 - (not (interactive-stream-p error-stream)) - (file-position error-stream :start)) - (let ((string - (make-string pos - :element-type (stream-element-type - error-stream)))) - (when (= pos (read-sequence string error-stream)) - (setq lineno (1+ (count #\Newline string)) - colno (- pos - (or (position #\Newline string :from-end t) -1) - 1)))) - (file-position-or-nil-for-error error-stream pos)) - (pprint-logical-block (stream nil) - (format stream - "~S ~@[at ~W ~]~ - ~@[(line ~W~]~@[, column ~W) ~]~ - on ~S" - (class-name (class-of condition)) - pos lineno colno error-stream) - (when simple - (format stream ":~2I~_~?" - (simple-condition-format-control condition) - (simple-condition-format-arguments condition))))))) +(defun %report-reader-error (condition stream &key simple position) + (let ((error-stream (stream-error-stream condition))) + (pprint-logical-block (stream nil) + (if simple + (apply #'format stream + (simple-condition-format-control condition) + (simple-condition-format-arguments condition)) + (prin1 (class-name (class-of condition)) stream)) + (format stream "~2I~@[~_~_~:{~:(~A~): ~S~:^, ~:_~}~]~_~_Stream: ~S" + (stream-error-position-info error-stream position) + error-stream)))) ;;;; special SBCL extension conditions @@ -911,6 +902,10 @@ (define-condition simple-reference-warning (reference-condition simple-warning) ()) +(define-condition arguments-out-of-domain-error + (arithmetic-error reference-condition) + ()) + (define-condition duplicate-definition (reference-condition warning) ((name :initarg :name :reader duplicate-definition-name)) (:report (lambda (c s) @@ -930,6 +925,12 @@ (define-condition package-at-variance (reference-condition simple-warning) () + (:default-initargs :references (list '(:ansi-cl :macro defpackage) + '(:sbcl :variable *on-package-variance*)))) + +(define-condition package-at-variance-error (reference-condition simple-condition + package-error) + () (:default-initargs :references (list '(:ansi-cl :macro defpackage)))) (define-condition defconstant-uneql (reference-condition error) @@ -957,6 +958,9 @@ (define-condition type-warning (reference-condition simple-warning) () (:default-initargs :references (list '(:sbcl :node "Handling of Types")))) +(define-condition type-style-warning (reference-condition simple-style-warning) + () + (:default-initargs :references (list '(:sbcl :node "Handling of Types")))) (define-condition local-argument-mismatch (reference-condition simple-warning) () @@ -977,7 +981,8 @@ ((name :initarg :name :reader implicit-generic-function-name)) (:report (lambda (condition stream) - (format stream "~@" + (format stream "~@" (implicit-generic-function-name condition))))) (define-condition extension-failure (reference-condition simple-error) @@ -991,22 +996,26 @@ #!+sb-package-locks (progn -(define-condition package-lock-violation (reference-condition package-error) - ((format-control :initform nil :initarg :format-control - :reader package-error-format-control) - (format-arguments :initform nil :initarg :format-arguments - :reader package-error-format-arguments)) +(define-condition package-lock-violation (package-error + reference-condition + simple-condition) + ((current-package :initform *package* + :reader package-lock-violation-in-package)) (:report (lambda (condition stream) - (let ((control (package-error-format-control condition))) + (let ((control (simple-condition-format-control condition)) + (error-package (package-name (package-error-package condition))) + (current-package (package-name (package-lock-violation-in-package condition)))) (if control (apply #'format stream - (format nil "~~@" - (package-name (package-error-package condition)) - control) - (package-error-format-arguments condition)) - (format stream "~@" - (package-name (package-error-package condition))))))) + (format nil "~~@" + error-package + control + current-package) + (simple-condition-format-arguments condition)) + (format stream "~@" + error-package + current-package))))) ;; no :default-initargs -- reference-stuff provided by the ;; signalling form in target-package.lisp #!+sb-doc @@ -1047,8 +1056,11 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (define-condition undefined-alien-function-error (undefined-alien-error) () (:report (lambda (condition stream) - (declare (ignore condition)) - (format stream "Attempt to call an undefined alien function.")))) + (if (and (slot-boundp condition 'name) + (cell-error-name condition)) + (format stream "The alien function ~s is undefined." + (cell-error-name condition)) + (format stream "Attempt to call an undefined alien function."))))) ;;;; various other (not specified by ANSI) CONDITIONs @@ -1061,15 +1073,6 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (define-condition encapsulated-condition (condition) ((condition :initarg :condition :reader encapsulated-condition))) -(define-condition values-type-error (type-error) - () - (:report - (lambda (condition stream) - (format stream - "~@" - (type-error-datum condition) - (type-error-expected-type condition))))) - ;;; KLUDGE: a condition for floating point errors when we can't or ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we ;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably @@ -1186,7 +1189,7 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (define-condition simple-package-error (simple-condition package-error) ()) -(define-condition simple-reader-package-error (simple-reader-error) ()) +(define-condition simple-reader-package-error (simple-reader-error package-error) ()) (define-condition reader-eof-error (end-of-file) ((context :reader reader-eof-error-context :initarg :context)) @@ -1217,6 +1220,17 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (:default-initargs :references `((:ansi-cl :section (2 1 1 2)) (:ansi-cl :glossary "standard readtable")))) +(define-condition standard-pprint-dispatch-table-modified-error + (reference-condition error) + ((operation :initarg :operation + :reader standard-pprint-dispatch-table-modified-operation)) + (:report (lambda (condition stream) + (format stream "~S would modify the standard pprint dispatch table." + (standard-pprint-dispatch-table-modified-operation + condition)))) + (:default-initargs + :references `((:ansi-cl :glossary "standard pprint dispatch table")))) + (define-condition timeout (serious-condition) ((seconds :initarg :seconds :initform nil :reader timeout-seconds)) (:report (lambda (condition stream) @@ -1229,7 +1243,7 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (lambda (condition stream) (declare (type stream stream)) (format stream - "I/O timeout ~(~A~)ing ~S." + "I/O timeout while doing ~(~A~) on ~S." (io-timeout-direction condition) (stream-error-stream condition))))) @@ -1317,40 +1331,41 @@ handled by any other handler, it will be muffled.") ;; redefinitions, but other redefinitions could be done later ;; (e.g. methods). (define-condition redefinition-warning (style-warning) - ()) + ((name + :initarg :name + :reader redefinition-warning-name) + (new-location + :initarg :new-location + :reader redefinition-warning-new-location))) (define-condition function-redefinition-warning (redefinition-warning) - ((name :initarg :name :reader function-redefinition-warning-name) - (old :initarg :old :reader function-redefinition-warning-old-fdefinition) - ;; For DEFGENERIC and perhaps others, the redefinition - ;; destructively modifies the original, rather than storing a new - ;; object, so there's no NEW here, but only in subclasses. - )) + ((new-function + :initarg :new-function + :reader function-redefinition-warning-new-function))) (define-condition redefinition-with-defun (function-redefinition-warning) - ((new :initarg :new :reader redefinition-with-defun-new-fdefinition) - ;; KLUDGE: it would be nice to fix the unreasonably late - ;; back-patching of DEBUG-SOURCEs in the DEBUG-INFO during - ;; fasloading and just use the new fdefinition, but for the moment - ;; we'll compare the SOURCE-LOCATION created during DEFUN with the - ;; previous DEBUG-SOURCE. - (new-location :initarg :new-location - :reader redefinition-with-defun-new-location)) + () + (:report (lambda (warning stream) + (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~ + in DEFUN" + (redefinition-warning-name warning))))) + +(define-condition redefinition-with-defmacro (function-redefinition-warning) + () (:report (lambda (warning stream) - (format stream "redefining ~S in DEFUN" - (function-redefinition-warning-name warning))))) + (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~ + in DEFMACRO" + (redefinition-warning-name warning))))) -(define-condition redefinition-with-defgeneric (function-redefinition-warning) - ((new-location :initarg :new-location - :reader redefinition-with-defgeneric-new-location)) +(define-condition redefinition-with-defgeneric (redefinition-warning) + () (:report (lambda (warning stream) - (format stream "redefining ~S in DEFGENERIC" - (function-redefinition-warning-name warning))))) + (format stream "redefining ~/sb-impl::print-symbol-with-prefix/ ~ + in DEFGENERIC" + (redefinition-warning-name warning))))) (define-condition redefinition-with-defmethod (redefinition-warning) - ((gf :initarg :generic-function - :reader redefinition-with-defmethod-generic-function) - (qualifiers :initarg :qualifiers + ((qualifiers :initarg :qualifiers :reader redefinition-with-defmethod-qualifiers) (specializers :initarg :specializers :reader redefinition-with-defmethod-specializers) @@ -1360,135 +1375,104 @@ handled by any other handler, it will be muffled.") :reader redefinition-with-defmethod-old-method)) (:report (lambda (warning stream) (format stream "redefining ~S~{ ~S~} ~S in DEFMETHOD" - (redefinition-with-defmethod-generic-function warning) + (redefinition-warning-name warning) (redefinition-with-defmethod-qualifiers warning) (redefinition-with-defmethod-specializers warning))))) -;; FIXME: see the FIXMEs in defmacro.lisp, then maybe instantiate this. -(define-condition redefinition-with-defmacro (function-redefinition-warning) - ()) +;;;; Deciding which redefinitions are "interesting". + +(defun function-file-namestring (function) + #!+sb-eval + (when (typep function 'sb!eval:interpreted-function) + (return-from function-file-namestring + (sb!c:definition-source-location-namestring + (sb!eval:interpreted-function-source-location function)))) + (let* ((fun (sb!kernel:%fun-fun function)) + (code (sb!kernel:fun-code-header fun)) + (debug-info (sb!kernel:%code-debug-info code)) + (debug-source (when debug-info + (sb!c::debug-info-source debug-info))) + (namestring (when debug-source + (sb!c::debug-source-namestring debug-source)))) + namestring)) + +(defun interesting-function-redefinition-warning-p (warning old) + (let ((new (function-redefinition-warning-new-function warning)) + (source-location (redefinition-warning-new-location warning))) + (or + ;; compiled->interpreted is interesting. + (and (typep old 'compiled-function) + (typep new '(not compiled-function))) + ;; fin->regular is interesting except for interpreted->compiled. + (and (typep old '(and funcallable-instance + #!+sb-eval (not sb!eval:interpreted-function))) + (typep new '(not funcallable-instance))) + ;; different file or unknown location is interesting. + (let* ((old-namestring (function-file-namestring old)) + (new-namestring + (or (function-file-namestring new) + (when source-location + (sb!c::definition-source-location-namestring source-location))))) + (and (or (not old-namestring) + (not new-namestring) + (not (string= old-namestring new-namestring)))))))) -;; Here are a few predicates for what people might find interesting -;; about redefinitions. - -;; DEFUN can replace a generic function with an ordinary function. -;; (Attempting to replace an ordinary function with a generic one -;; causes an error, though.) -(defun redefinition-replaces-generic-function-p (warning) - (and (typep warning 'redefinition-with-defun) - (typep (function-redefinition-warning-old-fdefinition warning) - 'generic-function))) - -(defun redefinition-replaces-compiled-function-with-interpreted-p (warning) - (and (typep warning 'redefinition-with-defun) - (compiled-function-p - (function-redefinition-warning-old-fdefinition warning)) - (not (compiled-function-p - (redefinition-with-defun-new-fdefinition warning))))) - -;; Most people seem to agree that re-running a DEFUN in a file is -;; completely uninteresting. (defun uninteresting-ordinary-function-redefinition-p (warning) - ;; OAOO violation: this duplicates code in SB-INTROSPECT. - ;; Additionally, there are some functions that aren't - ;; funcallable-instances for which finding the source location is - ;; complicated (e.g. DEFSTRUCT-defined predicates and accessors), - ;; but I don't think they're defined with %DEFUN, so the warning - ;; isn't raised. - (flet ((fdefinition-file-namestring (fdefn) - #!+sb-eval - (when (typep fdefn 'sb!eval:interpreted-function) - (return-from fdefinition-file-namestring - (sb!c:definition-source-location-namestring - (sb!eval:interpreted-function-source-location fdefn)))) - ;; All the following accesses are guarded with conditionals - ;; because it's not clear whether any of the slots we're - ;; chasing down are guaranteed to be filled in. - (let* ((fdefn - ;; KLUDGE: although this looks like it only works - ;; for %SIMPLE-FUNs, in fact there's a pun such - ;; that %SIMPLE-FUN-SELF returns the simple-fun - ;; object for closures and - ;; funcallable-instances. -- CSR, circa 2005 - (sb!kernel:%simple-fun-self fdefn)) - (code (if fdefn (sb!kernel:fun-code-header fdefn))) - (debug-info (if code (sb!kernel:%code-debug-info code))) - (debug-source (if debug-info - (sb!c::debug-info-source debug-info))) - (namestring (if debug-source - (sb!c::debug-source-namestring debug-source)))) - namestring))) - (and - ;; There's garbage in various places when the first DEFUN runs in - ;; cold-init. - sb!kernel::*cold-init-complete-p* - (typep warning 'redefinition-with-defun) - (let ((old-fdefn - (function-redefinition-warning-old-fdefinition warning)) - (new-fdefn - (redefinition-with-defun-new-fdefinition warning))) - ;; Replacing a compiled function with a compiled function is - ;; clearly uninteresting, and we'll say arbitrarily that - ;; replacing an interpreted function with an interpreted - ;; function is uninteresting, too, but leave out the - ;; compiled-to-interpreted case. - (when (or (typep - old-fdefn - '(or #!+sb-eval sb!eval:interpreted-function)) - (and (typep old-fdefn - '(and compiled-function - (not funcallable-instance))) - ;; Since this is a REDEFINITION-WITH-DEFUN, - ;; NEW-FDEFN can't be a FUNCALLABLE-INSTANCE. - (typep new-fdefn 'compiled-function))) - (let* ((old-namestring (fdefinition-file-namestring old-fdefn)) - (new-namestring - (or (fdefinition-file-namestring new-fdefn) - (let ((srcloc - (redefinition-with-defun-new-location warning))) - (if srcloc - (sb!c::definition-source-location-namestring - srcloc)))))) - (and old-namestring - new-namestring - (equal old-namestring new-namestring)))))))) + (and + ;; There's garbage in various places when the first DEFUN runs in + ;; cold-init. + sb!kernel::*cold-init-complete-p* + (typep warning 'redefinition-with-defun) + ;; Shared logic. + (let ((name (redefinition-warning-name warning))) + (not (interesting-function-redefinition-warning-p + warning (or (fdefinition name) (macro-function name))))))) + +(defun uninteresting-macro-redefinition-p (warning) + (and + (typep warning 'redefinition-with-defmacro) + ;; Shared logic. + (let ((name (redefinition-warning-name warning))) + (not (interesting-function-redefinition-warning-p + warning (or (macro-function name) (fdefinition name))))))) (defun uninteresting-generic-function-redefinition-p (warning) - (and (typep warning 'redefinition-with-defgeneric) - (let* ((old-fdefn - (function-redefinition-warning-old-fdefinition warning)) - (old-location - (if (typep old-fdefn 'generic-function) - (sb!pcl::definition-source old-fdefn))) - (old-namestring - (if old-location - (sb!c:definition-source-location-namestring old-location))) - (new-location - (redefinition-with-defgeneric-new-location warning)) - (new-namestring - (if new-location - (sb!c:definition-source-location-namestring new-location)))) - (and old-namestring - new-namestring - (equal old-namestring new-namestring))))) + (and + (typep warning 'redefinition-with-defgeneric) + ;; Can't use the shared logic above, since GF's don't get a "new" + ;; definition -- rather the FIN-FUNCTION is set. + (let* ((name (redefinition-warning-name warning)) + (old (fdefinition name)) + (old-location (when (typep old 'generic-function) + (sb!pcl::definition-source old))) + (old-namestring (when old-location + (sb!c:definition-source-location-namestring old-location))) + (new-location (redefinition-warning-new-location warning)) + (new-namestring (when new-location + (sb!c:definition-source-location-namestring new-location)))) + (and old-namestring + new-namestring + (string= old-namestring new-namestring))))) (defun uninteresting-method-redefinition-p (warning) - (and (typep warning 'redefinition-with-defmethod) - (let* ((old-method (redefinition-with-defmethod-old-method warning)) - (old-location (sb!pcl::definition-source old-method)) - (old-namestring (if old-location - (sb!c:definition-source-location-namestring - old-location))) - (new-location (redefinition-with-defmethod-new-location warning)) - (new-namestring (if new-location - (sb!c:definition-source-location-namestring - new-location)))) + (and + (typep warning 'redefinition-with-defmethod) + ;; Can't use the shared logic above, since GF's don't get a "new" + ;; definition -- rather the FIN-FUNCTION is set. + (let* ((old-method (redefinition-with-defmethod-old-method warning)) + (old-location (sb!pcl::definition-source old-method)) + (old-namestring (when old-location + (sb!c:definition-source-location-namestring old-location))) + (new-location (redefinition-warning-new-location warning)) + (new-namestring (when new-location + (sb!c:definition-source-location-namestring new-location)))) (and new-namestring old-namestring - (equal new-namestring old-namestring))))) + (string= new-namestring old-namestring))))) (deftype uninteresting-redefinition () '(or (satisfies uninteresting-ordinary-function-redefinition-p) + (satisfies uninteresting-macro-redefinition-p) (satisfies uninteresting-generic-function-redefinition-p) (satisfies uninteresting-method-redefinition-p))) @@ -1608,6 +1592,67 @@ the usual naming convention (names like *FOO*) for special variables" (proclamation-mismatch-name warning) (proclamation-mismatch-old warning))))) +;;;; deprecation conditions + +(define-condition deprecation-condition () + ((name :initarg :name :reader deprecated-name) + (replacements :initarg :replacements :reader deprecated-name-replacements) + (since :initarg :since :reader deprecated-since) + (runtime-error :initarg :runtime-error :reader deprecated-name-runtime-error))) + +(def!method print-object ((condition deprecation-condition) stream) + (let ((*package* (find-package :keyword))) + (if *print-escape* + (print-unreadable-object (condition stream :type t) + (apply #'format + stream "~S is deprecated.~ + ~#[~; Use ~S instead.~; ~ + Use ~S or ~S instead.~:; ~ + Use~@{~#[~; or~] ~S~^,~} instead.~]" + (deprecated-name condition) + (deprecated-name-replacements condition))) + (apply #'format + stream "~@<~S has been deprecated as of SBCL ~A.~ + ~#[~; Use ~S instead.~; ~ + Use ~S or ~S instead.~:; ~ + Use~@{~#[~; or~] ~S~^,~:_~} instead.~]~:@>" + (deprecated-name condition) + (deprecated-since condition) + (deprecated-name-replacements condition))))) + +(define-condition early-deprecation-warning (style-warning deprecation-condition) + ()) + +(def!method print-object :after ((warning early-deprecation-warning) stream) + (unless *print-escape* + (let ((*package* (find-package :keyword))) + (format stream "~%~@<~:@_In future SBCL versions ~S will signal a full warning ~ + at compile-time.~:@>" + (deprecated-name warning))))) + +(define-condition late-deprecation-warning (warning deprecation-condition) + ()) + +(def!method print-object :after ((warning late-deprecation-warning) stream) + (unless *print-escape* + (when (deprecated-name-runtime-error warning) + (let ((*package* (find-package :keyword))) + (format stream "~%~@<~:@_In future SBCL versions ~S will signal a runtime error.~:@>" + (deprecated-name warning)))))) + +(define-condition final-deprecation-warning (warning deprecation-condition) + ()) + +(def!method print-object :after ((warning final-deprecation-warning) stream) + (unless *print-escape* + (when (deprecated-name-runtime-error warning) + (let ((*package* (find-package :keyword))) + (format stream "~%~@<~:@_An error will be signaled at runtime for ~S.~:@>" + (deprecated-name warning)))))) + +(define-condition deprecation-error (error deprecation-condition) + ()) + ;;;; restart definitions (define-condition abort-failure (control-error) () @@ -1643,11 +1688,14 @@ the usual naming convention (names like *FOO*) for special variables" (define-nil-returning-restart continue () "Transfer control to a restart named CONTINUE, or return NIL if none exists.") (define-nil-returning-restart store-value (value) - "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if - none exists.") + "Transfer control and VALUE to a restart named STORE-VALUE, or +return NIL if none exists.") (define-nil-returning-restart use-value (value) - "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if - none exists.")) + "Transfer control and VALUE to a restart named USE-VALUE, or +return NIL if none exists.") + (define-nil-returning-restart print-unreadably () + "Transfer control to a restart named SB-EXT:PRINT-UNREADABLY, or +return NIL if none exists.")) ;;; single-stepping restarts @@ -1670,5 +1718,14 @@ not exists.") condition, stepping into the current form. Signals a CONTROL-ERROR is the restart does not exist.")) -(/show0 "condition.lisp end of file") +;;; Compiler macro magic + +(define-condition compiler-macro-keyword-problem () + ((argument :initarg :argument :reader compiler-macro-keyword-argument)) + (:report (lambda (condition stream) + (format stream "~@" + (compiler-macro-keyword-argument condition))))) +(/show0 "condition.lisp end of file")