X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=f8e70f3cb595a59e3b42dabb40ddea77e29c2d94;hb=6f7128b46e9ca91de777f61e8623bf5d997b2987;hp=4e686efcff57db716bb3e222fab526ce0ec51dc5;hpb=784b195743728436795b90f95273c3535ebee9a5;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 4e686ef..f8e70f3 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -272,7 +272,10 @@ ;;;; DEFINE-CONDITION (eval-when (:compile-toplevel :load-toplevel :execute) -(defun %compiler-define-condition (name direct-supers layout) +(defun %compiler-define-condition (name direct-supers layout + all-readers all-writers) + (sb!xc:proclaim `(ftype (function (t) t) ,@all-readers)) + (sb!xc:proclaim `(ftype (function (t t) t) ,@all-writers)) (multiple-value-bind (class old-layout) (insured-find-classoid name #'condition-classoid-p @@ -313,7 +316,6 @@ (remove-if-not #'condition-classoid-p (std-compute-class-precedence-list class)))) (values)) - ) ; EVAL-WHEN ;;; Compute the effective slots of CLASS, copying inherited slots and @@ -365,7 +367,9 @@ (lambda (new-value condition) (condition-writer-function condition new-value slot-name)))) -(defun %define-condition (name slots documentation report default-initargs) +(defun %define-condition (name parent-types layout slots documentation + report default-initargs all-readers all-writers) + (%compiler-define-condition name parent-types layout all-readers all-writers) (let ((class (find-classoid name))) (setf (condition-classoid-slots class) slots) (setf (condition-classoid-report class) report) @@ -522,17 +526,19 @@ (error "unknown option: ~S" (first option))))) `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (%compiler-define-condition ',name ',parent-types ',layout)) - - (declaim (ftype (function (t) t) ,@(all-readers))) - (declaim (ftype (function (t t) t) ,@(all-writers))) - - (%define-condition ',name - (list ,@(slots)) - ,documentation - ,report - (list ,@default-initargs)))))) + (eval-when (:compile-toplevel) + (%compiler-define-condition ',name ',parent-types ',layout + ',(all-readers) ',(all-writers))) + (eval-when (:load-toplevel :execute) + (%define-condition ',name + ',parent-types + ',layout + (list ,@(slots)) + ,documentation + ,report + (list ,@default-initargs) + ',(all-readers) + ',(all-writers))))))) ;;;; DESCRIBE on CONDITIONs @@ -565,10 +571,12 @@ (define-condition simple-condition () ((format-control :reader simple-condition-format-control - :initarg :format-control) + :initarg :format-control + :type format-control) (format-arguments :reader simple-condition-format-arguments :initarg :format-arguments - :initform '())) + :initform '() + :type list)) (:report simple-condition-printer)) (define-condition simple-warning (simple-condition warning) ()) @@ -675,11 +683,39 @@ :initform '())) (:report (lambda (condition stream) - (let ((error-stream (stream-error-stream condition))) - (format stream "READER-ERROR ~@[at ~W ~]on ~S:~%~?" - (file-position error-stream) error-stream - (reader-error-format-control condition) - (reader-error-format-arguments condition)))))) + (let* ((error-stream (stream-error-stream condition)) + (pos (file-position 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 error-stream pos)) + (format stream + "READER-ERROR ~@[at ~W ~]~ + ~@[(line ~W~]~@[, column ~W) ~]~ + on ~S:~%~?" + pos lineno colno error-stream + (reader-error-format-control condition) + (reader-error-format-arguments condition))))))) ;;;; various other (not specified by ANSI) CONDITIONs ;;;; @@ -687,6 +723,8 @@ ;;;; setup of CONDITION machinery, only because that makes it easier to ;;;; get cold init to work. +(define-condition simple-style-warning (simple-condition style-warning) ()) + (define-condition values-type-error (type-error) () (:report @@ -751,6 +789,7 @@ (define-condition nil-array-accessed-error (type-error) () (:report (lambda (condition stream) + (declare (ignore condition)) (format stream "An attempt to access an array of element-type ~ NIL was made. Congratulations!")))) @@ -803,19 +842,7 @@ (reader-error-format-arguments condition) (reader-impossible-number-error-error condition)))))) -(define-condition sb!ext::timeout (serious-condition) ()) - -(define-condition defconstant-uneql (error) - ((name :initarg :name :reader defconstant-uneql-name) - (old-value :initarg :old-value :reader defconstant-uneql-old-value) - (new-value :initarg :new-value :reader defconstant-uneql-new-value)) - (:report - (lambda (condition stream) - (format stream - "~@" - (defconstant-uneql-name condition) - (defconstant-uneql-old-value condition) - (defconstant-uneql-new-value condition))))) +(define-condition timeout (serious-condition) ()) ;;;; special SBCL extension conditions @@ -848,10 +875,6 @@ mailing lists, which you can find at ~ .~:@>" '((fmakunbound 'compile)))))) -(defun bug (format-control &rest format-arguments) - (error 'bug - :format-control format-control - :format-arguments format-arguments)) ;;; a condition for use in stubs for operations which aren't supported ;;; on some platforms @@ -880,6 +903,112 @@ "unsupported on this platform (OS, CPU, whatever): ~S" (cell-error-name condition))))) +;;; (:ansi-cl :function remove) +;;; (:ansi-cl :section (a b c)) +;;; (:ansi-cl :glossary "similar") +;;; +;;; (:sbcl :node "...") +;;; (:sbcl :variable *ed-functions*) +;;; +;;; FIXME: this is not the right place for this. +(defun print-reference (reference stream) + (ecase (car reference) + (:ansi-cl + (format stream "The ANSI Standard") + (format stream ", ") + (destructuring-bind (type data) (cdr reference) + (ecase type + (:function (format stream "Function ~S" data)) + (:special-operator (format stream "Special Operator ~S" data)) + (:macro (format stream "Macro ~S" data)) + (:section (format stream "Section ~{~D~^.~}" data)) + (:glossary (format stream "Glossary Entry ~S" data))))) + (:sbcl + (format stream "The SBCL Manual") + (format stream ", ") + (destructuring-bind (type data) (cdr reference) + (ecase type + (:node (format stream "Node ~S" data)) + (:variable (format stream "Variable ~S" data))))) + ;; FIXME: other documents (e.g. AMOP, Franz documentation :-) + )) +(define-condition reference-condition () + ((references :initarg :references :reader reference-condition-references))) +(defvar *print-condition-references* t) +(def!method print-object :around ((o reference-condition) s) + (call-next-method) + (unless (or *print-escape* *print-readably*) + (when *print-condition-references* + (format s "~&See also:~%") + (pprint-logical-block (s nil :per-line-prefix " ") + (do* ((rs (reference-condition-references o) (cdr rs)) + (r (car rs) (car rs))) + ((null rs)) + (print-reference r s) + (unless (null (cdr rs)) + (terpri s))))))) + +(define-condition duplicate-definition (reference-condition warning) + ((name :initarg :name :reader duplicate-definition-name)) + (:report (lambda (c s) + (format s "~@" + (duplicate-definition-name c)))) + (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3))))) + +(define-condition package-at-variance (reference-condition simple-warning) + () + (:default-initargs :references (list '(:ansi-cl :macro defpackage)))) + +(define-condition defconstant-uneql (reference-condition error) + ((name :initarg :name :reader defconstant-uneql-name) + (old-value :initarg :old-value :reader defconstant-uneql-old-value) + (new-value :initarg :new-value :reader defconstant-uneql-new-value)) + (:report + (lambda (condition stream) + (format stream + "~@" + (defconstant-uneql-name condition) + (defconstant-uneql-old-value condition) + (defconstant-uneql-new-value condition)))) + (:default-initargs :references (list '(:ansi-cl :macro defconstant) + '(:sbcl :node "Idiosyncrasies")))) + +(define-condition array-initial-element-mismatch + (reference-condition simple-warning) + () + (:default-initargs + :references (list '(:ansi-cl :function make-array) + '(:ansi-cl :function upgraded-array-element-type)))) + +(define-condition displaced-to-array-too-small-error + (reference-condition simple-error) + () + (:default-initargs + :references (list '(:ansi-cl :function adjust-array)))) + +(define-condition type-warning (reference-condition simple-warning) + () + (:default-initargs :references (list '(:sbcl :node "Handling of Types")))) + +(define-condition local-argument-mismatch (reference-condition simple-warning) + () + (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3))))) + +(define-condition format-args-mismatch (reference-condition) + () + (:default-initargs :references (list '(:ansi-cl :section (22 3 10 2))))) + +(define-condition format-too-few-args-warning + (format-args-mismatch simple-warning) + ()) +(define-condition format-too-many-args-warning + (format-args-mismatch simple-style-warning) + ()) + +(define-condition extension-failure (reference-condition simple-error) + ()) + ;;;; restart definitions (define-condition abort-failure (control-error) ()