(sb!xc:defmacro deferr (name args &rest body)
(let* ((rest-pos (position '&rest args))
(required (if rest-pos (subseq args 0 rest-pos) args))
- (fp (gensym))
- (context (gensym))
- (sc-offsets (gensym))
(fn-name (symbolicate name "-HANDLER")))
- `(progn
- ;; FIXME: Having a separate full DEFUN for each error doesn't
- ;; seem to add much value, and it takes a lot of space. Perhaps
- ;; we could do this dispatch with a big CASE statement instead?
- (defun ,fn-name (name ,fp ,context ,sc-offsets)
- ;; FIXME: It would probably be good to do *STACK-TOP-HINT*
- ;; tricks to hide this internal error-handling logic from the
- ;; poor high level user, so his debugger tells him about
- ;; where his error was detected instead of telling him where
- ;; he ended up inside the system error-handling logic.
- (declare (ignorable name ,fp ,context ,sc-offsets))
- (let (,@(let ((offset -1))
- (mapcar (lambda (var)
- `(,var (sb!di::sub-access-debug-var-slot
- ,fp
- (nth ,(incf offset)
- ,sc-offsets)
- ,context)))
- required))
- ,@(when rest-pos
- `((,(nth (1+ rest-pos) args)
- (mapcar (lambda (sc-offset)
- (sb!di::sub-access-debug-var-slot
- ,fp
- sc-offset
- ,context))
- (nthcdr ,rest-pos ,sc-offsets))))))
- ,@body))
- (setf (svref *internal-errors* ,(error-number-or-lose name))
- #',fn-name))))
+ (with-unique-names (fp context sc-offsets)
+ `(progn
+ ;; FIXME: Having a separate full DEFUN for each error doesn't
+ ;; seem to add much value, and it takes a lot of space. Perhaps
+ ;; we could do this dispatch with a big CASE statement instead?
+ (defun ,fn-name (name ,fp ,context ,sc-offsets)
+ ;; FIXME: It would probably be good to do *STACK-TOP-HINT*
+ ;; tricks to hide this internal error-handling logic from the
+ ;; poor high level user, so his debugger tells him about
+ ;; where his error was detected instead of telling him where
+ ;; he ended up inside the system error-handling logic.
+ (declare (ignorable name ,fp ,context ,sc-offsets))
+ (let (,@(let ((offset -1))
+ (mapcar (lambda (var)
+ `(,var (sb!di::sub-access-debug-var-slot
+ ,fp
+ (nth ,(incf offset)
+ ,sc-offsets)
+ ,context)))
+ required))
+ ,@(when rest-pos
+ `((,(nth (1+ rest-pos) args)
+ (mapcar (lambda (sc-offset)
+ (sb!di::sub-access-debug-var-slot
+ ,fp
+ sc-offset
+ ,context))
+ (nthcdr ,rest-pos ,sc-offsets))))))
+ ,@body))
+ (setf (svref *internal-errors* ,(error-number-or-lose name))
+ #',fn-name)))))
) ; EVAL-WHEN
(symbol fdefn-or-symbol)
(fdefn (fdefn-name fdefn-or-symbol)))))
+#!+x86-64
+(deferr undefined-alien-fun-error (address)
+ (error 'undefined-alien-function-error
+ :name
+ (and (integerp address)
+ (sap-foreign-symbol (int-sap address)))))
+
+#!-x86-64
+(defun undefined-alien-fun-error ()
+ (error 'undefined-alien-function-error))
+
(deferr invalid-arg-count-error (nargs)
(error 'simple-program-error
:format-control "invalid number of arguments: ~S"
:operands (list this that)))
(deferr object-not-type-error (object type)
- (error (if (and (%instancep object)
- (layout-invalid (%instance-layout object)))
- 'layout-invalid
- 'type-error)
- :datum object
- :expected-type type))
+ (if (invalid-array-p object)
+ (invalid-array-error object)
+ (error (if (and (%instancep object)
+ (layout-invalid (%instance-layout object)))
+ 'layout-invalid
+ 'type-error)
+ :datum object
+ :expected-type type)))
(deferr layout-invalid-error (object layout)
(error 'layout-invalid
:datum object
:expected-type '(complex long-float)))
+#!+sb-simd-pack
+(deferr object-not-simd-pack-error (object)
+ (error 'type-error
+ :datum object
+ :expected-type 'simd-pack))
+
(deferr object-not-weak-pointer-error (object)
(error 'type-error
:datum object
(/show0 "trapped DEBUG-CONDITION")
(values "<error finding interrupted name -- trapped debug-condition>"
nil)))))
+
+(defun find-caller-of-named-frame (name)
+ (unless *finding-name*
+ (handler-case
+ (let ((*finding-name* t))
+ (do ((frame (sb!di:top-frame) (sb!di:frame-down frame)))
+ ((null frame))
+ (when (and (sb!di::compiled-frame-p frame)
+ (eq name (sb!di:debug-fun-name
+ (sb!di:frame-debug-fun frame))))
+ (let ((caller (sb!di:frame-down frame)))
+ (sb!di:flush-frames-above caller)
+ (return caller)))))
+ ((or error sb!di:debug-condition) ()
+ nil)
+ (sb!di:debug-condition ()
+ nil))))
\f
;;;; INTERNAL-ERROR signal handler
(/hexstr context)
(infinite-error-protect
(/show0 "about to bind ALIEN-CONTEXT")
- (let ((alien-context (locally
- (declare (optimize (inhibit-warnings 3)))
- (sb!alien:sap-alien context (* os-context-t)))))
+ (let* ((alien-context (locally
+ (declare (optimize (inhibit-warnings 3)))
+ (sb!alien:sap-alien context (* os-context-t))))
+ #!+c-stack-is-control-stack
+ (*saved-fp-and-pcs*
+ (cons (cons (%make-lisp-obj (sb!vm:context-register
+ alien-context
+ sb!vm::cfp-offset))
+ (sb!vm:context-pc alien-context))
+ (when (boundp '*saved-fp-and-pcs*)
+ *saved-fp-and-pcs*))))
+ (declare (truly-dynamic-extent *saved-fp-and-pcs*))
(/show0 "about to bind ERROR-NUMBER and ARGUMENTS")
(multiple-value-bind (error-number arguments)
(sb!vm:internal-error-args alien-context)
(defun undefined-alien-variable-error ()
(error 'undefined-alien-variable-error))
-(defun undefined-alien-function-error ()
- (error 'undefined-alien-function-error))
-
#!-win32
-(define-alien-variable current-memory-fault-address unsigned-long)
+(define-alien-variable current-memory-fault-address unsigned)
#!-win32
(defun memory-fault-error ()
projects / sbcl.git / blobdiff