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

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.42 - (hide annotations)
Mon May 26 20:20:32 2003 UTC (10 years, 10 months ago) by gerd
Branch: MAIN
CVS Tags: snapshot-2003-10, dynamic-extent-base, sparc_gencgc_merge, sparc_gencgc, lisp-executable-base
Branch point for: sparc_gencgc_branch, dynamic-extent, lisp-executable
Changes since 1.41: +3 -1 lines
	Fix code signaling type-errors which did not have :datum and/or
	:expected-type, which lead to the conditions which were not
	displayable because the corresponding condition slots are
	not bound.

	* src/code/seq.lisp (coerce):
	* src/code/list.lisp (nreconc):
	* src/code/interr.lisp (invalid-array-index-error):
	* src/code/bignum.lisp (bignum-to-float):
	* src/code/byte-interp.lisp (%byte-car, %byte-cdr): Fix
	type-errors to include :datum and/or :expected-type.

	Add &more handling to the byte-compiler and -interpreter.
	Reported by Paul Werkowski on cmucl-imp.

	* src/compiler/byte-comp.lisp (make-xep-for): Handle &more.

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

  ViewVC Help
Powered by ViewVC 1.1.5