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

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.47 - (hide annotations)
Fri Aug 17 14:02:12 2007 UTC (6 years, 8 months ago) by rtoy
Branch: MAIN
CVS Tags: merged-unicode-utf16-extfmt-2009-06-11, unicode-utf16-extfmt-2009-03-27, snapshot-2007-09, snapshot-2008-08, snapshot-2008-09, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, unicode-string-buffer-impl-base, sse2-base, unicode-string-buffer-base, sse2-packed-base, amd64-dd-start, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, release-19e, unicode-utf16-sync-2008-12, label-2009-03-16, release-19f-base, merge-sse2-packed, merge-with-19f, unicode-snapshot-2009-05, unicode-snapshot-2009-06, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, snapshot-2008-04, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, release-20a-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, unicode-utf16-sync-2008-11, pre-merge-intl-branch, release-19e-pre1, release-19e-pre2, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, label-2009-03-25, sse2-checkpoint-2008-10-01, sse2-merge-with-2008-11, sse2-merge-with-2008-10, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19e-base, intl-branch-base, unicode-utf16-base, portable-clx-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, pre-telent-clx
Branch point for: RELEASE-19F-BRANCH, portable-clx-branch, unicode-string-buffer-branch, sse2-packed-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, unicode-utf16-branch, release-19e-branch, sse2-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.46: +4 -4 lines
Generate more informative gensyms.
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.47 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/interr.lisp,v 1.47 2007/08/17 14:02:12 rtoy Rel $")
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 gerd 1.40 (export '(infinite-error-protect find-caller-name *maximum-error-depth*
21 pmai 1.44 #+stack-checking red-zone-hit #+stack-checking yellow-zone-hit
22     #+heap-overflow-check dynamic-space-overflow-error-hit
23     #+heap-overflow-check dynamic-space-overflow-warning-hit))
24 wlott 1.1
25    
26    
27     ;;;; Internal Errors
28    
29 wlott 1.24 (defvar *internal-errors*
30     (macrolet ((frob ()
31     (map 'vector #'cdr (c:backend-internal-errors c:*backend*))))
32     (frob)))
33 wlott 1.1
34    
35     (eval-when (compile eval)
36    
37 wlott 1.24 (defmacro deferr (name args &rest body)
38 wlott 1.7 (let* ((rest-pos (position '&rest args))
39     (required (if rest-pos (subseq args 0 rest-pos) args))
40 rtoy 1.47 (fp (gensym "FP-"))
41     (sigcontext (gensym "SIGCONTEXT-"))
42     (sc-offsets (gensym "SC-OFFSETS-"))
43 wlott 1.24 (temp (gensym))
44     (fn-name (symbolicate name "-HANDLER")))
45     `(progn
46     (defun ,fn-name (name ,fp ,sigcontext ,sc-offsets)
47     (declare (ignorable name ,fp ,sigcontext ,sc-offsets))
48     (macrolet ((set-value (var value)
49     (let ((pos (position var ',required)))
50     (unless pos
51     (error "~S isn't one of the required args."
52     var))
53     `(let ((,',temp ,value))
54     (di::sub-set-debug-var-slot
55     ,',fp (nth ,pos ,',sc-offsets)
56     ,',temp ,',sigcontext)
57     (setf ,var ,',temp)))))
58     (let (,@(let ((offset -1))
59     (mapcar #'(lambda (var)
60     `(,var (di::sub-access-debug-var-slot
61     ,fp
62     (nth ,(incf offset)
63     ,sc-offsets)
64     ,sigcontext)))
65     required))
66     ,@(when rest-pos
67     `((,(nth (1+ rest-pos) args)
68     (mapcar #'(lambda (sc-offset)
69     (di::sub-access-debug-var-slot
70     ,fp
71     sc-offset
72     ,sigcontext))
73     (nthcdr ,rest-pos ,sc-offsets))))))
74     ,@body)))
75     (setf (svref *internal-errors* ,(error-number-or-lose name))
76     #',fn-name))))
77 wlott 1.1
78 wlott 1.7 ) ; Eval-When (Compile Eval)
79 wlott 1.1
80    
81    
82 wlott 1.24 (deferr unknown-error (&rest args)
83 wlott 1.1 (error "Unknown error:~{ ~S~})" args))
84    
85 wlott 1.24 (deferr object-not-function-error (object)
86 wlott 1.15 (error 'type-error
87     :function-name name
88     :datum object
89     :expected-type 'function))
90 wlott 1.1
91 wlott 1.24 (deferr object-not-list-error (object)
92 wlott 1.15 (error 'type-error
93     :function-name name
94     :datum object
95     :expected-type 'list))
96 wlott 1.1
97 wlott 1.24 (deferr object-not-bignum-error (object)
98 wlott 1.15 (error 'type-error
99     :function-name name
100     :datum object
101     :expected-type 'bignum))
102 wlott 1.1
103 wlott 1.24 (deferr object-not-ratio-error (object)
104 wlott 1.15 (error 'type-error
105     :function-name name
106     :datum object
107     :expected-type 'ratio))
108 wlott 1.1
109 wlott 1.24 (deferr object-not-single-float-error (object)
110 wlott 1.15 (error 'type-error
111     :function-name name
112     :datum object
113     :expected-type 'single-float))
114 wlott 1.1
115 wlott 1.24 (deferr object-not-double-float-error (object)
116 wlott 1.15 (error 'type-error
117     :function-name name
118     :datum object
119     :expected-type 'double-float))
120 wlott 1.1
121 dtc 1.33 #+long-float
122     (deferr object-not-long-float-error (object)
123     (error 'type-error
124     :function-name name
125     :datum object
126     :expected-type 'long-float))
127    
128 rtoy 1.45 #+double-double
129     (deferr object-not-double-double-float-error (object)
130     (error 'type-error
131     :function-name name
132     :datum object
133     :expected-type 'double-double-float))
134    
135 wlott 1.24 (deferr object-not-simple-string-error (object)
136 wlott 1.15 (error 'type-error
137     :function-name name
138     :datum object
139     :expected-type 'simple-string))
140 wlott 1.1
141 wlott 1.24 (deferr object-not-simple-bit-vector-error (object)
142 wlott 1.15 (error 'type-error
143     :function-name name
144     :datum object
145     :expected-type 'simple-bit-vector))
146 wlott 1.1
147 wlott 1.24 (deferr object-not-simple-vector-error (object)
148 wlott 1.15 (error 'type-error
149     :function-name name
150     :datum object
151     :expected-type 'simple-vector))
152 wlott 1.1
153 wlott 1.24 (deferr object-not-fixnum-error (object)
154 wlott 1.15 (error 'type-error
155     :function-name name
156     :datum object
157     :expected-type 'fixnum))
158 wlott 1.1
159 wlott 1.24 (deferr object-not-function-or-symbol-error (object)
160 wlott 1.15 (error 'type-error
161     :function-name name
162     :datum object
163     :expected-type '(or function symbol)))
164 wlott 1.1
165 wlott 1.24 (deferr object-not-vector-error (object)
166 wlott 1.15 (error 'type-error
167     :function-name name
168     :datum object
169     :expected-type 'vector))
170 wlott 1.1
171 wlott 1.24 (deferr object-not-string-error (object)
172 wlott 1.15 (error 'type-error
173     :function-name name
174     :datum object
175     :expected-type 'string))
176 wlott 1.1
177 wlott 1.24 (deferr object-not-bit-vector-error (object)
178 wlott 1.15 (error 'type-error
179     :function-name name
180     :datum object
181     :expected-type 'bit-vector))
182 wlott 1.1
183 wlott 1.24 (deferr object-not-array-error (object)
184 wlott 1.15 (error 'type-error
185     :function-name name
186     :datum object
187     :expected-type 'array))
188 wlott 1.1
189 wlott 1.24 (deferr object-not-number-error (object)
190 wlott 1.15 (error 'type-error
191     :function-name name
192     :datum object
193     :expected-type 'number))
194 wlott 1.1
195 wlott 1.24 (deferr object-not-rational-error (object)
196 wlott 1.15 (error 'type-error
197     :function-name name
198     :datum object
199     :expected-type 'rational))
200 wlott 1.1
201 wlott 1.24 (deferr object-not-float-error (object)
202 wlott 1.15 (error 'type-error
203     :function-name name
204     :datum object
205     :expected-type 'float))
206 wlott 1.1
207 wlott 1.24 (deferr object-not-real-error (object)
208 wlott 1.15 (error 'type-error
209     :function-name name
210     :datum object
211     :expected-type 'real))
212 wlott 1.1
213 wlott 1.24 (deferr object-not-integer-error (object)
214 wlott 1.15 (error 'type-error
215     :function-name name
216     :datum object
217     :expected-type 'integer))
218 wlott 1.1
219 wlott 1.24 (deferr object-not-cons-error (object)
220 wlott 1.15 (error 'type-error
221     :function-name name
222     :datum object
223     :expected-type 'cons))
224 wlott 1.1
225 wlott 1.24 (deferr object-not-symbol-error (object)
226 wlott 1.15 (error 'type-error
227     :function-name name
228     :datum object
229     :expected-type 'symbol))
230 wlott 1.1
231 wlott 1.25 (deferr undefined-symbol-error (fdefn-or-symbol)
232 wlott 1.15 (error 'undefined-function
233     :function-name name
234 wlott 1.25 :name (etypecase fdefn-or-symbol
235     (symbol fdefn-or-symbol)
236     (fdefn (fdefn-name fdefn-or-symbol)))))
237 wlott 1.1
238 wlott 1.24 (deferr object-not-coercable-to-function-error (object)
239 wlott 1.15 (error 'type-error
240     :function-name name
241     :datum object
242     :expected-type 'coercable-to-function))
243 wlott 1.1
244 wlott 1.24 (deferr invalid-argument-count-error (nargs)
245 dtc 1.36 (error 'simple-program-error
246 wlott 1.15 :function-name name
247 ram 1.28 :format-control "Invalid number of arguments: ~S"
248 wlott 1.15 :format-arguments (list nargs)))
249 wlott 1.1
250 wlott 1.24 (deferr bogus-argument-to-values-list-error (list)
251 dtc 1.36 (error 'simple-type-error
252 wlott 1.15 :function-name name
253 dtc 1.36 :datum list
254     :expected-type 'list
255 ram 1.28 :format-control "Attempt to use VALUES-LIST on a dotted-list:~% ~S"
256 wlott 1.15 :format-arguments (list list)))
257 wlott 1.1
258 wlott 1.24 (deferr unbound-symbol-error (symbol)
259 wlott 1.15 (error 'unbound-variable :function-name name :name symbol))
260 wlott 1.1
261 wlott 1.24 (deferr object-not-base-char-error (object)
262 wlott 1.15 (error 'type-error
263     :function-name name
264     :datum object
265 wlott 1.18 :expected-type 'base-char))
266 wlott 1.1
267 wlott 1.24 (deferr object-not-sap-error (object)
268 wlott 1.15 (error 'type-error
269     :function-name name
270     :datum object
271     :expected-type 'system-area-pointer))
272 wlott 1.1
273 wlott 1.24 (deferr invalid-unwind-error ()
274 dtc 1.35 (error 'simple-control-error
275 wlott 1.15 :function-name name
276 ram 1.28 :format-control
277 wlott 1.15 "Attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
278 wlott 1.1
279 wlott 1.24 (deferr unseen-throw-tag-error (tag)
280 dtc 1.35 (error 'simple-control-error
281 wlott 1.15 :function-name name
282 ram 1.28 :format-control "Attempt to THROW to a tag that does not exist: ~S"
283 wlott 1.15 :format-arguments (list tag)))
284 ram 1.19
285 wlott 1.24 (deferr nil-function-returned-error (function)
286 dtc 1.35 (error 'simple-control-error
287 ram 1.19 :function-name name
288 ram 1.28 :format-control
289 ram 1.19 "Function with declared result type NIL returned:~% ~S"
290     :format-arguments (list function)))
291 wlott 1.1
292 wlott 1.24 (deferr division-by-zero-error (this that)
293 wlott 1.15 (error 'division-by-zero
294     :function-name name
295     :operation 'division
296     :operands (list this that)))
297 wlott 1.1
298 wlott 1.24 (deferr object-not-type-error (object type)
299 ram 1.26 (error (if (and (%instancep object)
300     (layout-invalid (%instance-layout object)))
301     'layout-invalid
302     'type-error)
303 wlott 1.15 :function-name name
304     :datum object
305     :expected-type type))
306 wlott 1.1
307 ram 1.26 (deferr layout-invalid-error (object layout)
308     (error 'layout-invalid
309     :function-name name
310     :datum object
311     :expected-type (layout-class layout)))
312    
313 wlott 1.24 (deferr odd-keyword-arguments-error ()
314 pmai 1.38 (error 'simple-program-error
315 wlott 1.15 :function-name name
316 ram 1.28 :format-control "Odd number of keyword arguments."))
317 wlott 1.1
318 wlott 1.24 (deferr unknown-keyword-argument-error (key)
319 dtc 1.36 (error 'simple-program-error
320 wlott 1.15 :function-name name
321 ram 1.28 :format-control "Unknown keyword: ~S"
322 wlott 1.15 :format-arguments (list key)))
323 wlott 1.1
324 wlott 1.24 (deferr invalid-array-index-error (array bound index)
325 gerd 1.41 (error 'type-error
326 wlott 1.15 :function-name name
327 gerd 1.42 :datum index
328     :expected-type `(integer 0 (,bound))
329 ram 1.28 :format-control
330 dtc 1.37 (cond ((zerop bound)
331     "Invalid array index, ~D for ~S. Array has no elements.")
332     ((minusp index)
333     "Invalid array index, ~D for ~S. Should have greater than or equal to 0.")
334     (t
335     "Invalid array index, ~D for ~S. Should have been less than ~D"))
336 wlott 1.15 :format-arguments (list index array bound)))
337 wlott 1.1
338 wlott 1.24 (deferr object-not-simple-array-error (object)
339 wlott 1.15 (error 'type-error
340     :function-name name
341     :datum object
342     :expected-type 'simple-array))
343 wlott 1.1
344 wlott 1.24 (deferr object-not-signed-byte-32-error (object)
345 wlott 1.15 (error 'type-error
346     :function-name name
347     :datum object
348     :expected-type '(signed-byte 32)))
349 wlott 1.1
350 wlott 1.24 (deferr object-not-unsigned-byte-32-error (object)
351 wlott 1.15 (error 'type-error
352     :function-name name
353     :datum object
354     :expected-type '(unsigned-byte 32)))
355 wlott 1.1
356 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-2-error (object)
357 wlott 1.15 (error 'type-error
358     :function-name name
359     :datum object
360     :expected-type '(simple-array (unsigned-byte 2) (*))))
361 wlott 1.1
362 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-4-error (object)
363 wlott 1.15 (error 'type-error
364     :function-name name
365     :datum object
366     :expected-type '(simple-array (unsigned-byte 4) (*))))
367 wlott 1.1
368 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-8-error (object)
369 wlott 1.15 (error 'type-error
370     :function-name name
371     :datum object
372     :expected-type '(simple-array (unsigned-byte 8) (*))))
373 wlott 1.1
374 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-16-error (object)
375 wlott 1.15 (error 'type-error
376     :function-name name
377     :datum object
378     :expected-type '(simple-array (unsigned-byte 16) (*))))
379 wlott 1.1
380 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-32-error (object)
381 wlott 1.15 (error 'type-error
382     :function-name name
383     :datum object
384     :expected-type '(simple-array (unsigned-byte 32) (*))))
385 dtc 1.30
386     (deferr object-not-simple-array-signed-byte-8-error (object)
387     (error 'type-error
388     :function-name name
389     :datum object
390     :expected-type '(simple-array (signed-byte 8) (*))))
391    
392     (deferr object-not-simple-array-signed-byte-16-error (object)
393     (error 'type-error
394     :function-name name
395     :datum object
396     :expected-type '(simple-array (signed-byte 16) (*))))
397    
398     (deferr object-not-simple-array-signed-byte-30-error (object)
399     (error 'type-error
400     :function-name name
401     :datum object
402     :expected-type '(simple-array (signed-byte 30) (*))))
403    
404     (deferr object-not-simple-array-signed-byte-32-error (object)
405     (error 'type-error
406     :function-name name
407     :datum object
408     :expected-type '(simple-array (signed-byte 32) (*))))
409 wlott 1.1
410 wlott 1.24 (deferr object-not-simple-array-single-float-error (object)
411 wlott 1.15 (error 'type-error
412     :function-name name
413     :datum object
414     :expected-type '(simple-array single-float (*))))
415 wlott 1.1
416 wlott 1.24 (deferr object-not-simple-array-double-float-error (object)
417 wlott 1.15 (error 'type-error
418     :function-name name
419     :datum object
420     :expected-type '(simple-array double-float (*))))
421 wlott 1.1
422 rtoy 1.45 #+double-double
423     (deferr object-not-simple-array-double-double-float-error (object)
424     (error 'type-error
425     :function-name name
426     :datum object
427     :expected-type '(simple-array double-double-float (*))))
428    
429 dtc 1.31 (deferr object-not-simple-array-complex-single-float-error (object)
430     (error 'type-error
431     :function-name name
432     :datum object
433     :expected-type '(simple-array (complex single-float) (*))))
434    
435     (deferr object-not-simple-array-complex-double-float-error (object)
436     (error 'type-error
437     :function-name name
438     :datum object
439     :expected-type '(simple-array (complex double-float) (*))))
440    
441 dtc 1.34 #+long-float
442 dtc 1.33 (deferr object-not-simple-array-complex-long-float-error (object)
443     (error 'type-error
444     :function-name name
445     :datum object
446     :expected-type '(simple-array (complex long-float) (*))))
447    
448 rtoy 1.45 #+double-double
449     (deferr object-not-simple-array-complex-double-double-float-error (object)
450     (error 'type-error
451     :function-name name
452     :datum object
453     :expected-type '(simple-array (complex double-double-float) (*))))
454    
455 wlott 1.24 (deferr object-not-complex-error (object)
456 wlott 1.15 (error 'type-error
457     :function-name name
458     :datum object
459     :expected-type 'complex))
460 dtc 1.32
461     (deferr object-not-complex-rational-error (object)
462     (error 'type-error
463     :function-name name
464     :datum object
465     :expected-type '(complex rational)))
466 dtc 1.31
467     (deferr object-not-complex-single-float-error (object)
468     (error 'type-error
469     :function-name name
470     :datum object
471     :expected-type '(complex single-float)))
472    
473     (deferr object-not-complex-double-float-error (object)
474     (error 'type-error
475     :function-name name
476     :datum object
477     :expected-type '(complex double-float)))
478 dtc 1.33
479 dtc 1.34 #+long-float
480 dtc 1.33 (deferr object-not-complex-long-float-error (object)
481     (error 'type-error
482     :function-name name
483     :datum object
484     :expected-type '(complex long-float)))
485 wlott 1.1
486 rtoy 1.45 #+double-double
487     (deferr object-not-complex-double-double-float-error (object)
488     (error 'type-error
489     :function-name name
490     :datum object
491     :expected-type '(complex double-double-float)))
492    
493 wlott 1.24 (deferr object-not-weak-pointer-error (object)
494 wlott 1.15 (error 'type-error
495     :function-name name
496     :datum object
497     :expected-type 'weak-pointer))
498 wlott 1.11
499 ram 1.26 (deferr object-not-instance-error (object)
500 wlott 1.15 (error 'type-error
501 wlott 1.11 :function-name name
502 wlott 1.15 :datum object
503 ram 1.26 :expected-type 'instance))
504 wlott 1.15
505 pmai 1.39 #+linkage-table
506     (deferr undefined-foreign-symbol-error (symbol)
507     (error 'simple-program-error
508     :function-name name
509     :format-control "Undefined foreign symbol: ~S"
510     :format-arguments (list symbol)))
511 wlott 1.1
512    
513 ram 1.20 ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of
514     ;;; hyperspace.
515     ;;;
516     (defmacro infinite-error-protect (&rest forms)
517     `(if (and (boundp '*error-system-initialized*)
518     (numberp *current-error-depth*))
519     (let ((*current-error-depth* (1+ *current-error-depth*)))
520     (if (> *current-error-depth* *maximum-error-depth*)
521 ram 1.21 (error-error "Help! " *current-error-depth* " nested errors. "
522 ram 1.20 "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
523     (progn ,@forms)))
524     (%primitive halt)))
525 wlott 1.1
526 ram 1.20 ;;; Track the depth of recursive errors.
527     ;;;
528     (defvar *maximum-error-depth* 10
529     "The maximum number of nested errors allowed. Internal errors are
530     double-counted.")
531     (defvar *current-error-depth* 0 "The current number of nested errors.")
532 wlott 1.6
533 ram 1.20 ;;; These specials are used by ERROR-ERROR to track the success of recovery
534     ;;; attempts.
535     ;;;
536     (defvar *error-error-depth* 0)
537     (defvar *error-throw-up-count* 0)
538    
539     ;;; This protects against errors that happen before we run this top-level form.
540     ;;;
541     (defvar *error-system-initialized* t)
542    
543     ;;; ERROR-ERROR can be called when the error system is in trouble and needs
544     ;;; to punt fast. Prints a message without using format. If we get into
545     ;;; this recursively, then halt.
546     ;;;
547     (defun error-error (&rest messages)
548     (let ((*error-error-depth* (1+ *error-error-depth*)))
549     (when (> *error-throw-up-count* 50)
550     (%primitive halt)
551     (throw 'lisp::top-level-catcher nil))
552     (case *error-error-depth*
553     (1)
554     (2
555     (lisp::stream-init))
556     (3
557     (incf *error-throw-up-count*)
558     (throw 'lisp::top-level-catcher nil))
559     (t
560     (%primitive halt)
561     (throw 'lisp::top-level-catcher nil)))
562    
563     (with-standard-io-syntax
564 ram 1.21 (let ((*print-readably* nil))
565     (dolist (item messages) (princ item *terminal-io*))
566     (debug:internal-debug)))))
567 ram 1.20
568    
569     ;;;; Fetching errorful function name.
570    
571     ;;; Used to prevent infinite recursive lossage when we can't find the caller
572     ;;; for some reason.
573     ;;;
574 ram 1.21 (defvar *finding-name* nil)
575 ram 1.20
576     ;;; FIND-CALLER-NAME -- Internal
577     ;;;
578     (defun find-caller-name ()
579 ram 1.21 (if *finding-name*
580 wlott 1.23 (values "<error finding name>" nil)
581 ram 1.20 (handler-case
582 wlott 1.23 (let* ((*finding-name* t)
583     (frame (di:frame-down (di:frame-down (di:top-frame))))
584     (name (di:debug-function-name
585     (di:frame-debug-function frame))))
586     (di:flush-frames-above frame)
587     (values name frame))
588     (error ()
589     (values "<error finding name>" nil))
590     (di:debug-condition ()
591     (values "<error finding name>" nil)))))
592 ram 1.20
593    
594 wlott 1.6 (defun find-interrupted-name ()
595     (if *finding-name*
596 wlott 1.23 (values "<error finding name>" nil)
597 wlott 1.6 (handler-case
598     (let ((*finding-name* t))
599     (do ((frame (di:top-frame) (di:frame-down frame)))
600 wlott 1.27 ((null frame)
601     (values "<error finding name>" nil))
602     (when (and (di::compiled-frame-p frame)
603     (di::compiled-frame-escaped frame))
604     (di:flush-frames-above frame)
605     (return (values (di:debug-function-name
606     (di:frame-debug-function frame))
607     frame)))))
608 wlott 1.23 (error ()
609     (values "<error finding name>" nil))
610     (di:debug-condition ()
611     (values "<error finding name>" nil)))))
612 wlott 1.6
613 ram 1.20
614     ;;;; internal-error signal handler.
615 wlott 1.6
616 wlott 1.13 (defun internal-error (scp continuable)
617 wlott 1.22 (declare (type system-area-pointer scp) (ignore continuable))
618 ram 1.20 (infinite-error-protect
619 wlott 1.24 (let ((scp (locally
620     (declare (optimize (inhibit-warnings 3)))
621     (alien:sap-alien scp (* unix:sigcontext)))))
622 wlott 1.22 (multiple-value-bind
623     (error-number arguments)
624     (vm:internal-error-arguments scp)
625 wlott 1.23 (multiple-value-bind
626     (name debug:*stack-top-hint*)
627     (find-interrupted-name)
628     (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
629 wlott 1.24 (handler (and (< -1 error-number (length *internal-errors*))
630     (svref *internal-errors* error-number))))
631     (cond ((null handler)
632 wlott 1.23 (error 'simple-error
633     :function-name name
634 ram 1.28 :format-control
635 wlott 1.23 "Unknown internal error, ~D? args=~S"
636     :format-arguments
637     (list error-number
638     (mapcar #'(lambda (sc-offset)
639     (di::sub-access-debug-var-slot
640     fp sc-offset scp))
641     arguments))))
642 wlott 1.24 ((not (functionp handler))
643 wlott 1.23 (error 'simple-error
644     :function-name name
645 ram 1.28 :format-control
646 wlott 1.23 "Internal error ~D: ~A. args=~S"
647     :format-arguments
648     (list error-number
649 wlott 1.24 handler
650 wlott 1.23 (mapcar #'(lambda (sc-offset)
651     (di::sub-access-debug-var-slot
652     fp sc-offset scp))
653     arguments))))
654     (t
655 wlott 1.24 (funcall handler name fp scp arguments)))))))))
656 gerd 1.40
657     ;;;
658     ;;; Called from C when the yellow control stack guard zone is hit.
659     ;;; The yellow zone is unprotected in the C code prior to calling this
660     ;;; function, to give some room for debugging. The red zone is still
661     ;;; protected.
662     ;;;
663     #+stack-checking
664     (defun yellow-zone-hit ()
665     (let ((debug:*stack-top-hint* nil))
666     (format *error-output*
667     "~2&~@<A control stack overflow has occurred: ~
668     the program has entered the yellow control stack guard zone. ~
669     Please note that you will be returned to the Top-Level if you ~
670     enter the red control stack guard zone while debugging.~@:>~2%")
671     (infinite-error-protect (error 'stack-overflow))))
672    
673     ;;;
674     ;;; Called from C when the red control stack guard zone is hit. We
675     ;;; could ABORT here, which would usually take us back to the debugger
676     ;;; or top-level, and add code to the restarts re-protecting the red
677     ;;; zone (which can't be done here because we're still in the red
678     ;;; zone). Using ABORT is too dangerous because users may be using
679     ;;; abort restarts which don't do the necessary re-protecting of the
680     ;;; red zone, and would thus render CMUCL unprotected.
681     ;;;
682     #+stack-checking
683     (defun red-zone-hit ()
684     (format *error-output*
685 rtoy 1.46 "~2&~@<Fatal control stack overflow. You have entered~%~
686     the red control stack guard zone while debugging.~%~
687 gerd 1.40 Returning to Top-Level.~@:>~2%")
688     (throw 'lisp::top-level-catcher nil))
689    
690 toy 1.43 #+heap-overflow-check
691     (defun dynamic-space-overflow-warning-hit ()
692     (let ((debug:*stack-top-hint* nil))
693     ;; Don't reserve any more pages
694     (setf lisp::reserved-heap-pages 0)
695     (format *error-output*
696 rtoy 1.46 "~2&~@<Imminent dynamic space overflow has occurred:~%~
697     Only a small amount of dynamic space is available now.~%~
698     Please note that you will be returned to the Top-Level without~%~
699 toy 1.43 warning if you run out of space while debugging.~@:>~%")
700     (infinite-error-protect (error 'heap-overflow))))
701    
702     #+heap-overflow-check
703     (defun dynamic-space-overflow-error-hit ()
704     (throw 'lisp::top-level-catcher nil))
705 ram 1.20

  ViewVC Help
Powered by ViewVC 1.1.5