0.8.0.78.vector-nil-string.1:

[sbcl.git] / src / code / interr.lisp

diff --git a/src/code/interr.lisp b/src/code/interr.lisp
index 143784d..0f878d9 100644 (file)
--- a/src/code/interr.lisp
+++ b/src/code/interr.lisp
@@ -103,6 +103,11 @@
         :datum object
         :expected-type 'simple-string))
 
+(deferr object-not-simple-base-string-error (object)
+  (error 'type-error
+        :datum object
+        :expected-type 'simple-base-string))
+
 (deferr object-not-simple-bit-vector-error (object)
   (error 'type-error
         :datum object
@@ -128,6 +133,11 @@
         :datum object
         :expected-type 'string))
 
+(deferr object-not-base-string-error (object)
+  (error 'type-error
+        :datum object
+        :expected-type 'base-string))
+
 (deferr object-not-bit-vector-error (object)
   (error 'type-error
         :datum object
@@ -173,23 +183,18 @@
         :datum object
         :expected-type 'symbol))
 
-(deferr undefined-symbol-error (fdefn-or-symbol)
+(deferr undefined-fun-error (fdefn-or-symbol)
   (error 'undefined-function
         :name (etypecase fdefn-or-symbol
                 (symbol fdefn-or-symbol)
                 (fdefn (fdefn-name fdefn-or-symbol)))))
 
-(deferr object-not-coerceable-to-fun-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type 'coerceable-to-fun))
-
-(deferr invalid-argument-count-error (nargs)
+(deferr invalid-arg-count-error (nargs)
   (error 'simple-program-error
         :format-control "invalid number of arguments: ~S"
         :format-arguments (list nargs)))
 
-(deferr bogus-argument-to-values-list-error (list)
+(deferr bogus-arg-to-values-list-error (list)
   (error 'simple-type-error
         :datum list
         :expected-type 'list
@@ -227,6 +232,10 @@
         "A function with declared result type NIL returned:~%  ~S"
         :format-arguments (list function)))
 
+(deferr nil-array-accessed-error (array)
+  (error 'nil-array-accessed-error
+        :datum array :expected-type '(not (array nil))))
+
 (deferr division-by-zero-error (this that)
   (error 'division-by-zero
         :operation 'division
@@ -243,22 +252,24 @@
 (deferr layout-invalid-error (object layout)
   (error 'layout-invalid
         :datum object
-        :expected-type (layout-class layout)))
+        :expected-type (layout-classoid layout)))
 
-(deferr odd-key-arguments-error ()
+(deferr odd-key-args-error ()
   (error 'simple-program-error
         :format-control "odd number of &KEY arguments"))
 
-(deferr unknown-key-argument-error (key-name)
+(deferr unknown-key-arg-error (key-name)
   (error 'simple-program-error
         :format-control "unknown &KEY argument: ~S"
         :format-arguments (list key-name)))
 
 (deferr invalid-array-index-error (array bound index)
-  (error 'simple-error
+  (error 'simple-type-error
         :format-control
         "invalid array index ~W for ~S (should be nonnegative and <~W)"
-        :format-arguments (list index array bound)))
+        :format-arguments (list index array bound)
+        :datum index
+        :expected-type `(integer 0 (,bound))))
 
 (deferr object-not-simple-array-error (object)
   (error 'type-error
@@ -275,6 +286,11 @@
         :datum object
         :expected-type '(unsigned-byte 32)))
 
+(deferr object-not-simple-array-nil-error (object)
+  (error 'type-error
+        :datum object
+        :expected-type '(simple-array nil (*))))
+
 (deferr object-not-simple-array-unsigned-byte-2-error (object)
   (error 'type-error
         :datum object
@@ -438,7 +454,7 @@
 \f
 ;;;; INTERNAL-ERROR signal handler
 
-(defvar *internal-error-arguments*)
+(defvar *internal-error-args*)
 
 (defun internal-error (context continuable)
   (declare (type system-area-pointer context))
@@ -452,11 +468,18 @@
                          (sb!alien:sap-alien context (* os-context-t)))))
      (/show0 "about to bind ERROR-NUMBER and ARGUMENTS")
      (multiple-value-bind (error-number arguments)
-        (sb!vm:internal-error-arguments alien-context)
-       (/show0 "back from INTERNAL-ERROR-ARGUMENTS, ERROR-NUMBER=..")
+        (sb!vm:internal-error-args alien-context)
+
+       ;; There's a limit to how much error reporting we can usefully
+       ;; do before initialization is complete, but try to be a little
+       ;; bit helpful before we die.
+       (/show0 "back from INTERNAL-ERROR-ARGS, ERROR-NUMBER=..")
        (/hexstr error-number)
        (/show0 "cold/low ARGUMENTS=..")
        (/hexstr arguments)
+       (unless *cold-init-complete-p*
+        (%primitive print "can't recover from error in cold init, halting")
+        (%primitive sb!c:halt))
 
        (multiple-value-bind (name sb!debug:*stack-top-hint*)
           (find-interrupted-name)
@@ -487,3 +510,13 @@
                                       arguments))))
                 (t
                  (funcall handler name fp alien-context arguments)))))))))
+
+(defun control-stack-exhausted-error ()
+  (let ((sb!debug:*stack-top-hint* nil))
+    (infinite-error-protect
+     (format *error-output*
+            "Control stack guard page temporarily disabled: proceed with caution~%")
+     (error 'control-stack-exhausted))))
+
+
+