home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / interr.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  13.9 KB  |  529 lines
  1. ;;; -*- Log: code.log; Package: KERNEL -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: interr.lisp,v 1.24 92/03/28 21:07:08 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Functions and macros to define and deal with internal errors (i.e.
  15. ;;; problems that can be signaled from assembler code).
  16. ;;;
  17. ;;; Written by William Lott.
  18. ;;;
  19.  
  20. (in-package "KERNEL")
  21.  
  22. (export '(infinite-error-protect find-caller-name *maximum-error-depth*))
  23.  
  24.  
  25.  
  26. ;;;; Internal Errors
  27.  
  28. (defvar *internal-errors*
  29.   (macrolet ((frob ()
  30.            (map 'vector #'cdr (c:backend-internal-errors c:*backend*))))
  31.     (frob)))
  32.  
  33.  
  34. (eval-when (compile eval)
  35.  
  36. (defmacro deferr (name args &rest body)
  37.   (let* ((rest-pos (position '&rest args))
  38.      (required (if rest-pos (subseq args 0 rest-pos) args))
  39.      (fp (gensym))
  40.      (sigcontext (gensym))
  41.      (sc-offsets (gensym))
  42.      (temp (gensym))
  43.      (fn-name (symbolicate name "-HANDLER")))
  44.     `(progn
  45.        (defun ,fn-name (name ,fp ,sigcontext ,sc-offsets)
  46.      (declare (ignorable name ,fp ,sigcontext ,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."
  51.                  var))
  52.             `(let ((,',temp ,value))
  53.                (di::sub-set-debug-var-slot
  54.                 ,',fp (nth ,pos ,',sc-offsets)
  55.                 ,',temp ,',sigcontext)
  56.                (setf ,var ,',temp)))))
  57.        (let (,@(let ((offset -1))
  58.              (mapcar #'(lambda (var)
  59.                  `(,var (di::sub-access-debug-var-slot
  60.                      ,fp
  61.                      (nth ,(incf offset)
  62.                           ,sc-offsets)
  63.                      ,sigcontext)))
  64.                  required))
  65.            ,@(when rest-pos
  66.                `((,(nth (1+ rest-pos) args)
  67.               (mapcar #'(lambda (sc-offset)
  68.                       (di::sub-access-debug-var-slot
  69.                        ,fp
  70.                        sc-offset
  71.                        ,sigcontext))
  72.                   (nthcdr ,rest-pos ,sc-offsets))))))
  73.          ,@body)))
  74.        (setf (svref *internal-errors* ,(error-number-or-lose name))
  75.          #',fn-name))))
  76.  
  77. ) ; Eval-When (Compile Eval)
  78.  
  79.  
  80.  
  81. (deferr unknown-error (&rest args)
  82.   (error "Unknown error:~{ ~S~})" args))
  83.  
  84. (deferr object-not-function-error (object)
  85.   (error 'type-error
  86.      :function-name name
  87.      :datum object
  88.      :expected-type 'function))
  89.  
  90. (deferr object-not-list-error (object)
  91.   (error 'type-error
  92.      :function-name name
  93.      :datum object
  94.      :expected-type 'list))
  95.  
  96. (deferr object-not-bignum-error (object)
  97.   (error 'type-error
  98.      :function-name name
  99.      :datum object
  100.      :expected-type 'bignum))
  101.  
  102. (deferr object-not-ratio-error (object)
  103.   (error 'type-error
  104.      :function-name name
  105.      :datum object
  106.      :expected-type 'ratio))
  107.  
  108. (deferr object-not-single-float-error (object)
  109.   (error 'type-error
  110.      :function-name name
  111.      :datum object
  112.      :expected-type 'single-float))
  113.  
  114. (deferr object-not-double-float-error (object)
  115.   (error 'type-error
  116.      :function-name name
  117.      :datum object
  118.      :expected-type 'double-float))
  119.  
  120. (deferr object-not-simple-string-error (object)
  121.   (error 'type-error
  122.      :function-name name
  123.      :datum object
  124.      :expected-type 'simple-string))
  125.  
  126. (deferr object-not-simple-bit-vector-error (object)
  127.   (error 'type-error
  128.      :function-name name
  129.      :datum object
  130.      :expected-type 'simple-bit-vector))
  131.  
  132. (deferr object-not-simple-vector-error (object)
  133.   (error 'type-error
  134.      :function-name name
  135.      :datum object
  136.      :expected-type 'simple-vector))
  137.  
  138. (deferr object-not-fixnum-error (object)
  139.   (error 'type-error
  140.      :function-name name
  141.      :datum object
  142.      :expected-type 'fixnum))
  143.  
  144. (deferr object-not-function-or-symbol-error (object)
  145.   (error 'type-error
  146.      :function-name name
  147.      :datum object
  148.      :expected-type '(or function symbol)))
  149.  
  150. (deferr object-not-vector-error (object)
  151.   (error 'type-error
  152.      :function-name name
  153.      :datum object
  154.      :expected-type 'vector))
  155.  
  156. (deferr object-not-string-error (object)
  157.   (error 'type-error
  158.      :function-name name
  159.      :datum object
  160.      :expected-type 'string))
  161.  
  162. (deferr object-not-bit-vector-error (object)
  163.   (error 'type-error
  164.      :function-name name
  165.      :datum object
  166.      :expected-type 'bit-vector))
  167.  
  168. (deferr object-not-array-error (object)
  169.   (error 'type-error
  170.      :function-name name
  171.      :datum object
  172.      :expected-type 'array))
  173.  
  174. (deferr object-not-number-error (object)
  175.   (error 'type-error
  176.      :function-name name
  177.      :datum object
  178.      :expected-type 'number))
  179.  
  180. (deferr object-not-rational-error (object)
  181.   (error 'type-error
  182.      :function-name name
  183.      :datum object
  184.      :expected-type 'rational))
  185.  
  186. (deferr object-not-float-error (object)
  187.   (error 'type-error
  188.      :function-name name
  189.      :datum object
  190.      :expected-type 'float))
  191.  
  192. (deferr object-not-real-error (object)
  193.   (error 'type-error
  194.      :function-name name
  195.      :datum object
  196.      :expected-type 'real))
  197.  
  198. (deferr object-not-integer-error (object)
  199.   (error 'type-error
  200.      :function-name name
  201.      :datum object
  202.      :expected-type 'integer))
  203.  
  204. (deferr object-not-cons-error (object)
  205.   (error 'type-error
  206.      :function-name name
  207.      :datum object
  208.      :expected-type 'cons))
  209.  
  210. (deferr object-not-symbol-error (object)
  211.   (error 'type-error
  212.      :function-name name
  213.      :datum object
  214.      :expected-type 'symbol))
  215.  
  216. (deferr undefined-symbol-error (symbol)
  217.   (error 'undefined-function
  218.      :function-name name
  219.      :name symbol))
  220.  
  221. (deferr object-not-coercable-to-function-error (object)
  222.   (error 'type-error
  223.      :function-name name
  224.      :datum object
  225.      :expected-type 'coercable-to-function))
  226.  
  227. (deferr invalid-argument-count-error (nargs)
  228.   (error 'simple-error
  229.      :function-name name
  230.      :format-string "Invalid number of arguments: ~S"
  231.      :format-arguments (list nargs)))
  232.  
  233. (deferr bogus-argument-to-values-list-error (list)
  234.   (error 'simple-error
  235.      :function-name name
  236.      :format-string "Attempt to use VALUES-LIST on a dotted-list:~%  ~S"
  237.      :format-arguments (list list)))
  238.  
  239. (deferr unbound-symbol-error (symbol)
  240.   (error 'unbound-variable :function-name name :name symbol))
  241.  
  242. (deferr object-not-base-char-error (object)
  243.   (error 'type-error
  244.      :function-name name
  245.      :datum object
  246.      :expected-type 'base-char))
  247.  
  248. (deferr object-not-sap-error (object)
  249.   (error 'type-error
  250.      :function-name name
  251.      :datum object
  252.      :expected-type 'system-area-pointer))
  253.  
  254. (deferr invalid-unwind-error ()
  255.   (error 'control-error
  256.      :function-name name
  257.      :format-string
  258.      "Attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
  259.  
  260. (deferr unseen-throw-tag-error (tag)
  261.   (error 'control-error
  262.      :function-name name
  263.      :format-string "Attempt to THROW to a tag that does not exist: ~S"
  264.      :format-arguments (list tag)))
  265.  
  266. (deferr nil-function-returned-error (function)
  267.   (error 'control-error
  268.      :function-name name
  269.      :format-string
  270.      "Function with declared result type NIL returned:~%  ~S"
  271.      :format-arguments (list function)))
  272.  
  273. (deferr division-by-zero-error (this that)
  274.   (error 'division-by-zero
  275.      :function-name name
  276.      :operation 'division
  277.      :operands (list this that)))
  278.  
  279. (deferr object-not-type-error (object type)
  280.   (error 'type-error
  281.      :function-name name
  282.      :datum object
  283.      :expected-type type))
  284.  
  285. (deferr odd-keyword-arguments-error ()
  286.   (error 'simple-error
  287.      :function-name name
  288.      :format-string "Odd number of keyword arguments."))
  289.  
  290. (deferr unknown-keyword-argument-error (key)
  291.   (error 'simple-error
  292.      :function-name name
  293.      :format-string "Unknown keyword: ~S"
  294.      :format-arguments (list key)))
  295.  
  296. (deferr invalid-array-index-error (array bound index)
  297.   (error 'simple-error
  298.      :function-name name
  299.      :format-string
  300.      "Invalid array index, ~D for ~S.  Should have been less than ~D"
  301.      :format-arguments (list index array bound)))
  302.  
  303. (deferr object-not-simple-array-error (object)
  304.   (error 'type-error
  305.      :function-name name
  306.      :datum object
  307.      :expected-type 'simple-array))
  308.  
  309. (deferr object-not-signed-byte-32-error (object)
  310.   (error 'type-error
  311.      :function-name name
  312.      :datum object
  313.      :expected-type '(signed-byte 32)))
  314.  
  315. (deferr object-not-unsigned-byte-32-error (object)
  316.   (error 'type-error
  317.      :function-name name
  318.      :datum object
  319.      :expected-type '(unsigned-byte 32)))
  320.  
  321. (deferr object-not-simple-array-unsigned-byte-2-error (object)
  322.   (error 'type-error
  323.      :function-name name
  324.      :datum object
  325.      :expected-type '(simple-array (unsigned-byte 2) (*))))
  326.  
  327. (deferr object-not-simple-array-unsigned-byte-4-error (object)
  328.   (error 'type-error
  329.      :function-name name
  330.      :datum object
  331.      :expected-type '(simple-array (unsigned-byte 4) (*))))
  332.  
  333. (deferr object-not-simple-array-unsigned-byte-8-error (object)
  334.   (error 'type-error
  335.      :function-name name
  336.      :datum object
  337.      :expected-type '(simple-array (unsigned-byte 8) (*))))
  338.  
  339. (deferr object-not-simple-array-unsigned-byte-16-error (object)
  340.   (error 'type-error
  341.      :function-name name
  342.      :datum object
  343.      :expected-type '(simple-array (unsigned-byte 16) (*))))
  344.  
  345. (deferr object-not-simple-array-unsigned-byte-32-error (object)
  346.   (error 'type-error
  347.      :function-name name
  348.      :datum object
  349.      :expected-type '(simple-array (unsigned-byte 32) (*))))
  350.  
  351. (deferr object-not-simple-array-single-float-error (object)
  352.   (error 'type-error
  353.      :function-name name
  354.      :datum object
  355.      :expected-type '(simple-array single-float (*))))
  356.  
  357. (deferr object-not-simple-array-double-float-error (object)
  358.   (error 'type-error
  359.      :function-name name
  360.      :datum object
  361.      :expected-type '(simple-array double-float (*))))
  362.  
  363. (deferr object-not-complex-error (object)
  364.   (error 'type-error
  365.      :function-name name
  366.      :datum object
  367.      :expected-type 'complex))
  368.  
  369. (deferr object-not-weak-pointer-error (object)
  370.   (error 'type-error
  371.      :function-name name
  372.      :datum object
  373.      :expected-type 'weak-pointer))
  374.  
  375. (deferr object-not-structure-error (object)
  376.   (error 'type-error
  377.      :function-name name
  378.      :datum object
  379.      :expected-type 'structure))
  380.  
  381.  
  382.  
  383. ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of
  384. ;;; hyperspace.
  385. ;;;
  386. (defmacro infinite-error-protect (&rest forms)
  387.   `(if (and (boundp '*error-system-initialized*)
  388.         (numberp *current-error-depth*))
  389.        (let ((*current-error-depth* (1+ *current-error-depth*)))
  390.      (if (> *current-error-depth* *maximum-error-depth*)
  391.          (error-error "Help! " *current-error-depth* " nested errors.  "
  392.               "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
  393.          (progn ,@forms)))
  394.        (%primitive halt)))
  395.  
  396. ;;; Track the depth of recursive errors.
  397. ;;;
  398. (defvar *maximum-error-depth* 10
  399.   "The maximum number of nested errors allowed.  Internal errors are
  400.    double-counted.")
  401. (defvar *current-error-depth* 0 "The current number of nested errors.")
  402.  
  403. ;;; These specials are used by ERROR-ERROR to track the success of recovery
  404. ;;; attempts.
  405. ;;;
  406. (defvar *error-error-depth* 0)
  407. (defvar *error-throw-up-count* 0)
  408.  
  409. ;;; This protects against errors that happen before we run this top-level form.
  410. ;;;
  411. (defvar *error-system-initialized* t)
  412.  
  413. ;;; ERROR-ERROR can be called when the error system is in trouble and needs
  414. ;;; to punt fast.  Prints a message without using format.  If we get into
  415. ;;; this recursively, then halt.
  416. ;;;
  417. (defun error-error (&rest messages)
  418.   (let ((*error-error-depth* (1+ *error-error-depth*)))
  419.     (when (> *error-throw-up-count* 50)
  420.       (%primitive halt)
  421.       (throw 'lisp::top-level-catcher nil))
  422.     (case *error-error-depth*
  423.       (1)
  424.       (2
  425.        (lisp::stream-init))
  426.       (3
  427.        (incf *error-throw-up-count*)
  428.        (throw 'lisp::top-level-catcher nil))
  429.       (t
  430.        (%primitive halt)
  431.        (throw 'lisp::top-level-catcher nil)))
  432.  
  433.     (with-standard-io-syntax
  434.       (let ((*print-readably* nil))
  435.     (dolist (item messages) (princ item *terminal-io*))
  436.     (debug:internal-debug)))))
  437.  
  438.  
  439. ;;;; Fetching errorful function name.
  440.  
  441. ;;; Used to prevent infinite recursive lossage when we can't find the caller
  442. ;;; for some reason.
  443. ;;;
  444. (defvar *finding-name* nil)
  445.  
  446. ;;; FIND-CALLER-NAME  --  Internal
  447. ;;;
  448. (defun find-caller-name ()
  449.   (if *finding-name*
  450.       (values "<error finding name>" nil)
  451.       (handler-case
  452.       (let* ((*finding-name* t)
  453.          (frame (di:frame-down (di:frame-down (di:top-frame))))
  454.          (name (di:debug-function-name
  455.             (di:frame-debug-function frame))))
  456.         (di:flush-frames-above frame)
  457.         (values name frame))
  458.     (error ()
  459.       (values "<error finding name>" nil))
  460.     (di:debug-condition ()
  461.       (values "<error finding name>" nil)))))
  462.  
  463.  
  464. (defun find-interrupted-name ()
  465.   (if *finding-name*
  466.       (values "<error finding name>" nil)
  467.       (handler-case
  468.       (let ((*finding-name* t))
  469.         (do ((frame (di:top-frame) (di:frame-down frame)))
  470.         ((or (null frame)
  471.              (and (di::compiled-frame-p frame)
  472.               (di::compiled-frame-escaped frame)))
  473.          (if (di::compiled-frame-p frame)
  474.              (values (di:debug-function-name
  475.                   (di:frame-debug-function frame))
  476.                  (progn
  477.                    (di:flush-frames-above frame)
  478.                    frame))
  479.              (values "<error finding name>" nil)))))
  480.     (error ()
  481.       (values "<error finding name>" nil))
  482.     (di:debug-condition ()
  483.       (values "<error finding name>" nil)))))
  484.  
  485.  
  486. ;;;; internal-error signal handler.
  487.  
  488. (defun internal-error (scp continuable)
  489.   (declare (type system-area-pointer scp) (ignore continuable))
  490.   (infinite-error-protect
  491.    (let ((scp (locally
  492.         (declare (optimize (inhibit-warnings 3)))
  493.         (alien:sap-alien scp (* unix:sigcontext)))))
  494.      (multiple-value-bind
  495.      (error-number arguments)
  496.      (vm:internal-error-arguments scp)
  497.        (multiple-value-bind
  498.        (name debug:*stack-top-hint*)
  499.        (find-interrupted-name)
  500.      (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
  501.            (handler (and (< -1 error-number (length *internal-errors*))
  502.                  (svref *internal-errors* error-number))))
  503.        (cond ((null handler)
  504.           (error 'simple-error
  505.              :function-name name
  506.              :format-string
  507.              "Unknown internal error, ~D?  args=~S"
  508.              :format-arguments
  509.              (list error-number
  510.                    (mapcar #'(lambda (sc-offset)
  511.                        (di::sub-access-debug-var-slot
  512.                         fp sc-offset scp))
  513.                        arguments))))
  514.          ((not (functionp handler))
  515.           (error 'simple-error
  516.              :function-name name
  517.              :format-string
  518.              "Internal error ~D: ~A.  args=~S"
  519.              :format-arguments
  520.              (list error-number
  521.                    handler
  522.                    (mapcar #'(lambda (sc-offset)
  523.                        (di::sub-access-debug-var-slot
  524.                         fp sc-offset scp))
  525.                        arguments))))
  526.          (t
  527.           (funcall handler name fp scp arguments)))))))))
  528.  
  529.