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

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.49 - (hide annotations)
Mon Apr 19 02:18:03 2010 UTC (4 years ago) by rtoy
Branch: MAIN
Changes since 1.48: +3 -3 lines
Remove _N"" reader macro from docstrings when possible.
1 wlott 1.1 ;;; -*- Log: code.log; Package: KERNEL -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.16 ;;; 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 rtoy 1.49 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/interr.lisp,v 1.49 2010/04/19 02:18:03 rtoy Exp $")
9 ram 1.16 ;;;
10 wlott 1.1 ;;; **********************************************************************
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 rtoy 1.48 (intl:textdomain "cmucl")
21    
22 gerd 1.40 (export '(infinite-error-protect find-caller-name *maximum-error-depth*
23 pmai 1.44 #+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 wlott 1.1
27    
28    
29     ;;;; Internal Errors
30    
31 wlott 1.24 (defvar *internal-errors*
32     (macrolet ((frob ()
33     (map 'vector #'cdr (c:backend-internal-errors c:*backend*))))
34     (frob)))
35 wlott 1.1
36    
37     (eval-when (compile eval)
38    
39 wlott 1.24 (defmacro deferr (name args &rest body)
40 wlott 1.7 (let* ((rest-pos (position '&rest args))
41     (required (if rest-pos (subseq args 0 rest-pos) args))
42 rtoy 1.47 (fp (gensym "FP-"))
43     (sigcontext (gensym "SIGCONTEXT-"))
44     (sc-offsets (gensym "SC-OFFSETS-"))
45 wlott 1.24 (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 rtoy 1.48 (error _"~S isn't one of the required args."
54 wlott 1.24 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 wlott 1.1
80 wlott 1.7 ) ; Eval-When (Compile Eval)
81 wlott 1.1
82    
83    
84 wlott 1.24 (deferr unknown-error (&rest args)
85 rtoy 1.48 (error _"Unknown error:~{ ~S~})" args))
86 wlott 1.1
87 wlott 1.24 (deferr object-not-function-error (object)
88 wlott 1.15 (error 'type-error
89     :function-name name
90     :datum object
91     :expected-type 'function))
92 wlott 1.1
93 wlott 1.24 (deferr object-not-list-error (object)
94 wlott 1.15 (error 'type-error
95     :function-name name
96     :datum object
97     :expected-type 'list))
98 wlott 1.1
99 wlott 1.24 (deferr object-not-bignum-error (object)
100 wlott 1.15 (error 'type-error
101     :function-name name
102     :datum object
103     :expected-type 'bignum))
104 wlott 1.1
105 wlott 1.24 (deferr object-not-ratio-error (object)
106 wlott 1.15 (error 'type-error
107     :function-name name
108     :datum object
109     :expected-type 'ratio))
110 wlott 1.1
111 wlott 1.24 (deferr object-not-single-float-error (object)
112 wlott 1.15 (error 'type-error
113     :function-name name
114     :datum object
115     :expected-type 'single-float))
116 wlott 1.1
117 wlott 1.24 (deferr object-not-double-float-error (object)
118 wlott 1.15 (error 'type-error
119     :function-name name
120     :datum object
121     :expected-type 'double-float))
122 wlott 1.1
123 dtc 1.33 #+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 rtoy 1.45 #+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 wlott 1.24 (deferr object-not-simple-string-error (object)
138 wlott 1.15 (error 'type-error
139     :function-name name
140     :datum object
141     :expected-type 'simple-string))
142 wlott 1.1
143 wlott 1.24 (deferr object-not-simple-bit-vector-error (object)
144 wlott 1.15 (error 'type-error
145     :function-name name
146     :datum object
147     :expected-type 'simple-bit-vector))
148 wlott 1.1
149 wlott 1.24 (deferr object-not-simple-vector-error (object)
150 wlott 1.15 (error 'type-error
151     :function-name name
152     :datum object
153     :expected-type 'simple-vector))
154 wlott 1.1
155 wlott 1.24 (deferr object-not-fixnum-error (object)
156 wlott 1.15 (error 'type-error
157     :function-name name
158     :datum object
159     :expected-type 'fixnum))
160 wlott 1.1
161 wlott 1.24 (deferr object-not-function-or-symbol-error (object)
162 wlott 1.15 (error 'type-error
163     :function-name name
164     :datum object
165     :expected-type '(or function symbol)))
166 wlott 1.1
167 wlott 1.24 (deferr object-not-vector-error (object)
168 wlott 1.15 (error 'type-error
169     :function-name name
170     :datum object
171     :expected-type 'vector))
172 wlott 1.1
173 wlott 1.24 (deferr object-not-string-error (object)
174 wlott 1.15 (error 'type-error
175     :function-name name
176     :datum object
177     :expected-type 'string))
178 wlott 1.1
179 wlott 1.24 (deferr object-not-bit-vector-error (object)
180 wlott 1.15 (error 'type-error
181     :function-name name
182     :datum object
183     :expected-type 'bit-vector))
184 wlott 1.1
185 wlott 1.24 (deferr object-not-array-error (object)
186 wlott 1.15 (error 'type-error
187     :function-name name
188     :datum object
189     :expected-type 'array))
190 wlott 1.1
191 wlott 1.24 (deferr object-not-number-error (object)
192 wlott 1.15 (error 'type-error
193     :function-name name
194     :datum object
195     :expected-type 'number))
196 wlott 1.1
197 wlott 1.24 (deferr object-not-rational-error (object)
198 wlott 1.15 (error 'type-error
199     :function-name name
200     :datum object
201     :expected-type 'rational))
202 wlott 1.1
203 wlott 1.24 (deferr object-not-float-error (object)
204 wlott 1.15 (error 'type-error
205     :function-name name
206     :datum object
207     :expected-type 'float))
208 wlott 1.1
209 wlott 1.24 (deferr object-not-real-error (object)
210 wlott 1.15 (error 'type-error
211     :function-name name
212     :datum object
213     :expected-type 'real))
214 wlott 1.1
215 wlott 1.24 (deferr object-not-integer-error (object)
216 wlott 1.15 (error 'type-error
217     :function-name name
218     :datum object
219     :expected-type 'integer))
220 wlott 1.1
221 wlott 1.24 (deferr object-not-cons-error (object)
222 wlott 1.15 (error 'type-error
223     :function-name name
224     :datum object
225     :expected-type 'cons))
226 wlott 1.1
227 wlott 1.24 (deferr object-not-symbol-error (object)
228 wlott 1.15 (error 'type-error
229     :function-name name
230     :datum object
231     :expected-type 'symbol))
232 wlott 1.1
233 wlott 1.25 (deferr undefined-symbol-error (fdefn-or-symbol)
234 wlott 1.15 (error 'undefined-function
235     :function-name name
236 wlott 1.25 :name (etypecase fdefn-or-symbol
237     (symbol fdefn-or-symbol)
238     (fdefn (fdefn-name fdefn-or-symbol)))))
239 wlott 1.1
240 wlott 1.24 (deferr object-not-coercable-to-function-error (object)
241 wlott 1.15 (error 'type-error
242     :function-name name
243     :datum object
244     :expected-type 'coercable-to-function))
245 wlott 1.1
246 wlott 1.24 (deferr invalid-argument-count-error (nargs)
247 dtc 1.36 (error 'simple-program-error
248 wlott 1.15 :function-name name
249 rtoy 1.48 :format-control _"Invalid number of arguments: ~S"
250 wlott 1.15 :format-arguments (list nargs)))
251 wlott 1.1
252 wlott 1.24 (deferr bogus-argument-to-values-list-error (list)
253 dtc 1.36 (error 'simple-type-error
254 wlott 1.15 :function-name name
255 dtc 1.36 :datum list
256     :expected-type 'list
257 rtoy 1.48 :format-control _"Attempt to use VALUES-LIST on a dotted-list:~% ~S"
258 wlott 1.15 :format-arguments (list list)))
259 wlott 1.1
260 wlott 1.24 (deferr unbound-symbol-error (symbol)
261 wlott 1.15 (error 'unbound-variable :function-name name :name symbol))
262 wlott 1.1
263 wlott 1.24 (deferr object-not-base-char-error (object)
264 wlott 1.15 (error 'type-error
265     :function-name name
266     :datum object
267 wlott 1.18 :expected-type 'base-char))
268 wlott 1.1
269 wlott 1.24 (deferr object-not-sap-error (object)
270 wlott 1.15 (error 'type-error
271     :function-name name
272     :datum object
273     :expected-type 'system-area-pointer))
274 wlott 1.1
275 wlott 1.24 (deferr invalid-unwind-error ()
276 dtc 1.35 (error 'simple-control-error
277 wlott 1.15 :function-name name
278 ram 1.28 :format-control
279 rtoy 1.48 _"Attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
280 wlott 1.1
281 wlott 1.24 (deferr unseen-throw-tag-error (tag)
282 dtc 1.35 (error 'simple-control-error
283 wlott 1.15 :function-name name
284 rtoy 1.48 :format-control _"Attempt to THROW to a tag that does not exist: ~S"
285 wlott 1.15 :format-arguments (list tag)))
286 ram 1.19
287 wlott 1.24 (deferr nil-function-returned-error (function)
288 dtc 1.35 (error 'simple-control-error
289 ram 1.19 :function-name name
290 ram 1.28 :format-control
291 rtoy 1.48 _"Function with declared result type NIL returned:~% ~S"
292 ram 1.19 :format-arguments (list function)))
293 wlott 1.1
294 wlott 1.24 (deferr division-by-zero-error (this that)
295 wlott 1.15 (error 'division-by-zero
296     :function-name name
297     :operation 'division
298     :operands (list this that)))
299 wlott 1.1
300 wlott 1.24 (deferr object-not-type-error (object type)
301 ram 1.26 (error (if (and (%instancep object)
302     (layout-invalid (%instance-layout object)))
303     'layout-invalid
304     'type-error)
305 wlott 1.15 :function-name name
306     :datum object
307     :expected-type type))
308 wlott 1.1
309 ram 1.26 (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 wlott 1.24 (deferr odd-keyword-arguments-error ()
316 pmai 1.38 (error 'simple-program-error
317 wlott 1.15 :function-name name
318 rtoy 1.48 :format-control _"Odd number of keyword arguments."))
319 wlott 1.1
320 wlott 1.24 (deferr unknown-keyword-argument-error (key)
321 dtc 1.36 (error 'simple-program-error
322 wlott 1.15 :function-name name
323 rtoy 1.48 :format-control _"Unknown keyword: ~S"
324 wlott 1.15 :format-arguments (list key)))
325 wlott 1.1
326 wlott 1.24 (deferr invalid-array-index-error (array bound index)
327 gerd 1.41 (error 'type-error
328 wlott 1.15 :function-name name
329 gerd 1.42 :datum index
330     :expected-type `(integer 0 (,bound))
331 ram 1.28 :format-control
332 dtc 1.37 (cond ((zerop bound)
333 rtoy 1.48 _"Invalid array index, ~D for ~S. Array has no elements.")
334 dtc 1.37 ((minusp index)
335 rtoy 1.48 _"Invalid array index, ~D for ~S. Should have greater than or equal to 0.")
336 dtc 1.37 (t
337 rtoy 1.48 _"Invalid array index, ~D for ~S. Should have been less than ~D"))
338 wlott 1.15 :format-arguments (list index array bound)))
339 wlott 1.1
340 wlott 1.24 (deferr object-not-simple-array-error (object)
341 wlott 1.15 (error 'type-error
342     :function-name name
343     :datum object
344     :expected-type 'simple-array))
345 wlott 1.1
346 wlott 1.24 (deferr object-not-signed-byte-32-error (object)
347 wlott 1.15 (error 'type-error
348     :function-name name
349     :datum object
350     :expected-type '(signed-byte 32)))
351 wlott 1.1
352 wlott 1.24 (deferr object-not-unsigned-byte-32-error (object)
353 wlott 1.15 (error 'type-error
354     :function-name name
355     :datum object
356     :expected-type '(unsigned-byte 32)))
357 wlott 1.1
358 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-2-error (object)
359 wlott 1.15 (error 'type-error
360     :function-name name
361     :datum object
362     :expected-type '(simple-array (unsigned-byte 2) (*))))
363 wlott 1.1
364 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-4-error (object)
365 wlott 1.15 (error 'type-error
366     :function-name name
367     :datum object
368     :expected-type '(simple-array (unsigned-byte 4) (*))))
369 wlott 1.1
370 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-8-error (object)
371 wlott 1.15 (error 'type-error
372     :function-name name
373     :datum object
374     :expected-type '(simple-array (unsigned-byte 8) (*))))
375 wlott 1.1
376 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-16-error (object)
377 wlott 1.15 (error 'type-error
378     :function-name name
379     :datum object
380     :expected-type '(simple-array (unsigned-byte 16) (*))))
381 wlott 1.1
382 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-32-error (object)
383 wlott 1.15 (error 'type-error
384     :function-name name
385     :datum object
386     :expected-type '(simple-array (unsigned-byte 32) (*))))
387 dtc 1.30
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 wlott 1.1
412 wlott 1.24 (deferr object-not-simple-array-single-float-error (object)
413 wlott 1.15 (error 'type-error
414     :function-name name
415     :datum object
416     :expected-type '(simple-array single-float (*))))
417 wlott 1.1
418 wlott 1.24 (deferr object-not-simple-array-double-float-error (object)
419 wlott 1.15 (error 'type-error
420     :function-name name
421     :datum object
422     :expected-type '(simple-array double-float (*))))
423 wlott 1.1
424 rtoy 1.45 #+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 dtc 1.31 (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 dtc 1.34 #+long-float
444 dtc 1.33 (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 rtoy 1.45 #+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 wlott 1.24 (deferr object-not-complex-error (object)
458 wlott 1.15 (error 'type-error
459     :function-name name
460     :datum object
461     :expected-type 'complex))
462 dtc 1.32
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 dtc 1.31
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 dtc 1.33
481 dtc 1.34 #+long-float
482 dtc 1.33 (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 wlott 1.1
488 rtoy 1.45 #+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 wlott 1.24 (deferr object-not-weak-pointer-error (object)
496 wlott 1.15 (error 'type-error
497     :function-name name
498     :datum object
499     :expected-type 'weak-pointer))
500 wlott 1.11
501 ram 1.26 (deferr object-not-instance-error (object)
502 wlott 1.15 (error 'type-error
503 wlott 1.11 :function-name name
504 wlott 1.15 :datum object
505 ram 1.26 :expected-type 'instance))
506 wlott 1.15
507 pmai 1.39 #+linkage-table
508     (deferr undefined-foreign-symbol-error (symbol)
509     (error 'simple-program-error
510     :function-name name
511 rtoy 1.48 :format-control _"Undefined foreign symbol: ~S"
512 pmai 1.39 :format-arguments (list symbol)))
513 wlott 1.1
514    
515 ram 1.20 ;;; 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 rtoy 1.48 (error-error _"Help! " *current-error-depth* _" nested errors. "
524     _"KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
525 ram 1.20 (progn ,@forms)))
526     (%primitive halt)))
527 wlott 1.1
528 ram 1.20 ;;; Track the depth of recursive errors.
529     ;;;
530     (defvar *maximum-error-depth* 10
531 rtoy 1.49 "The maximum number of nested errors allowed. Internal errors are
532 ram 1.20 double-counted.")
533 rtoy 1.49 (defvar *current-error-depth* 0 "The current number of nested errors.")
534 wlott 1.6
535 ram 1.20 ;;; 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 ram 1.21 (let ((*print-readably* nil))
567     (dolist (item messages) (princ item *terminal-io*))
568     (debug:internal-debug)))))
569 ram 1.20
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 ram 1.21 (defvar *finding-name* nil)
577 ram 1.20
578     ;;; FIND-CALLER-NAME -- Internal
579     ;;;
580     (defun find-caller-name ()
581 ram 1.21 (if *finding-name*
582 wlott 1.23 (values "<error finding name>" nil)
583 ram 1.20 (handler-case
584 wlott 1.23 (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 ram 1.20
595    
596 wlott 1.6 (defun find-interrupted-name ()
597     (if *finding-name*
598 wlott 1.23 (values "<error finding name>" nil)
599 wlott 1.6 (handler-case
600     (let ((*finding-name* t))
601     (do ((frame (di:top-frame) (di:frame-down frame)))
602 wlott 1.27 ((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 wlott 1.23 (error ()
611     (values "<error finding name>" nil))
612     (di:debug-condition ()
613     (values "<error finding name>" nil)))))
614 wlott 1.6
615 ram 1.20
616     ;;;; internal-error signal handler.
617 wlott 1.6
618 wlott 1.13 (defun internal-error (scp continuable)
619 wlott 1.22 (declare (type system-area-pointer scp) (ignore continuable))
620 ram 1.20 (infinite-error-protect
621 wlott 1.24 (let ((scp (locally
622     (declare (optimize (inhibit-warnings 3)))
623     (alien:sap-alien scp (* unix:sigcontext)))))
624 wlott 1.22 (multiple-value-bind
625     (error-number arguments)
626     (vm:internal-error-arguments scp)
627 wlott 1.23 (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 wlott 1.24 (handler (and (< -1 error-number (length *internal-errors*))
632     (svref *internal-errors* error-number))))
633     (cond ((null handler)
634 wlott 1.23 (error 'simple-error
635     :function-name name
636 ram 1.28 :format-control
637 rtoy 1.48 _"Unknown internal error, ~D? args=~S"
638 wlott 1.23 :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 wlott 1.24 ((not (functionp handler))
645 wlott 1.23 (error 'simple-error
646     :function-name name
647 ram 1.28 :format-control
648 rtoy 1.48 _"Internal error ~D: ~A. args=~S"
649 wlott 1.23 :format-arguments
650     (list error-number
651 wlott 1.24 handler
652 wlott 1.23 (mapcar #'(lambda (sc-offset)
653     (di::sub-access-debug-var-slot
654     fp sc-offset scp))
655     arguments))))
656     (t
657 wlott 1.24 (funcall handler name fp scp arguments)))))))))
658 gerd 1.40
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 rtoy 1.48 _"~2&~@<A control stack overflow has occurred: ~
670 gerd 1.40 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 rtoy 1.48 _"~2&~@<Fatal control stack overflow. You have entered~%~
688 rtoy 1.46 the red control stack guard zone while debugging.~%~
689 gerd 1.40 Returning to Top-Level.~@:>~2%")
690     (throw 'lisp::top-level-catcher nil))
691    
692 toy 1.43 #+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 rtoy 1.48 _"~2&~@<Imminent dynamic space overflow has occurred:~%~
699 rtoy 1.46 Only a small amount of dynamic space is available now.~%~
700     Please note that you will be returned to the Top-Level without~%~
701 toy 1.43 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 ram 1.20

  ViewVC Help
Powered by ViewVC 1.1.5