X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=a1d40d5f6d42e915814104b6a20da133f1d91ff7;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=3562d0c4462ec8817e4da291eecc2d5f6e174f6d;hpb=ac93aa515b197d751dad85d70432ebc87fac420a;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 3562d0c..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))) @@ -193,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) @@ -253,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 @@ -275,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 @@ -369,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)))) @@ -403,7 +400,7 @@ report)) (defun %define-condition (name parent-types layout slots documentation - 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") @@ -412,9 +409,9 @@ (setf (layout-source-location layout) source-location)) (let ((class (find-classoid name))) - (setf (condition-classoid-slots class) slots) - (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) @@ -427,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*) @@ -480,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)) @@ -536,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) @@ -556,15 +554,9 @@ `#'(lambda (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))))) @@ -578,7 +570,7 @@ ',layout (list ,@(slots)) ,documentation - (list ,@default-initargs) + (list ,@direct-default-initargs) ',(all-readers) ',(all-writers) (sb!c:source-location)) @@ -586,7 +578,8 @@ ;; 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)))))) + (%set-condition-report ',name ,report) + ',name))))) ;;;; various CONDITIONs specified by ANSI @@ -633,7 +626,9 @@ (type-error-expected-type condition))))) (def!method print-object ((condition type-error) stream) - (if *print-escape* + (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)))) @@ -704,9 +699,10 @@ (define-condition undefined-function (cell-error) () (:report (lambda (condition stream) - (format stream - "The function ~/sb-impl::print-symbol-with-prefix/ 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 @@ -766,29 +762,6 @@ (:report (lambda (condition stream) (%report-reader-error condition stream :simple t)))) -(defun stream-error-position-info (stream &optional position) - (unless (interactive-stream-p stream) - (let ((now (file-position-or-nil-for-error stream)) - (pos position)) - (when (and (not pos) now (plusp now)) - ;; FILE-POSITION is the next character -- error is at the previous one. - (setf pos (1- now))) - (let (lineno colno) - (when (and pos - (< pos sb!xc:array-dimension-limit) - (file-position stream :start)) - (let ((string - (make-string pos :element-type (stream-element-type stream)))) - (when (= pos (read-sequence string stream)) - ;; Lines count from 1, columns from 0. It's stupid and traditional. - (setq lineno (1+ (count #\Newline string)) - colno (- pos (or (position #\Newline string :from-end t) 0))))) - (file-position-or-nil-for-error stream now)) - (remove-if-not #'second - (list (list :line lineno) - (list :column colno) - (list :file-position pos))))))) - ;;; base REPORTing of a READER-ERROR ;;; ;;; When SIMPLE, we expect and use SIMPLE-CONDITION-ish FORMAT-CONTROL @@ -952,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) @@ -1002,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) @@ -1076,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 @@ -1417,13 +1400,14 @@ handled by any other handler, it will be muffled.") (let ((new (function-redefinition-warning-new-function warning)) (source-location (redefinition-warning-new-location warning))) (or - ;; Compiled->Interpreted is interesting. + ;; compiled->interpreted is interesting. (and (typep old 'compiled-function) (typep new '(not compiled-function))) - ;; FIN->Regular is interesting. - (and (typep old 'funcallable-instance) + ;; 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. + ;; different file or unknown location is interesting. (let* ((old-namestring (function-file-namestring old)) (new-namestring (or (function-file-namestring new) @@ -1612,7 +1596,7 @@ the usual naming convention (names like *FOO*) for special variables" (define-condition deprecation-condition () ((name :initarg :name :reader deprecated-name) - (replacement :initarg :replacement :reader deprecated-name-replacement) + (replacements :initarg :replacements :reader deprecated-name-replacements) (since :initarg :since :reader deprecated-since) (runtime-error :initarg :runtime-error :reader deprecated-name-runtime-error))) @@ -1620,14 +1604,21 @@ the usual naming convention (names like *FOO*) for special variables" (let ((*package* (find-package :keyword))) (if *print-escape* (print-unreadable-object (condition stream :type t) - (format stream "~S is deprecated~@[, use ~S~]" + (apply #'format + stream "~S is deprecated.~ + ~#[~; Use ~S instead.~; ~ + Use ~S or ~S instead.~:; ~ + Use~@{~#[~; or~] ~S~^,~} instead.~]" (deprecated-name condition) - (deprecated-name-replacement condition))) - (format stream "~@<~S has been deprecated as of SBCL ~A~ - ~@[, use ~S instead~].~:@>" + (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-replacement condition))))) + (deprecated-name-replacements condition))))) (define-condition early-deprecation-warning (style-warning deprecation-condition) ()) @@ -1727,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")