;; misc. utilities used internally
"LEGAL-FUNCTION-NAME-P"
"FUNCTION-NAME-BLOCK-NAME"
+ "WHITESPACE-CHAR-P"
"LISTEN-SKIP-WHITESPACE"
"PACKAGE-INTERNAL-SYMBOL-COUNT" "PACKAGE-EXTERNAL-SYMBOL-COUNT"
"PROPER-LIST-OF-LENGTH-P"
"%COERCE-CALLABLE-TO-FUNCTION"
"FUNCTION-SUBTYPE" "*MAXIMUM-ERROR-DEPTH*"
"%SET-SYMBOL-PLIST" "INFINITE-ERROR-PROTECT"
- "FIND-CALLER-NAME"
+ "FIND-CALLER-NAME-AND-FRAME"
"%SET-SYMBOL-VALUE" "%SET-SYMBOL-PACKAGE"
"OUTPUT-SYMBOL-NAME"
"FSET" "RAW-DEFINITION"
"MAKE-UNDEFINED-CLASS" "CLASS-DIRECT-SUPERCLASSES" "MAKE-LAYOUT"
"BYTE-FUNCTION-TYPE"
"REDEFINE-LAYOUT-WARNING" "SLOT-CLASS"
- "INSURED-FIND-CLASS" "CONDITION-FUNCTION-NAME"
+ "INSURED-FIND-CLASS"
;; symbols from former SB!CONDITIONS
"*HANDLER-CLUSTERS*" "*RESTART-CLUSTERS*"
:format-control "bad argument to ~S: ~S"
:format-arguments (list function-name datum)))))
+;;; a shared idiom in ERROR, CERROR, and BREAK: The user probably
+;;; doesn't want to hear that the error "occurred in" one of these
+;;; functions, so we try to point the top of the stack to our caller
+;;; instead.
+(eval-when (:compile-toplevel :execute)
+ (defmacro-mundanely maybe-find-stack-top-hint ()
+ `(or sb!debug:*stack-top-hint*
+ (nth-value 1 (sb!kernel:find-caller-name-and-frame)))))
+
(defun error (datum &rest arguments)
#!+sb-doc
"Invoke the signal facility on a condition formed from datum and arguments.
(sb!kernel:infinite-error-protect
(let ((condition (coerce-to-condition datum arguments
'simple-error 'error))
- ;; FIXME: Why is *STACK-TOP-HINT* in SB-DEBUG instead of SB-DI?
- ;; SB-DEBUG should probably be only for true interface stuff.
- (sb!debug:*stack-top-hint* sb!debug:*stack-top-hint*))
- (unless (and (condition-function-name condition)
- sb!debug:*stack-top-hint*)
- (multiple-value-bind (name frame) (sb!kernel:find-caller-name)
- (unless (condition-function-name condition)
- (setf (condition-function-name condition) name))
- (unless sb!debug:*stack-top-hint*
- (setf sb!debug:*stack-top-hint* frame))))
+ (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
(let ((sb!debug:*stack-top-hint* nil))
(signal condition))
(invoke-debugger condition))))
arguments
'simple-error
'error)))
- (sb!debug:*stack-top-hint* sb!debug:*stack-top-hint*))
- (unless (and (condition-function-name condition)
- sb!debug:*stack-top-hint*)
- (multiple-value-bind (name frame) (sb!kernel:find-caller-name)
- (unless (condition-function-name condition)
- (setf (condition-function-name condition) name))
- (unless sb!debug:*stack-top-hint*
- (setf sb!debug:*stack-top-hint* frame))))
+ (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
(with-condition-restarts condition (list (find-restart 'continue))
(let ((sb!debug:*stack-top-hint* nil))
(signal condition))
of condition handling occurring."
(sb!kernel:infinite-error-protect
(with-simple-restart (continue "Return from BREAK.")
- (let ((sb!debug:*stack-top-hint*
- (or sb!debug:*stack-top-hint*
- (nth-value 1 (sb!kernel:find-caller-name)))))
+ (let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
(invoke-debugger
(coerce-to-condition datum arguments 'simple-condition 'break)))))
nil)
()
(:report
(lambda (condition stream)
- (format stream "Layout-invalid error in ~S:~@
- Type test of class ~S was passed obsolete instance:~% ~S"
- (condition-function-name condition)
+ (format stream
+ "~@<invalid structure layout: ~
+ ~2I~_A test for class ~4I~_~S ~
+ ~2I~_was passed the obsolete instance ~4I~_~S~:>"
(sb!kernel:class-proper-name (type-error-expected-type condition))
(type-error-datum condition)))))
(possibilities :reader case-failure-possibilities :initarg :possibilities))
(:report
(lambda (condition stream)
- (format stream "~@<~S fell through ~S expression. ~:_Wanted one of ~:S.~:>"
+ (format stream "~@<~S fell through ~S expression. ~
+ ~:_Wanted one of ~:S.~:>"
(type-error-datum condition)
(case-failure-name condition)
(case-failure-possibilities condition)))))
(deferr object-not-function-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'function))
(deferr object-not-list-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'list))
(deferr object-not-bignum-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'bignum))
(deferr object-not-ratio-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'ratio))
(deferr object-not-single-float-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'single-float))
(deferr object-not-double-float-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'double-float))
#!+long-float
(deferr object-not-long-float-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'long-float))
(deferr object-not-simple-string-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'simple-string))
(deferr object-not-simple-bit-vector-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'simple-bit-vector))
(deferr object-not-simple-vector-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'simple-vector))
(deferr object-not-fixnum-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'fixnum))
(deferr object-not-function-or-symbol-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(or function symbol)))
(deferr object-not-vector-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'vector))
(deferr object-not-string-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'string))
(deferr object-not-bit-vector-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'bit-vector))
(deferr object-not-array-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'array))
(deferr object-not-number-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'number))
(deferr object-not-rational-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'rational))
(deferr object-not-float-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'float))
(deferr object-not-real-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'real))
(deferr object-not-integer-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'integer))
(deferr object-not-cons-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'cons))
(deferr object-not-symbol-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'symbol))
(deferr undefined-symbol-error (fdefn-or-symbol)
(error 'undefined-function
- :function-name name
:name (etypecase fdefn-or-symbol
(symbol fdefn-or-symbol)
(fdefn (fdefn-name fdefn-or-symbol)))))
(deferr object-not-coerceable-to-function-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'coerceable-to-function))
(deferr invalid-argument-count-error (nargs)
(error 'simple-program-error
- :function-name name
:format-control "invalid number of arguments: ~S"
:format-arguments (list nargs)))
(deferr bogus-argument-to-values-list-error (list)
(error 'simple-type-error
- :function-name name
:datum list
:expected-type 'list
:format-control
:format-arguments (list list)))
(deferr unbound-symbol-error (symbol)
- (error 'unbound-variable :function-name name :name symbol))
+ (error 'unbound-variable :name symbol))
(deferr object-not-base-char-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'base-char))
(deferr object-not-sap-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'system-area-pointer))
(deferr invalid-unwind-error ()
(error 'simple-control-error
- :function-name name
:format-control
- "attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
+ "attempt to RETURN-FROM a block or GO to a tag that no longer exists"
+ ))
(deferr unseen-throw-tag-error (tag)
(error 'simple-control-error
- :function-name name
:format-control "attempt to THROW to a tag that does not exist: ~S"
:format-arguments (list tag)))
(deferr nil-function-returned-error (function)
(error 'simple-control-error
- :function-name name
:format-control
"A function with declared result type NIL returned:~% ~S"
:format-arguments (list function)))
(deferr division-by-zero-error (this that)
(error 'division-by-zero
- :function-name name
:operation 'division
:operands (list this that)))
(layout-invalid (%instance-layout object)))
'layout-invalid
'type-error)
- :function-name name
:datum object
:expected-type type))
(deferr layout-invalid-error (object layout)
(error 'layout-invalid
- :function-name name
:datum object
:expected-type (layout-class layout)))
(deferr odd-key-arguments-error ()
(error 'simple-program-error
- :function-name name
:format-control "odd number of &KEY arguments"))
(deferr unknown-key-argument-error (key-name)
(error 'simple-program-error
- :function-name name
:format-control "unknown &KEY argument: ~S"
:format-arguments (list key-name)))
(deferr invalid-array-index-error (array bound index)
(error 'simple-error
- :function-name name
:format-control
"invalid array index ~D for ~S (should be nonnegative and <~D)"
:format-arguments (list index array bound)))
(deferr object-not-simple-array-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'simple-array))
(deferr object-not-signed-byte-32-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(signed-byte 32)))
(deferr object-not-unsigned-byte-32-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(unsigned-byte 32)))
(deferr object-not-simple-array-unsigned-byte-2-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(simple-array (unsigned-byte 2) (*))))
(deferr object-not-simple-array-unsigned-byte-4-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(simple-array (unsigned-byte 4) (*))))
(deferr object-not-simple-array-unsigned-byte-8-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(simple-array (unsigned-byte 8) (*))))
(deferr object-not-simple-array-unsigned-byte-16-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(simple-array (unsigned-byte 16) (*))))
(deferr object-not-simple-array-unsigned-byte-32-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(simple-array (unsigned-byte 32) (*))))
(deferr object-not-simple-array-signed-byte-8-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(simple-array (signed-byte 8) (*))))
(deferr object-not-simple-array-signed-byte-16-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(simple-array (signed-byte 16) (*))))
(deferr object-not-simple-array-signed-byte-30-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(simple-array (signed-byte 30) (*))))
(deferr object-not-simple-array-signed-byte-32-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(simple-array (signed-byte 32) (*))))
(deferr object-not-simple-array-single-float-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(simple-array single-float (*))))
(deferr object-not-simple-array-double-float-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(simple-array double-float (*))))
(deferr object-not-simple-array-complex-single-float-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(simple-array (complex single-float) (*))))
(deferr object-not-simple-array-complex-double-float-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(simple-array (complex double-float) (*))))
#!+long-float
(deferr object-not-simple-array-complex-long-float-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(simple-array (complex long-float) (*))))
(deferr object-not-complex-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'complex))
(deferr object-not-complex-rational-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(complex rational)))
(deferr object-not-complex-single-float-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(complex single-float)))
(deferr object-not-complex-double-float-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(complex double-float)))
#!+long-float
(deferr object-not-complex-long-float-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(complex long-float)))
(deferr object-not-weak-pointer-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'weak-pointer))
(deferr object-not-instance-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type 'instance))
(deferr object-not-complex-vector-error (object)
(error 'type-error
- :function-name name
:datum object
:expected-type '(and vector (not simple-array))))
\f
;;;; fetching errorful function name
-;;; This variable is used to prevent infinite recursive lossage when
+;;; This flag is used to prevent infinite recursive lossage when
;;; we can't find the caller for some reason.
(defvar *finding-name* nil)
-(defun find-caller-name ()
+(defun find-caller-name-and-frame ()
(if *finding-name*
(values "<error finding caller name -- already finding name>" nil)
(handler-case
(svref *internal-errors* error-number))))
(cond ((null handler)
(error 'simple-error
- :function-name name
:format-control
"unknown internal error, ~D? args=~S"
:format-arguments
arguments))))
((not (functionp handler))
(error 'simple-error
- :function-name name
:format-control "internal error ~D: ~A; args=~S"
:format-arguments
(list error-number
condition-class
make-condition-class)
(:copier nil))
-
- (function-name nil)
;; actual initargs supplied to MAKE-CONDITION
(actual-initargs (required-argument) :type list)
- ;; plist mapping slot names to any values that were assigned or
+ ;; a plist mapping slot names to any values that were assigned or
;; defaulted after creation
(assigned-slots () :type list))
(define-condition simple-warning (simple-condition warning) ())
-(defun print-simple-error (condition stream)
- (format stream
- ;; FIXME: It seems reasonable to display the "in function
- ;; ~S" information, but doesn't the logic to display it
- ;; belong in the debugger or someplace like that instead of
- ;; in the format string for this particular family of
- ;; conditions? Then this printer might look more
- ;; ("~@<~S: ~2I~:_~?~:>" (TYPE-OF C) ..) instead.
- "~@<error in function ~S: ~2I~:_~?~:>"
- (condition-function-name condition)
- (simple-condition-format-control condition)
- (simple-condition-format-arguments condition)))
-
-(define-condition simple-error (simple-condition error) ()
- ;; This is the condition type used by ERROR and CERROR when
- ;; a format-control string is supplied as the first argument.
- (:report print-simple-error))
+;;; This is the condition type used by ERROR and CERROR when
+;;; a format-control string is supplied as the first argument.
+(define-condition simple-error (simple-condition error) ())
(define-condition storage-condition (serious-condition) ())
-;;; FIXME: Should we really be reporting CONDITION-FUNCTION-NAME data
-;;; on an ad hoc basis, for some conditions and not others? Why not
-;;; standardize it somehow? perhaps by making the debugger report it?
-
(define-condition type-error (error)
((datum :reader type-error-datum :initarg :datum)
(expected-type :reader type-error-expected-type :initarg :expected-type))
(:report
(lambda (condition stream)
(format stream
- "~@<TYPE-ERROR in ~S: ~
- ~2I~_The value ~4I~:_~S ~2I~_is not of type ~4I~_~S.~:>"
- (condition-function-name condition)
+ "~@<The value ~2I~:_~S ~I~_is not of type ~2I~_~S.~:>"
(type-error-datum condition)
(type-error-expected-type condition)))))
(:report
(lambda (condition stream)
(format stream
- "END-OF-FILE on ~S"
+ "end of file on ~S"
(stream-error-stream condition)))))
(define-condition file-error (error)
(:report
(lambda (condition stream)
(format stream
- "~@<FILE-ERROR in function ~S: ~2I~:_~?~:>"
- (condition-function-name condition)
+ "~@<error on file ~_~S: ~2I~:_~?~:>"
+ (file-error-pathname condition)
+ ;; FIXME: ANSI's FILE-ERROR doesn't have FORMAT-CONTROL and
+ ;; FORMAT-ARGUMENTS, and the inheritance here doesn't seem
+ ;; to give us FORMAT-CONTROL or FORMAT-ARGUMENTS either.
+ ;; So how does this work?
(serious-condition-format-control condition)
(serious-condition-format-arguments condition)))))
(:report
(lambda (condition stream)
(format stream
- "error in ~S: The variable ~S is unbound."
- (condition-function-name condition)
+ "The variable ~S is unbound."
(cell-error-name condition)))))
(define-condition undefined-function (cell-error) ()
(:report
(lambda (condition stream)
(format stream
- "error in ~S: The function ~S is undefined."
- (condition-function-name condition)
+ "The function ~S is undefined."
(cell-error-name condition)))))
(define-condition arithmetic-error (error)
(format stream "~S cannot be printed readably." obj)))))
(define-condition reader-error (parse-error stream-error)
- ;; FIXME: Do we need FORMAT-CONTROL and FORMAT-ARGUMENTS when
- ;; we have an explicit :REPORT function? I thought we didn't..
((format-control
:reader reader-error-format-control
:initarg :format-control)
(:report
(lambda (condition stream)
(format stream
- "error in ~S: ~S: index too large"
- (condition-function-name condition)
+ "The index ~S is too large."
(type-error-datum condition)))))
(define-condition io-timeout (stream-error)
(lambda (condition stream)
(declare (type stream stream))
(format stream
- "IO-TIMEOUT ~(~A~)ing ~S"
+ "I/O timeout ~(~A~)ing ~S"
(io-timeout-direction condition)
(stream-error-stream condition)))))
(:report
(lambda (condition stream)
(format stream
- "unexpected EOF on ~S ~A"
+ "unexpected end of file on ~S ~A"
(stream-error-stream condition)
(reader-eof-error-context condition)))))
\f
(flet ((check-version (variant possible-implementation needed-version)
(when (string= possible-implementation implementation)
(unless (= version needed-version)
- (error "~@<~S was compiled for ~A fasl file format ~
- version ~D, but we need version ~D.~:@>"
+ (error "~@<~S is in ~A fasl file format version ~D, ~
+ but this version of SBCL uses ~
+ format version ~D.~:@>"
stream
variant
version
;;; We save space in macro definitions by calling this function.
(defun do-arg-count-error (error-kind name arg lambda-list minimum maximum)
- (multiple-value-bind (fname sb!debug:*stack-top-hint*) (find-caller-name)
+ (multiple-value-bind (fname sb!debug:*stack-top-hint*)
+ (find-caller-name-and-frame)
(error 'defmacro-ll-arg-count-error
:kind error-kind
- :function-name fname
:name name
:argument arg
:lambda-list lambda-list
:initform nil)))
(defun print-defmacro-ll-bind-error-intro (condition stream)
- (if (null (defmacro-lambda-list-bind-error-name condition))
- (format stream
- "error while parsing arguments to ~A in ~S:~%"
- (defmacro-lambda-list-bind-error-kind condition)
- (condition-function-name condition))
- (format stream
- "error while parsing arguments to ~A ~S:~%"
- (defmacro-lambda-list-bind-error-kind condition)
- (defmacro-lambda-list-bind-error-name condition))))
+ (format stream
+ "error while parsing arguments to ~A~@[ ~S~]:~%"
+ (defmacro-lambda-list-bind-error-kind condition)
+ (defmacro-lambda-list-bind-error-name condition)))
(define-condition defmacro-bogus-sublist-error
(defmacro-lambda-list-bind-error)
(write-char #\> stream))))
nil)
\f
-;;;; WHITESPACE-CHAR-P
-
-;;; This is used in other files, but is defined in this one for some reason.
-(defun whitespace-char-p (char)
- #!+sb-doc
- "Determines whether or not the character is considered whitespace."
- (or (char= char #\space)
- (char= char (code-char tab-char-code))
- (char= char (code-char return-char-code))
- (char= char #\linefeed)))
-\f
;;;; circularity detection stuff
;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that
;; Else, fail.
(t nil))))
+(defun whitespace-char-p (x)
+ (and (characterp x)
+ (or (char= x #\space)
+ (char= x (code-char tab-char-code))
+ (char= x (code-char return-char-code))
+ (char= x #\linefeed))))
+
(defun alphanumericp (char)
#!+sb-doc
"Given a character-object argument, alphanumericp returns T if the
(unless (sb!impl::whitespacep char)
(return (unread-char char stream))))))
+;;; like LISTEN, but any whitespace in the input stream will be flushed
(defun listen-skip-whitespace (&optional (stream *standard-input*))
- #!+sb-doc
- "See LISTEN. Any whitespace in the input stream will be flushed."
(do ((char (read-char-no-hang stream nil nil nil)
(read-char-no-hang stream nil nil nil)))
((null char) nil)
- (cond ((not (sb!impl::whitespace-char-p char))
+ (cond ((not (whitespace-char-p char))
(unread-char char stream)
(return t)))))
(setf *backend-fasl-file-type* "x86f")
(setf *backend-fasl-file-implementation* :x86)
-(setf *backend-fasl-file-version* 9)
+(setf *backend-fasl-file-version* 10)
;;; 2 = sbcl-0.6.4 uses COMPILE-OR-LOAD-DEFGENERIC.
;;; 3 = sbcl-0.6.6 uses private symbol, not :EMPTY, for empty HASH-TABLE slot.
;;; 4 = sbcl-0.6.7 uses HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
;;; 7 = around sbcl-0.6.9.8, merged SB-CONDITIONS package into SB-KERNEL
;;; 8 = sbcl-0.6.10.4 revived Gray stream support, changing stream layouts.
;;; 9 = deleted obsolete CONS-UNIQUE-TAG bytecode in sbcl-0.6.11.8
+;;; (somewhere in here also changes to AND and OR CTYPE layouts)
+;;; 10 = new layout for CONDITION in sbcl-0.6.11.38
(setf *backend-register-save-penalty* 3)
(setf *backend-byte-order* :little-endian)
+;;; KLUDGE: It would seem natural to set this by asking our C runtime
+;;; code for it, but mostly we need it for GENESIS, which doesn't in
+;;; general have our C runtime code running to ask, so instead we set
+;;; it by hand. -- WHN 2001-04-15
(setf *backend-page-size* 4096)
;;; comment from CMU CL:
;;;
(lambda (condition stream)
;; Don't try to print the structure, since it probably won't work.
(format stream
- "obsolete structure error in ~S:~@
- for a structure of type: ~S"
- (sb-kernel::condition-function-name condition)
+ "~@<obsolete structure error for a structure of type ~2I~_~S~:>"
(type-of (obsolete-structure-datum condition))))))
(defun obsolete-instance-trap (owrapper nwrapper instance)
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.11.37"
+"0.6.11.38"
projects / sbcl.git / commitdiff