X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Finterr.lisp;h=fb16a7727e8aa51a5a7d71a9a293cb303cf26aec;hb=cd1b14acf6f548b28b8a14e554d779f0473122ec;hp=c3f039f838cb0c53ac0709ff56d89db7c69ad025;hpb=08d05510b51708853ca998154d8096b21d85edab;p=sbcl.git

diff --git a/src/code/interr.lisp b/src/code/interr.lisp
index c3f039f..fb16a77 100644
--- a/src/code/interr.lisp
+++ b/src/code/interr.lisp
@@ -236,12 +236,14 @@
          :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
@@ -328,6 +330,12 @@
          :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
@@ -391,6 +399,23 @@
           (/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))))
 
 
 ;;;; INTERNAL-ERROR signal handler
@@ -402,9 +427,18 @@
   (/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)
@@ -494,7 +528,7 @@
   (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 ()