src/code/interr.lisp

   1 ;;;; functions and macros to define and deal with internal errors
   2 ;;;; (i.e. problems that can be signaled from assembler code)
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!KERNEL")
  14
  15 (file-comment
  16   "$Header$")
  17 \f
  18 ;;;; internal errors
  19
  20 (defvar *internal-errors*
  21   #.(map 'vector #'cdr sb!c:*backend-internal-errors*))
  22
  23 (eval-when (:compile-toplevel :execute)
  24
  25 (sb!xc:defmacro deferr (name args &rest body)
  26   (let* ((rest-pos (position '&rest args))
  27          (required (if rest-pos (subseq args 0 rest-pos) args))
  28          (fp (gensym))
  29          (context (gensym))
  30          (sc-offsets (gensym))
  31          (temp (gensym))
  32          (fn-name (symbolicate name "-HANDLER")))
  33     `(progn
  34        ;; FIXME: Having a separate full DEFUN for each error doesn't
  35        ;; seem to add much value, and it takes a lot of space. Perhaps
  36        ;; we could make this a big CASE statement instead?
  37        (defun ,fn-name (name ,fp ,context ,sc-offsets)
  38          ;; FIXME: Perhaps put in OPTIMIZE declaration to make this
  39          ;; byte coded.
  40          ;;
  41          ;; FIXME: It would probably be good to do *STACK-TOP-HINT*
  42          ;; tricks to hide this internal error-handling logic from the
  43          ;; poor high level user, so his debugger tells him about
  44          ;; where his error was detected instead of telling him where
  45          ;; he ended up inside the system error-handling logic.
  46          (declare (ignorable name ,fp ,context ,sc-offsets))
  47          (macrolet ((set-value (var value)
  48                       (let ((pos (position var ',required)))
  49                         (unless pos
  50                           (error "~S isn't one of the required args." var))
  51                         `(let ((,',temp ,value))
  52                            (sb!di::sub-set-debug-var-slot
  53                             ,',fp (nth ,pos ,',sc-offsets)
  54                             ,',temp ,',context)
  55                            (setf ,var ,',temp)))))
  56            (let (,@(let ((offset -1))
  57                      (mapcar #'(lambda (var)
  58                                  `(,var (sb!di::sub-access-debug-var-slot
  59                                          ,fp
  60                                          (nth ,(incf offset)
  61                                               ,sc-offsets)
  62                                          ,context)))
  63                              required))
  64                    ,@(when rest-pos
  65                        `((,(nth (1+ rest-pos) args)
  66                           (mapcar #'(lambda (sc-offset)
  67                                       (sb!di::sub-access-debug-var-slot
  68                                        ,fp
  69                                        sc-offset
  70                                        ,context))
  71                                   (nthcdr ,rest-pos ,sc-offsets))))))
  72              ,@body)))
  73        (setf (svref *internal-errors* ,(error-number-or-lose name))
  74              #',fn-name))))
  75
  76 ) ; EVAL-WHEN
  77
  78 (deferr unknown-error (&rest args)
  79   (error "unknown error:~{ ~S~})" args))
  80
  81 (deferr object-not-function-error (object)
  82   (error 'type-error
  83          :function-name name
  84          :datum object
  85          :expected-type 'function))
  86
  87 (deferr object-not-list-error (object)
  88   (error 'type-error
  89          :function-name name
  90          :datum object
  91          :expected-type 'list))
  92
  93 (deferr object-not-bignum-error (object)
  94   (error 'type-error
  95          :function-name name
  96          :datum object
  97          :expected-type 'bignum))
  98
  99 (deferr object-not-ratio-error (object)
 100   (error 'type-error
 101          :function-name name
 102          :datum object
 103          :expected-type 'ratio))
 104
 105 (deferr object-not-single-float-error (object)
 106   (error 'type-error
 107          :function-name name
 108          :datum object
 109          :expected-type 'single-float))
 110
 111 (deferr object-not-double-float-error (object)
 112   (error 'type-error
 113          :function-name name
 114          :datum object
 115          :expected-type 'double-float))
 116
 117 #!+long-float
 118 (deferr object-not-long-float-error (object)
 119   (error 'type-error
 120          :function-name name
 121          :datum object
 122          :expected-type 'long-float))
 123
 124 (deferr object-not-simple-string-error (object)
 125   (error 'type-error
 126          :function-name name
 127          :datum object
 128          :expected-type 'simple-string))
 129
 130 (deferr object-not-simple-bit-vector-error (object)
 131   (error 'type-error
 132          :function-name name
 133          :datum object
 134          :expected-type 'simple-bit-vector))
 135
 136 (deferr object-not-simple-vector-error (object)
 137   (error 'type-error
 138          :function-name name
 139          :datum object
 140          :expected-type 'simple-vector))
 141
 142 (deferr object-not-fixnum-error (object)
 143   (error 'type-error
 144          :function-name name
 145          :datum object
 146          :expected-type 'fixnum))
 147
 148 (deferr object-not-function-or-symbol-error (object)
 149   (error 'type-error
 150          :function-name name
 151          :datum object
 152          :expected-type '(or function symbol)))
 153
 154 (deferr object-not-vector-error (object)
 155   (error 'type-error
 156          :function-name name
 157          :datum object
 158          :expected-type 'vector))
 159
 160 (deferr object-not-string-error (object)
 161   (error 'type-error
 162          :function-name name
 163          :datum object
 164          :expected-type 'string))
 165
 166 (deferr object-not-bit-vector-error (object)
 167   (error 'type-error
 168          :function-name name
 169          :datum object
 170          :expected-type 'bit-vector))
 171
 172 (deferr object-not-array-error (object)
 173   (error 'type-error
 174          :function-name name
 175          :datum object
 176          :expected-type 'array))
 177
 178 (deferr object-not-number-error (object)
 179   (error 'type-error
 180          :function-name name
 181          :datum object
 182          :expected-type 'number))
 183
 184 (deferr object-not-rational-error (object)
 185   (error 'type-error
 186          :function-name name
 187          :datum object
 188          :expected-type 'rational))
 189
 190 (deferr object-not-float-error (object)
 191   (error 'type-error
 192          :function-name name
 193          :datum object
 194          :expected-type 'float))
 195
 196 (deferr object-not-real-error (object)
 197   (error 'type-error
 198          :function-name name
 199          :datum object
 200          :expected-type 'real))
 201
 202 (deferr object-not-integer-error (object)
 203   (error 'type-error
 204          :function-name name
 205          :datum object
 206          :expected-type 'integer))
 207
 208 (deferr object-not-cons-error (object)
 209   (error 'type-error
 210          :function-name name
 211          :datum object
 212          :expected-type 'cons))
 213
 214 (deferr object-not-symbol-error (object)
 215   (error 'type-error
 216          :function-name name
 217          :datum object
 218          :expected-type 'symbol))
 219
 220 (deferr undefined-symbol-error (fdefn-or-symbol)
 221   (error 'undefined-function
 222          :function-name name
 223          :name (etypecase fdefn-or-symbol
 224                  (symbol fdefn-or-symbol)
 225                  (fdefn (fdefn-name fdefn-or-symbol)))))
 226
 227 (deferr object-not-coerceable-to-function-error (object)
 228   (error 'type-error
 229          :function-name name
 230          :datum object
 231          :expected-type 'coerceable-to-function))
 232
 233 (deferr invalid-argument-count-error (nargs)
 234   (error 'simple-program-error
 235          :function-name name
 236          :format-control "invalid number of arguments: ~S"
 237          :format-arguments (list nargs)))
 238
 239 (deferr bogus-argument-to-values-list-error (list)
 240   (error 'type-error
 241          :function-name name
 242          :format-control "attempt to use VALUES-LIST on a dotted-list:~%  ~S"
 243          :format-arguments (list list)))
 244
 245 (deferr unbound-symbol-error (symbol)
 246   (error 'unbound-variable :function-name name :name symbol))
 247
 248 (deferr object-not-base-char-error (object)
 249   (error 'type-error
 250          :function-name name
 251          :datum object
 252          :expected-type 'base-char))
 253
 254 (deferr object-not-sap-error (object)
 255   (error 'type-error
 256          :function-name name
 257          :datum object
 258          :expected-type 'system-area-pointer))
 259
 260 (deferr invalid-unwind-error ()
 261   (error 'simple-control-error
 262          :function-name name
 263          :format-control
 264          "attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
 265
 266 (deferr unseen-throw-tag-error (tag)
 267   (error 'simple-control-error
 268          :function-name name
 269          :format-control "attempt to THROW to a tag that does not exist: ~S"
 270          :format-arguments (list tag)))
 271
 272 (deferr nil-function-returned-error (function)
 273   (error 'simple-control-error
 274          :function-name name
 275          :format-control
 276          "A function with declared result type NIL returned:~%  ~S"
 277          :format-arguments (list function)))
 278
 279 (deferr division-by-zero-error (this that)
 280   (error 'division-by-zero
 281          :function-name name
 282          :operation 'division
 283          :operands (list this that)))
 284
 285 (deferr object-not-type-error (object type)
 286   (error (if (and (typep object 'instance)
 287                   (layout-invalid (%instance-layout object)))
 288              'layout-invalid
 289              'type-error)
 290          :function-name name
 291          :datum object
 292          :expected-type type))
 293
 294 (deferr layout-invalid-error (object layout)
 295   (error 'layout-invalid
 296          :function-name name
 297          :datum object
 298          :expected-type (layout-class layout)))
 299
 300 (deferr odd-keyword-arguments-error ()
 301   (error 'simple-program-error
 302          :function-name name
 303          :format-control "odd number of keyword arguments"))
 304
 305 (deferr unknown-keyword-argument-error (key)
 306   (error 'simple-program-error
 307          :function-name name
 308          :format-control "unknown keyword: ~S"
 309          :format-arguments (list key)))
 310
 311 (deferr invalid-array-index-error (array bound index)
 312   (error 'simple-error
 313          :function-name name
 314          :format-control
 315          "invalid array index, ~D for ~S (should have been less than ~D)"
 316          :format-arguments (list index array bound)))
 317
 318 (deferr object-not-simple-array-error (object)
 319   (error 'type-error
 320          :function-name name
 321          :datum object
 322          :expected-type 'simple-array))
 323
 324 (deferr object-not-signed-byte-32-error (object)
 325   (error 'type-error
 326          :function-name name
 327          :datum object
 328          :expected-type '(signed-byte 32)))
 329
 330 (deferr object-not-unsigned-byte-32-error (object)
 331   (error 'type-error
 332          :function-name name
 333          :datum object
 334          :expected-type '(unsigned-byte 32)))
 335
 336 (deferr object-not-simple-array-unsigned-byte-2-error (object)
 337   (error 'type-error
 338          :function-name name
 339          :datum object
 340          :expected-type '(simple-array (unsigned-byte 2) (*))))
 341
 342 (deferr object-not-simple-array-unsigned-byte-4-error (object)
 343   (error 'type-error
 344          :function-name name
 345          :datum object
 346          :expected-type '(simple-array (unsigned-byte 4) (*))))
 347
 348 (deferr object-not-simple-array-unsigned-byte-8-error (object)
 349   (error 'type-error
 350          :function-name name
 351          :datum object
 352          :expected-type '(simple-array (unsigned-byte 8) (*))))
 353
 354 (deferr object-not-simple-array-unsigned-byte-16-error (object)
 355   (error 'type-error
 356          :function-name name
 357          :datum object
 358          :expected-type '(simple-array (unsigned-byte 16) (*))))
 359
 360 (deferr object-not-simple-array-unsigned-byte-32-error (object)
 361   (error 'type-error
 362          :function-name name
 363          :datum object
 364          :expected-type '(simple-array (unsigned-byte 32) (*))))
 365
 366 (deferr object-not-simple-array-signed-byte-8-error (object)
 367   (error 'type-error
 368          :function-name name
 369          :datum object
 370          :expected-type '(simple-array (signed-byte 8) (*))))
 371
 372 (deferr object-not-simple-array-signed-byte-16-error (object)
 373   (error 'type-error
 374          :function-name name
 375          :datum object
 376          :expected-type '(simple-array (signed-byte 16) (*))))
 377
 378 (deferr object-not-simple-array-signed-byte-30-error (object)
 379   (error 'type-error
 380          :function-name name
 381          :datum object
 382          :expected-type '(simple-array (signed-byte 30) (*))))
 383
 384 (deferr object-not-simple-array-signed-byte-32-error (object)
 385   (error 'type-error
 386          :function-name name
 387          :datum object
 388          :expected-type '(simple-array (signed-byte 32) (*))))
 389
 390 (deferr object-not-simple-array-single-float-error (object)
 391   (error 'type-error
 392          :function-name name
 393          :datum object
 394          :expected-type '(simple-array single-float (*))))
 395
 396 (deferr object-not-simple-array-double-float-error (object)
 397   (error 'type-error
 398          :function-name name
 399          :datum object
 400          :expected-type '(simple-array double-float (*))))
 401
 402 (deferr object-not-simple-array-complex-single-float-error (object)
 403   (error 'type-error
 404          :function-name name
 405          :datum object
 406          :expected-type '(simple-array (complex single-float) (*))))
 407
 408 (deferr object-not-simple-array-complex-double-float-error (object)
 409   (error 'type-error
 410          :function-name name
 411          :datum object
 412          :expected-type '(simple-array (complex double-float) (*))))
 413
 414 #!+long-float
 415 (deferr object-not-simple-array-complex-long-float-error (object)
 416   (error 'type-error
 417          :function-name name
 418          :datum object
 419          :expected-type '(simple-array (complex long-float) (*))))
 420
 421 (deferr object-not-complex-error (object)
 422   (error 'type-error
 423          :function-name name
 424          :datum object
 425          :expected-type 'complex))
 426
 427 (deferr object-not-complex-rational-error (object)
 428   (error 'type-error
 429          :function-name name
 430          :datum object
 431          :expected-type '(complex rational)))
 432
 433 (deferr object-not-complex-single-float-error (object)
 434   (error 'type-error
 435          :function-name name
 436          :datum object
 437          :expected-type '(complex single-float)))
 438
 439 (deferr object-not-complex-double-float-error (object)
 440   (error 'type-error
 441          :function-name name
 442          :datum object
 443          :expected-type '(complex double-float)))
 444
 445 #!+long-float
 446 (deferr object-not-complex-long-float-error (object)
 447   (error 'type-error
 448          :function-name name
 449          :datum object
 450          :expected-type '(complex long-float)))
 451
 452 (deferr object-not-weak-pointer-error (object)
 453   (error 'type-error
 454          :function-name name
 455          :datum object
 456          :expected-type 'weak-pointer))
 457
 458 (deferr object-not-instance-error (object)
 459   (error 'type-error
 460          :function-name name
 461          :datum object
 462          :expected-type 'instance))
 463 \f
 464 ;;;; fetching errorful function name
 465
 466 ;;; This variable is used to prevent infinite recursive lossage when
 467 ;;; we can't find the caller for some reason.
 468 (defvar *finding-name* nil)
 469
 470 (defun find-caller-name ()
 471   (if *finding-name*
 472       (values "<error finding caller name -- already finding name>" nil)
 473       (handler-case
 474           (let* ((*finding-name* t)
 475                  (frame (sb!di:frame-down (sb!di:frame-down (sb!di:top-frame))))
 476                  (name (sb!di:debug-function-name
 477                         (sb!di:frame-debug-function frame))))
 478             (sb!di:flush-frames-above frame)
 479             (values name frame))
 480         (error ()
 481           (values "<error finding caller name -- trapped error>" nil))
 482         (sb!di:debug-condition ()
 483           (values "<error finding caller name -- trapped debug-condition>"
 484                   nil)))))
 485
 486 (defun find-interrupted-name ()
 487   (if *finding-name*
 488       (values "<error finding interrupted name -- already finding name>" nil)
 489       (handler-case
 490           (let ((*finding-name* t))
 491             (do ((frame (sb!di:top-frame) (sb!di:frame-down frame)))
 492                 ((null frame)
 493                  (values "<error finding interrupted name -- null frame>" nil))
 494               (when (and (sb!di::compiled-frame-p frame)
 495                          (sb!di::compiled-frame-escaped frame))
 496                 (sb!di:flush-frames-above frame)
 497                 (return (values (sb!di:debug-function-name
 498                                  (sb!di:frame-debug-function frame))
 499                                 frame)))))
 500         (error ()
 501           (values "<error finding interrupted name -- trapped error>" nil))
 502         (sb!di:debug-condition ()
 503           (values "<error finding interrupted name -- trapped debug-condition>"
 504                   nil)))))
 505 \f
 506 ;;;; INTERNAL-ERROR signal handler
 507
 508 (defun internal-error (context continuable)
 509   (declare (type system-area-pointer context) (ignore continuable))
 510   (infinite-error-protect
 511    (let ((context (locally
 512                    (declare (optimize (inhibit-warnings 3)))
 513                    (sb!alien:sap-alien context (* os-context-t)))))
 514      (multiple-value-bind (error-number arguments)
 515          (sb!vm:internal-error-arguments context)
 516        (multiple-value-bind (name sb!debug:*stack-top-hint*)
 517            (find-interrupted-name)
 518          (let ((fp (int-sap (sb!vm:context-register context
 519                                                     sb!vm::cfp-offset)))
 520                (handler (and (< -1 error-number (length *internal-errors*))
 521                              (svref *internal-errors* error-number))))
 522            (cond ((null handler)
 523                   (error 'simple-error
 524                          :function-name name
 525                          :format-control
 526                          "unknown internal error, ~D? args=~S"
 527                          :format-arguments
 528                          (list error-number
 529                                (mapcar #'(lambda (sc-offset)
 530                                            (sb!di::sub-access-debug-var-slot
 531                                             fp sc-offset context))
 532                                        arguments))))
 533                  ((not (functionp handler))
 534                   (error 'simple-error
 535                          :function-name name
 536                          :format-control
 537                          "internal error ~D: ~A; args=~S"
 538                          :format-arguments
 539                          (list error-number
 540                                handler
 541                                (mapcar #'(lambda (sc-offset)
 542                                            (sb!di::sub-access-debug-var-slot
 543                                             fp sc-offset context))
 544                                        arguments))))
 545                  (t
 546                   (funcall handler name fp context arguments)))))))))