/[cmucl]/src/code/interr.lisp
ViewVC logotype

Diff of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.28.1.1 by ram, Wed Oct 19 23:22:30 1994 UTC revision 1.51 by rtoy, Thu Sep 1 16:53:46 2011 UTC
# Line 3  Line 3 
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the CMU Common Lisp project at  ;;; 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.  ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact  
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.  
6  ;;;  ;;;
7  (ext:file-comment  (ext:file-comment
8    "$Header$")    "$Header$")
# Line 19  Line 17 
17    
18  (in-package "KERNEL")  (in-package "KERNEL")
19    
20  (export '(infinite-error-protect find-caller-name *maximum-error-depth*))  (intl:textdomain "cmucl")
21    
22    (export '(infinite-error-protect find-caller-name *maximum-error-depth*
23              #+stack-checking red-zone-hit #+stack-checking yellow-zone-hit
24              #+heap-overflow-check dynamic-space-overflow-error-hit
25              #+heap-overflow-check dynamic-space-overflow-warning-hit))
26    
27    
28    
# Line 36  Line 39 
39  (defmacro deferr (name args &rest body)  (defmacro deferr (name args &rest body)
40    (let* ((rest-pos (position '&rest args))    (let* ((rest-pos (position '&rest args))
41           (required (if rest-pos (subseq args 0 rest-pos) args))           (required (if rest-pos (subseq args 0 rest-pos) args))
42           (fp (gensym))           (fp (gensym "FP-"))
43           (s-context (gensym))           (sigcontext (gensym "SIGCONTEXT-"))
44           (sc-offsets (gensym))           (sc-offsets (gensym "SC-OFFSETS-"))
45           (temp (gensym))           (temp (gensym))
46           (fn-name (symbolicate name "-HANDLER")))           (fn-name (symbolicate name "-HANDLER")))
47      `(progn      `(progn
48         (defun ,fn-name (name ,fp ,s-context ,sc-offsets)         (defun ,fn-name (name ,fp ,sigcontext ,sc-offsets)
49           (declare (ignorable name ,fp ,s-context ,sc-offsets))           (declare (ignorable name ,fp ,sigcontext ,sc-offsets))
50           (macrolet ((set-value (var value)           (macrolet ((set-value (var value)
51                        (let ((pos (position var ',required)))                        (let ((pos (position var ',required)))
52                          (unless pos                          (unless pos
53                            (error "~S isn't one of the required args."                            (error (intl:gettext "~S isn't one of the required args.")
54                                   var))                                   var))
55                          `(let ((,',temp ,value))                          `(let ((,',temp ,value))
56                             (di::sub-set-debug-var-slot                             (di::sub-set-debug-var-slot
57                              ,',fp (nth ,pos ,',sc-offsets)                              ,',fp (nth ,pos ,',sc-offsets)
58                              ,',temp ,',s-context)                              ,',temp ,',sigcontext)
59                             (setf ,var ,',temp)))))                             (setf ,var ,',temp)))))
60             (let (,@(let ((offset -1))             (let (,@(let ((offset -1))
61                       (mapcar #'(lambda (var)                       (mapcar #'(lambda (var)
# Line 60  Line 63 
63                                           ,fp                                           ,fp
64                                           (nth ,(incf offset)                                           (nth ,(incf offset)
65                                                ,sc-offsets)                                                ,sc-offsets)
66                                           ,s-context)))                                           ,sigcontext)))
67                               required))                               required))
68                     ,@(when rest-pos                     ,@(when rest-pos
69                         `((,(nth (1+ rest-pos) args)                         `((,(nth (1+ rest-pos) args)
# Line 68  Line 71 
71                                        (di::sub-access-debug-var-slot                                        (di::sub-access-debug-var-slot
72                                         ,fp                                         ,fp
73                                         sc-offset                                         sc-offset
74                                         ,s-context))                                         ,sigcontext))
75                                    (nthcdr ,rest-pos ,sc-offsets))))))                                    (nthcdr ,rest-pos ,sc-offsets))))))
76               ,@body)))               ,@body)))
77         (setf (svref *internal-errors* ,(error-number-or-lose name))         (setf (svref *internal-errors* ,(error-number-or-lose name))
# Line 79  Line 82 
82    
83    
84  (deferr unknown-error (&rest args)  (deferr unknown-error (&rest args)
85    (error "Unknown error:~{ ~S~})" args))    (error (intl:gettext "Unknown error:~{ ~S~})") args))
86    
87  (deferr object-not-function-error (object)  (deferr object-not-function-error (object)
88    (error 'type-error    (error 'type-error
# Line 117  Line 120 
120           :datum object           :datum object
121           :expected-type 'double-float))           :expected-type 'double-float))
122    
123    #+long-float
124    (deferr object-not-long-float-error (object)
125      (error 'type-error
126             :function-name name
127             :datum object
128             :expected-type 'long-float))
129    
130    #+double-double
131    (deferr object-not-double-double-float-error (object)
132      (error 'type-error
133             :function-name name
134             :datum object
135             :expected-type 'double-double-float))
136    
137  (deferr object-not-simple-string-error (object)  (deferr object-not-simple-string-error (object)
138    (error 'type-error    (error 'type-error
139           :function-name name           :function-name name
# Line 227  Line 244 
244           :expected-type 'coercable-to-function))           :expected-type 'coercable-to-function))
245    
246  (deferr invalid-argument-count-error (nargs)  (deferr invalid-argument-count-error (nargs)
247    (error 'simple-error    (error 'simple-program-error
248           :function-name name           :function-name name
249           :format-control "Invalid number of arguments: ~S"           :format-control (intl:gettext "Invalid number of arguments: ~S")
250           :format-arguments (list nargs)))           :format-arguments (list nargs)))
251    
252  (deferr bogus-argument-to-values-list-error (list)  (deferr bogus-argument-to-values-list-error (list)
253    (error 'simple-error    (error 'simple-type-error
254           :function-name name           :function-name name
255           :format-control "Attempt to use VALUES-LIST on a dotted-list:~%  ~S"           :datum list
256             :expected-type 'list
257             :format-control (intl:gettext "Attempt to use VALUES-LIST on a dotted-list:~%  ~S")
258           :format-arguments (list list)))           :format-arguments (list list)))
259    
260  (deferr unbound-symbol-error (symbol)  (deferr unbound-symbol-error (symbol)
# Line 254  Line 273 
273           :expected-type 'system-area-pointer))           :expected-type 'system-area-pointer))
274    
275  (deferr invalid-unwind-error ()  (deferr invalid-unwind-error ()
276    (error 'control-error    (error 'simple-control-error
277           :function-name name           :function-name name
278           :format-control           :format-control
279           "Attempt to RETURN-FROM a block or GO to a tag that no longer exists"))           (intl:gettext "Attempt to RETURN-FROM a block or GO to a tag that no longer exists")))
280    
281  (deferr unseen-throw-tag-error (tag)  (deferr unseen-throw-tag-error (tag)
282    (error 'control-error    (error 'simple-control-error
283           :function-name name           :function-name name
284           :format-control "Attempt to THROW to a tag that does not exist: ~S"           :format-control (intl:gettext "Attempt to THROW to a tag that does not exist: ~S")
285           :format-arguments (list tag)))           :format-arguments (list tag)))
286    
287  (deferr nil-function-returned-error (function)  (deferr nil-function-returned-error (function)
288    (error 'control-error    (error 'simple-control-error
289           :function-name name           :function-name name
290           :format-control           :format-control
291           "Function with declared result type NIL returned:~%  ~S"           (intl:gettext "Function with declared result type NIL returned:~%  ~S")
292           :format-arguments (list function)))           :format-arguments (list function)))
293    
294  (deferr division-by-zero-error (this that)  (deferr division-by-zero-error (this that)
# Line 294  Line 313 
313           :expected-type (layout-class layout)))           :expected-type (layout-class layout)))
314    
315  (deferr odd-keyword-arguments-error ()  (deferr odd-keyword-arguments-error ()
316    (error 'simple-error    (error 'simple-program-error
317           :function-name name           :function-name name
318           :format-control "Odd number of keyword arguments."))           :format-control (intl:gettext "Odd number of keyword arguments.")))
319    
320  (deferr unknown-keyword-argument-error (key)  (deferr unknown-keyword-argument-error (key)
321    (error 'simple-error    (error 'simple-program-error
322           :function-name name           :function-name name
323           :format-control "Unknown keyword: ~S"           :format-control (intl:gettext "Unknown keyword: ~S")
324           :format-arguments (list key)))           :format-arguments (list key)))
325    
326  (deferr invalid-array-index-error (array bound index)  (deferr invalid-array-index-error (array bound index)
327    (error 'simple-error    (error 'type-error
328           :function-name name           :function-name name
329             :datum index
330             :expected-type `(integer 0 (,bound))
331           :format-control           :format-control
332           "Invalid array index, ~D for ~S.  Should have been less than ~D"           (cond ((zerop bound)
333                    (intl:gettext "Invalid array index, ~D for ~S.  Array has no elements."))
334                   ((minusp index)
335                    (intl:gettext "Invalid array index, ~D for ~S.  Should have greater than or equal to 0."))
336                   (t
337                    (intl:gettext "Invalid array index, ~D for ~S.  Should have been less than ~D")))
338           :format-arguments (list index array bound)))           :format-arguments (list index array bound)))
339    
340  (deferr object-not-simple-array-error (object)  (deferr object-not-simple-array-error (object)
# Line 359  Line 385 
385           :datum object           :datum object
386           :expected-type '(simple-array (unsigned-byte 32) (*))))           :expected-type '(simple-array (unsigned-byte 32) (*))))
387    
388    (deferr object-not-simple-array-signed-byte-8-error (object)
389      (error 'type-error
390             :function-name name
391             :datum object
392             :expected-type '(simple-array (signed-byte 8) (*))))
393    
394    (deferr object-not-simple-array-signed-byte-16-error (object)
395      (error 'type-error
396             :function-name name
397             :datum object
398             :expected-type '(simple-array (signed-byte 16) (*))))
399    
400    (deferr object-not-simple-array-signed-byte-30-error (object)
401      (error 'type-error
402             :function-name name
403             :datum object
404             :expected-type '(simple-array (signed-byte 30) (*))))
405    
406    (deferr object-not-simple-array-signed-byte-32-error (object)
407      (error 'type-error
408             :function-name name
409             :datum object
410             :expected-type '(simple-array (signed-byte 32) (*))))
411    
412  (deferr object-not-simple-array-single-float-error (object)  (deferr object-not-simple-array-single-float-error (object)
413    (error 'type-error    (error 'type-error
414           :function-name name           :function-name name
# Line 371  Line 421 
421           :datum object           :datum object
422           :expected-type '(simple-array double-float (*))))           :expected-type '(simple-array double-float (*))))
423    
424    #+double-double
425    (deferr object-not-simple-array-double-double-float-error (object)
426      (error 'type-error
427             :function-name name
428             :datum object
429             :expected-type '(simple-array double-double-float (*))))
430    
431    (deferr object-not-simple-array-complex-single-float-error (object)
432      (error 'type-error
433             :function-name name
434             :datum object
435             :expected-type '(simple-array (complex single-float) (*))))
436    
437    (deferr object-not-simple-array-complex-double-float-error (object)
438      (error 'type-error
439             :function-name name
440             :datum object
441             :expected-type '(simple-array (complex double-float) (*))))
442    
443    #+long-float
444    (deferr object-not-simple-array-complex-long-float-error (object)
445      (error 'type-error
446             :function-name name
447             :datum object
448             :expected-type '(simple-array (complex long-float) (*))))
449    
450    #+double-double
451    (deferr object-not-simple-array-complex-double-double-float-error (object)
452      (error 'type-error
453             :function-name name
454             :datum object
455             :expected-type '(simple-array (complex double-double-float) (*))))
456    
457  (deferr object-not-complex-error (object)  (deferr object-not-complex-error (object)
458    (error 'type-error    (error 'type-error
459           :function-name name           :function-name name
460           :datum object           :datum object
461           :expected-type 'complex))           :expected-type 'complex))
462    
463    (deferr object-not-complex-rational-error (object)
464      (error 'type-error
465             :function-name name
466             :datum object
467             :expected-type '(complex rational)))
468    
469    (deferr object-not-complex-single-float-error (object)
470      (error 'type-error
471             :function-name name
472             :datum object
473             :expected-type '(complex single-float)))
474    
475    (deferr object-not-complex-double-float-error (object)
476      (error 'type-error
477             :function-name name
478             :datum object
479             :expected-type '(complex double-float)))
480    
481    #+long-float
482    (deferr object-not-complex-long-float-error (object)
483      (error 'type-error
484             :function-name name
485             :datum object
486             :expected-type '(complex long-float)))
487    
488    #+double-double
489    (deferr object-not-complex-double-double-float-error (object)
490      (error 'type-error
491             :function-name name
492             :datum object
493             :expected-type '(complex double-double-float)))
494    
495  (deferr object-not-weak-pointer-error (object)  (deferr object-not-weak-pointer-error (object)
496    (error 'type-error    (error 'type-error
497           :function-name name           :function-name name
# Line 389  Line 504 
504           :datum object           :datum object
505           :expected-type 'instance))           :expected-type 'instance))
506    
507    #+linkage-table
508    (deferr undefined-foreign-symbol-error (symbol)
509      (error 'simple-program-error
510             :function-name name
511             :format-control (intl:gettext "Undefined foreign symbol: ~S")
512             :format-arguments (list symbol)))
513    
514    
515  ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of  ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of
# Line 399  Line 520 
520              (numberp *current-error-depth*))              (numberp *current-error-depth*))
521         (let ((*current-error-depth* (1+ *current-error-depth*)))         (let ((*current-error-depth* (1+ *current-error-depth*)))
522           (if (> *current-error-depth* *maximum-error-depth*)           (if (> *current-error-depth* *maximum-error-depth*)
523               (error-error "Help! " *current-error-depth* " nested errors.  "               (error-error (intl:gettext "Help! ") *current-error-depth* (intl:gettext " nested errors.  ")
524                            "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")                            (intl:gettext "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded."))
525               (progn ,@forms)))               (progn ,@forms)))
526         (%primitive halt)))         (%primitive halt)))
527    
# Line 499  Line 620 
620    (infinite-error-protect    (infinite-error-protect
621     (let ((scp (locally     (let ((scp (locally
622                  (declare (optimize (inhibit-warnings 3)))                  (declare (optimize (inhibit-warnings 3)))
623                  (alien:sap-alien scp (* unix:s-context)))))                  (alien:sap-alien scp (* unix:sigcontext)))))
624       (multiple-value-bind       (multiple-value-bind
625           (error-number arguments)           (error-number arguments)
626           (vm:internal-error-arguments scp)           (vm:internal-error-arguments scp)
627         (multiple-value-bind         (multiple-value-bind
628             (name debug:*stack-top-hint*)             (name debug:*stack-top-hint*)
629             (find-interrupted-name)             (find-interrupted-name)
630           (let ((fp (int-sap (vm:s-context-register scp vm::cfp-offset)))           (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
631                 (handler (and (< -1 error-number (length *internal-errors*))                 (handler (and (< -1 error-number (length *internal-errors*))
632                               (svref *internal-errors* error-number))))                               (svref *internal-errors* error-number))))
633             (cond ((null handler)             (cond ((null handler)
634                    (error 'simple-error                    (error 'simple-error
635                           :function-name name                           :function-name name
636                           :format-control                           :format-control
637                           "Unknown internal error, ~D?  args=~S"                           (intl:gettext "Unknown internal error, ~D?  args=~S")
638                           :format-arguments                           :format-arguments
639                           (list error-number                           (list error-number
640                                 (mapcar #'(lambda (sc-offset)                                 (mapcar #'(lambda (sc-offset)
# Line 524  Line 645 
645                    (error 'simple-error                    (error 'simple-error
646                           :function-name name                           :function-name name
647                           :format-control                           :format-control
648                           "Internal error ~D: ~A.  args=~S"                           (intl:gettext "Internal error ~D: ~A.  args=~S")
649                           :format-arguments                           :format-arguments
650                           (list error-number                           (list error-number
651                                 handler                                 handler
# Line 535  Line 656 
656                   (t                   (t
657                    (funcall handler name fp scp arguments)))))))))                    (funcall handler name fp scp arguments)))))))))
658    
659    ;;;
660    ;;; Called from C when the yellow control stack guard zone is hit.
661    ;;; The yellow zone is unprotected in the C code prior to calling this
662    ;;; function, to give some room for debugging.  The red zone is still
663    ;;; protected.
664    ;;;
665    #+stack-checking
666    (defun yellow-zone-hit ()
667      (let ((debug:*stack-top-hint* nil))
668        (format *error-output*
669                (intl:gettext "~2&~@<A control stack overflow has occurred:~%~
670                the program has entered the yellow control stack guard zone.~%~
671                Please note that you will be returned to the Top-Level if you~%~
672                enter the red control stack guard zone while debugging.~@:>~2%"))
673        (infinite-error-protect (error 'stack-overflow))))
674    
675    ;;;
676    ;;; Called from C when the red control stack guard zone is hit.  We
677    ;;; could ABORT here, which would usually take us back to the debugger
678    ;;; or top-level, and add code to the restarts re-protecting the red
679    ;;; zone (which can't be done here because we're still in the red
680    ;;; zone).  Using ABORT is too dangerous because users may be using
681    ;;; abort restarts which don't do the necessary re-protecting of the
682    ;;; red zone, and would thus render CMUCL unprotected.
683    ;;;
684    #+stack-checking
685    (defun red-zone-hit ()
686      (format *error-output*
687              (intl:gettext "~2&~@<Fatal control stack overflow.  You have entered~%~
688               the red control stack guard zone while debugging.~%~
689               Returning to Top-Level.~@:>~2%"))
690      (throw 'lisp::top-level-catcher nil))
691    
692    #+heap-overflow-check
693    (defun dynamic-space-overflow-warning-hit ()
694      (let ((debug:*stack-top-hint* nil))
695        ;; Don't reserve any more pages
696        (setf lisp::reserved-heap-pages 0)
697        (format *error-output*
698                (intl:gettext "~2&~@<Imminent dynamic space overflow has occurred:~%~
699                Only a small amount of dynamic space is available now.~%~
700                Please note that you will be returned to the Top-Level without~%~
701                warning if you run out of space while debugging.~@:>~%"))
702        (infinite-error-protect (error 'heap-overflow))))
703    
704    #+heap-overflow-check
705    (defun dynamic-space-overflow-error-hit ()
706      (throw 'lisp::top-level-catcher nil))
707    

Legend:
Removed from v.1.28.1.1  
changed lines
  Added in v.1.51

  ViewVC Help
Powered by ViewVC 1.1.5