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

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.47.24.2 - (show annotations)
Tue Feb 9 20:23:02 2010 UTC (4 years, 2 months ago) by rtoy
Branch: intl-branch
CVS Tags: intl-branch-working-2010-02-11-1000
Changes since 1.47.24.1: +16 -16 lines
Mark translatable strings; update cmucl.pot and ko/cmucl.po
accordingly.
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 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/interr.lisp,v 1.47.24.2 2010/02/09 20:23:02 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Functions and macros to define and deal with internal errors (i.e.
13 ;;; problems that can be signaled from assembler code).
14 ;;;
15 ;;; Written by William Lott.
16 ;;;
17
18 (in-package "KERNEL")
19
20 (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
29 ;;;; Internal Errors
30
31 (defvar *internal-errors*
32 (macrolet ((frob ()
33 (map 'vector #'cdr (c:backend-internal-errors c:*backend*))))
34 (frob)))
35
36
37 (eval-when (compile eval)
38
39 (defmacro deferr (name args &rest body)
40 (let* ((rest-pos (position '&rest args))
41 (required (if rest-pos (subseq args 0 rest-pos) args))
42 (fp (gensym "FP-"))
43 (sigcontext (gensym "SIGCONTEXT-"))
44 (sc-offsets (gensym "SC-OFFSETS-"))
45 (temp (gensym))
46 (fn-name (symbolicate name "-HANDLER")))
47 `(progn
48 (defun ,fn-name (name ,fp ,sigcontext ,sc-offsets)
49 (declare (ignorable name ,fp ,sigcontext ,sc-offsets))
50 (macrolet ((set-value (var value)
51 (let ((pos (position var ',required)))
52 (unless pos
53 (error "~S isn't one of the required args."
54 var))
55 `(let ((,',temp ,value))
56 (di::sub-set-debug-var-slot
57 ,',fp (nth ,pos ,',sc-offsets)
58 ,',temp ,',sigcontext)
59 (setf ,var ,',temp)))))
60 (let (,@(let ((offset -1))
61 (mapcar #'(lambda (var)
62 `(,var (di::sub-access-debug-var-slot
63 ,fp
64 (nth ,(incf offset)
65 ,sc-offsets)
66 ,sigcontext)))
67 required))
68 ,@(when rest-pos
69 `((,(nth (1+ rest-pos) args)
70 (mapcar #'(lambda (sc-offset)
71 (di::sub-access-debug-var-slot
72 ,fp
73 sc-offset
74 ,sigcontext))
75 (nthcdr ,rest-pos ,sc-offsets))))))
76 ,@body)))
77 (setf (svref *internal-errors* ,(error-number-or-lose name))
78 #',fn-name))))
79
80 ) ; Eval-When (Compile Eval)
81
82
83
84 (deferr unknown-error (&rest args)
85 (error "Unknown error:~{ ~S~})" args))
86
87 (deferr object-not-function-error (object)
88 (error 'type-error
89 :function-name name
90 :datum object
91 :expected-type 'function))
92
93 (deferr object-not-list-error (object)
94 (error 'type-error
95 :function-name name
96 :datum object
97 :expected-type 'list))
98
99 (deferr object-not-bignum-error (object)
100 (error 'type-error
101 :function-name name
102 :datum object
103 :expected-type 'bignum))
104
105 (deferr object-not-ratio-error (object)
106 (error 'type-error
107 :function-name name
108 :datum object
109 :expected-type 'ratio))
110
111 (deferr object-not-single-float-error (object)
112 (error 'type-error
113 :function-name name
114 :datum object
115 :expected-type 'single-float))
116
117 (deferr object-not-double-float-error (object)
118 (error 'type-error
119 :function-name name
120 :datum object
121 :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)
138 (error 'type-error
139 :function-name name
140 :datum object
141 :expected-type 'simple-string))
142
143 (deferr object-not-simple-bit-vector-error (object)
144 (error 'type-error
145 :function-name name
146 :datum object
147 :expected-type 'simple-bit-vector))
148
149 (deferr object-not-simple-vector-error (object)
150 (error 'type-error
151 :function-name name
152 :datum object
153 :expected-type 'simple-vector))
154
155 (deferr object-not-fixnum-error (object)
156 (error 'type-error
157 :function-name name
158 :datum object
159 :expected-type 'fixnum))
160
161 (deferr object-not-function-or-symbol-error (object)
162 (error 'type-error
163 :function-name name
164 :datum object
165 :expected-type '(or function symbol)))
166
167 (deferr object-not-vector-error (object)
168 (error 'type-error
169 :function-name name
170 :datum object
171 :expected-type 'vector))
172
173 (deferr object-not-string-error (object)
174 (error 'type-error
175 :function-name name
176 :datum object
177 :expected-type 'string))
178
179 (deferr object-not-bit-vector-error (object)
180 (error 'type-error
181 :function-name name
182 :datum object
183 :expected-type 'bit-vector))
184
185 (deferr object-not-array-error (object)
186 (error 'type-error
187 :function-name name
188 :datum object
189 :expected-type 'array))
190
191 (deferr object-not-number-error (object)
192 (error 'type-error
193 :function-name name
194 :datum object
195 :expected-type 'number))
196
197 (deferr object-not-rational-error (object)
198 (error 'type-error
199 :function-name name
200 :datum object
201 :expected-type 'rational))
202
203 (deferr object-not-float-error (object)
204 (error 'type-error
205 :function-name name
206 :datum object
207 :expected-type 'float))
208
209 (deferr object-not-real-error (object)
210 (error 'type-error
211 :function-name name
212 :datum object
213 :expected-type 'real))
214
215 (deferr object-not-integer-error (object)
216 (error 'type-error
217 :function-name name
218 :datum object
219 :expected-type 'integer))
220
221 (deferr object-not-cons-error (object)
222 (error 'type-error
223 :function-name name
224 :datum object
225 :expected-type 'cons))
226
227 (deferr object-not-symbol-error (object)
228 (error 'type-error
229 :function-name name
230 :datum object
231 :expected-type 'symbol))
232
233 (deferr undefined-symbol-error (fdefn-or-symbol)
234 (error 'undefined-function
235 :function-name name
236 :name (etypecase fdefn-or-symbol
237 (symbol fdefn-or-symbol)
238 (fdefn (fdefn-name fdefn-or-symbol)))))
239
240 (deferr object-not-coercable-to-function-error (object)
241 (error 'type-error
242 :function-name name
243 :datum object
244 :expected-type 'coercable-to-function))
245
246 (deferr invalid-argument-count-error (nargs)
247 (error 'simple-program-error
248 :function-name name
249 :format-control "Invalid number of arguments: ~S"
250 :format-arguments (list nargs)))
251
252 (deferr bogus-argument-to-values-list-error (list)
253 (error 'simple-type-error
254 :function-name name
255 :datum list
256 :expected-type 'list
257 :format-control "Attempt to use VALUES-LIST on a dotted-list:~% ~S"
258 :format-arguments (list list)))
259
260 (deferr unbound-symbol-error (symbol)
261 (error 'unbound-variable :function-name name :name symbol))
262
263 (deferr object-not-base-char-error (object)
264 (error 'type-error
265 :function-name name
266 :datum object
267 :expected-type 'base-char))
268
269 (deferr object-not-sap-error (object)
270 (error 'type-error
271 :function-name name
272 :datum object
273 :expected-type 'system-area-pointer))
274
275 (deferr invalid-unwind-error ()
276 (error 'simple-control-error
277 :function-name name
278 :format-control
279 _"Attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
280
281 (deferr unseen-throw-tag-error (tag)
282 (error 'simple-control-error
283 :function-name name
284 :format-control _"Attempt to THROW to a tag that does not exist: ~S"
285 :format-arguments (list tag)))
286
287 (deferr nil-function-returned-error (function)
288 (error 'simple-control-error
289 :function-name name
290 :format-control
291 _"Function with declared result type NIL returned:~% ~S"
292 :format-arguments (list function)))
293
294 (deferr division-by-zero-error (this that)
295 (error 'division-by-zero
296 :function-name name
297 :operation 'division
298 :operands (list this that)))
299
300 (deferr object-not-type-error (object type)
301 (error (if (and (%instancep object)
302 (layout-invalid (%instance-layout object)))
303 'layout-invalid
304 'type-error)
305 :function-name name
306 :datum object
307 :expected-type type))
308
309 (deferr layout-invalid-error (object layout)
310 (error 'layout-invalid
311 :function-name name
312 :datum object
313 :expected-type (layout-class layout)))
314
315 (deferr odd-keyword-arguments-error ()
316 (error 'simple-program-error
317 :function-name name
318 :format-control _"Odd number of keyword arguments."))
319
320 (deferr unknown-keyword-argument-error (key)
321 (error 'simple-program-error
322 :function-name name
323 :format-control _"Unknown keyword: ~S"
324 :format-arguments (list key)))
325
326 (deferr invalid-array-index-error (array bound index)
327 (error 'type-error
328 :function-name name
329 :datum index
330 :expected-type `(integer 0 (,bound))
331 :format-control
332 (cond ((zerop bound)
333 "Invalid array index, ~D for ~S. Array has no elements.")
334 ((minusp index)
335 "Invalid array index, ~D for ~S. Should have greater than or equal to 0.")
336 (t
337 "Invalid array index, ~D for ~S. Should have been less than ~D"))
338 :format-arguments (list index array bound)))
339
340 (deferr object-not-simple-array-error (object)
341 (error 'type-error
342 :function-name name
343 :datum object
344 :expected-type 'simple-array))
345
346 (deferr object-not-signed-byte-32-error (object)
347 (error 'type-error
348 :function-name name
349 :datum object
350 :expected-type '(signed-byte 32)))
351
352 (deferr object-not-unsigned-byte-32-error (object)
353 (error 'type-error
354 :function-name name
355 :datum object
356 :expected-type '(unsigned-byte 32)))
357
358 (deferr object-not-simple-array-unsigned-byte-2-error (object)
359 (error 'type-error
360 :function-name name
361 :datum object
362 :expected-type '(simple-array (unsigned-byte 2) (*))))
363
364 (deferr object-not-simple-array-unsigned-byte-4-error (object)
365 (error 'type-error
366 :function-name name
367 :datum object
368 :expected-type '(simple-array (unsigned-byte 4) (*))))
369
370 (deferr object-not-simple-array-unsigned-byte-8-error (object)
371 (error 'type-error
372 :function-name name
373 :datum object
374 :expected-type '(simple-array (unsigned-byte 8) (*))))
375
376 (deferr object-not-simple-array-unsigned-byte-16-error (object)
377 (error 'type-error
378 :function-name name
379 :datum object
380 :expected-type '(simple-array (unsigned-byte 16) (*))))
381
382 (deferr object-not-simple-array-unsigned-byte-32-error (object)
383 (error 'type-error
384 :function-name name
385 :datum object
386 :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)
413 (error 'type-error
414 :function-name name
415 :datum object
416 :expected-type '(simple-array single-float (*))))
417
418 (deferr object-not-simple-array-double-float-error (object)
419 (error 'type-error
420 :function-name name
421 :datum object
422 :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)
458 (error 'type-error
459 :function-name name
460 :datum object
461 :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)
496 (error 'type-error
497 :function-name name
498 :datum object
499 :expected-type 'weak-pointer))
500
501 (deferr object-not-instance-error (object)
502 (error 'type-error
503 :function-name name
504 :datum object
505 :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 _"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
516 ;;; hyperspace.
517 ;;;
518 (defmacro infinite-error-protect (&rest forms)
519 `(if (and (boundp '*error-system-initialized*)
520 (numberp *current-error-depth*))
521 (let ((*current-error-depth* (1+ *current-error-depth*)))
522 (if (> *current-error-depth* *maximum-error-depth*)
523 (error-error _"Help! " *current-error-depth* _" nested errors. "
524 _"KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
525 (progn ,@forms)))
526 (%primitive halt)))
527
528 ;;; Track the depth of recursive errors.
529 ;;;
530 (defvar *maximum-error-depth* 10
531 _N"The maximum number of nested errors allowed. Internal errors are
532 double-counted.")
533 (defvar *current-error-depth* 0 _N"The current number of nested errors.")
534
535 ;;; These specials are used by ERROR-ERROR to track the success of recovery
536 ;;; attempts.
537 ;;;
538 (defvar *error-error-depth* 0)
539 (defvar *error-throw-up-count* 0)
540
541 ;;; This protects against errors that happen before we run this top-level form.
542 ;;;
543 (defvar *error-system-initialized* t)
544
545 ;;; ERROR-ERROR can be called when the error system is in trouble and needs
546 ;;; to punt fast. Prints a message without using format. If we get into
547 ;;; this recursively, then halt.
548 ;;;
549 (defun error-error (&rest messages)
550 (let ((*error-error-depth* (1+ *error-error-depth*)))
551 (when (> *error-throw-up-count* 50)
552 (%primitive halt)
553 (throw 'lisp::top-level-catcher nil))
554 (case *error-error-depth*
555 (1)
556 (2
557 (lisp::stream-init))
558 (3
559 (incf *error-throw-up-count*)
560 (throw 'lisp::top-level-catcher nil))
561 (t
562 (%primitive halt)
563 (throw 'lisp::top-level-catcher nil)))
564
565 (with-standard-io-syntax
566 (let ((*print-readably* nil))
567 (dolist (item messages) (princ item *terminal-io*))
568 (debug:internal-debug)))))
569
570
571 ;;;; Fetching errorful function name.
572
573 ;;; Used to prevent infinite recursive lossage when we can't find the caller
574 ;;; for some reason.
575 ;;;
576 (defvar *finding-name* nil)
577
578 ;;; FIND-CALLER-NAME -- Internal
579 ;;;
580 (defun find-caller-name ()
581 (if *finding-name*
582 (values "<error finding name>" nil)
583 (handler-case
584 (let* ((*finding-name* t)
585 (frame (di:frame-down (di:frame-down (di:top-frame))))
586 (name (di:debug-function-name
587 (di:frame-debug-function frame))))
588 (di:flush-frames-above frame)
589 (values name frame))
590 (error ()
591 (values "<error finding name>" nil))
592 (di:debug-condition ()
593 (values "<error finding name>" nil)))))
594
595
596 (defun find-interrupted-name ()
597 (if *finding-name*
598 (values "<error finding name>" nil)
599 (handler-case
600 (let ((*finding-name* t))
601 (do ((frame (di:top-frame) (di:frame-down frame)))
602 ((null frame)
603 (values "<error finding name>" nil))
604 (when (and (di::compiled-frame-p frame)
605 (di::compiled-frame-escaped frame))
606 (di:flush-frames-above frame)
607 (return (values (di:debug-function-name
608 (di:frame-debug-function frame))
609 frame)))))
610 (error ()
611 (values "<error finding name>" nil))
612 (di:debug-condition ()
613 (values "<error finding name>" nil)))))
614
615
616 ;;;; internal-error signal handler.
617
618 (defun internal-error (scp continuable)
619 (declare (type system-area-pointer scp) (ignore continuable))
620 (infinite-error-protect
621 (let ((scp (locally
622 (declare (optimize (inhibit-warnings 3)))
623 (alien:sap-alien scp (* unix:sigcontext)))))
624 (multiple-value-bind
625 (error-number arguments)
626 (vm:internal-error-arguments scp)
627 (multiple-value-bind
628 (name debug:*stack-top-hint*)
629 (find-interrupted-name)
630 (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
631 (handler (and (< -1 error-number (length *internal-errors*))
632 (svref *internal-errors* error-number))))
633 (cond ((null handler)
634 (error 'simple-error
635 :function-name name
636 :format-control
637 _"Unknown internal error, ~D? args=~S"
638 :format-arguments
639 (list error-number
640 (mapcar #'(lambda (sc-offset)
641 (di::sub-access-debug-var-slot
642 fp sc-offset scp))
643 arguments))))
644 ((not (functionp handler))
645 (error 'simple-error
646 :function-name name
647 :format-control
648 _"Internal error ~D: ~A. args=~S"
649 :format-arguments
650 (list error-number
651 handler
652 (mapcar #'(lambda (sc-offset)
653 (di::sub-access-debug-var-slot
654 fp sc-offset scp))
655 arguments))))
656 (t
657 (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 _"~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 _"~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 _"~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

  ViewVC Help
Powered by ViewVC 1.1.5