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

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5