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

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.44.6.1.2.1 - (hide annotations)
Fri Jun 16 17:34:58 2006 UTC (7 years, 10 months ago) by rtoy
Branch: double-double-array-branch
Changes since 1.44.6.1: +8 -1 lines
Add support for type errors for simple-array double-double-float.
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.44.6.1.2.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/interr.lisp,v 1.44.6.1.2.1 2006/06/16 17:34:58 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 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     (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 rtoy 1.44.6.1 #+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.44.6.1.2.1 #+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 wlott 1.24 (deferr object-not-complex-error (object)
449 wlott 1.15 (error 'type-error
450     :function-name name
451     :datum object
452     :expected-type 'complex))
453 dtc 1.32
454     (deferr object-not-complex-rational-error (object)
455     (error 'type-error
456     :function-name name
457     :datum object
458     :expected-type '(complex rational)))
459 dtc 1.31
460     (deferr object-not-complex-single-float-error (object)
461     (error 'type-error
462     :function-name name
463     :datum object
464     :expected-type '(complex single-float)))
465    
466     (deferr object-not-complex-double-float-error (object)
467     (error 'type-error
468     :function-name name
469     :datum object
470     :expected-type '(complex double-float)))
471 dtc 1.33
472 dtc 1.34 #+long-float
473 dtc 1.33 (deferr object-not-complex-long-float-error (object)
474     (error 'type-error
475     :function-name name
476     :datum object
477     :expected-type '(complex long-float)))
478 wlott 1.1
479 wlott 1.24 (deferr object-not-weak-pointer-error (object)
480 wlott 1.15 (error 'type-error
481     :function-name name
482     :datum object
483     :expected-type 'weak-pointer))
484 wlott 1.11
485 ram 1.26 (deferr object-not-instance-error (object)
486 wlott 1.15 (error 'type-error
487 wlott 1.11 :function-name name
488 wlott 1.15 :datum object
489 ram 1.26 :expected-type 'instance))
490 wlott 1.15
491 pmai 1.39 #+linkage-table
492     (deferr undefined-foreign-symbol-error (symbol)
493     (error 'simple-program-error
494     :function-name name
495     :format-control "Undefined foreign symbol: ~S"
496     :format-arguments (list symbol)))
497 wlott 1.1
498    
499 ram 1.20 ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of
500     ;;; hyperspace.
501     ;;;
502     (defmacro infinite-error-protect (&rest forms)
503     `(if (and (boundp '*error-system-initialized*)
504     (numberp *current-error-depth*))
505     (let ((*current-error-depth* (1+ *current-error-depth*)))
506     (if (> *current-error-depth* *maximum-error-depth*)
507 ram 1.21 (error-error "Help! " *current-error-depth* " nested errors. "
508 ram 1.20 "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
509     (progn ,@forms)))
510     (%primitive halt)))
511 wlott 1.1
512 ram 1.20 ;;; Track the depth of recursive errors.
513     ;;;
514     (defvar *maximum-error-depth* 10
515     "The maximum number of nested errors allowed. Internal errors are
516     double-counted.")
517     (defvar *current-error-depth* 0 "The current number of nested errors.")
518 wlott 1.6
519 ram 1.20 ;;; These specials are used by ERROR-ERROR to track the success of recovery
520     ;;; attempts.
521     ;;;
522     (defvar *error-error-depth* 0)
523     (defvar *error-throw-up-count* 0)
524    
525     ;;; This protects against errors that happen before we run this top-level form.
526     ;;;
527     (defvar *error-system-initialized* t)
528    
529     ;;; ERROR-ERROR can be called when the error system is in trouble and needs
530     ;;; to punt fast. Prints a message without using format. If we get into
531     ;;; this recursively, then halt.
532     ;;;
533     (defun error-error (&rest messages)
534     (let ((*error-error-depth* (1+ *error-error-depth*)))
535     (when (> *error-throw-up-count* 50)
536     (%primitive halt)
537     (throw 'lisp::top-level-catcher nil))
538     (case *error-error-depth*
539     (1)
540     (2
541     (lisp::stream-init))
542     (3
543     (incf *error-throw-up-count*)
544     (throw 'lisp::top-level-catcher nil))
545     (t
546     (%primitive halt)
547     (throw 'lisp::top-level-catcher nil)))
548    
549     (with-standard-io-syntax
550 ram 1.21 (let ((*print-readably* nil))
551     (dolist (item messages) (princ item *terminal-io*))
552     (debug:internal-debug)))))
553 ram 1.20
554    
555     ;;;; Fetching errorful function name.
556    
557     ;;; Used to prevent infinite recursive lossage when we can't find the caller
558     ;;; for some reason.
559     ;;;
560 ram 1.21 (defvar *finding-name* nil)
561 ram 1.20
562     ;;; FIND-CALLER-NAME -- Internal
563     ;;;
564     (defun find-caller-name ()
565 ram 1.21 (if *finding-name*
566 wlott 1.23 (values "<error finding name>" nil)
567 ram 1.20 (handler-case
568 wlott 1.23 (let* ((*finding-name* t)
569     (frame (di:frame-down (di:frame-down (di:top-frame))))
570     (name (di:debug-function-name
571     (di:frame-debug-function frame))))
572     (di:flush-frames-above frame)
573     (values name frame))
574     (error ()
575     (values "<error finding name>" nil))
576     (di:debug-condition ()
577     (values "<error finding name>" nil)))))
578 ram 1.20
579    
580 wlott 1.6 (defun find-interrupted-name ()
581     (if *finding-name*
582 wlott 1.23 (values "<error finding name>" nil)
583 wlott 1.6 (handler-case
584     (let ((*finding-name* t))
585     (do ((frame (di:top-frame) (di:frame-down frame)))
586 wlott 1.27 ((null frame)
587     (values "<error finding name>" nil))
588     (when (and (di::compiled-frame-p frame)
589     (di::compiled-frame-escaped frame))
590     (di:flush-frames-above frame)
591     (return (values (di:debug-function-name
592     (di:frame-debug-function frame))
593     frame)))))
594 wlott 1.23 (error ()
595     (values "<error finding name>" nil))
596     (di:debug-condition ()
597     (values "<error finding name>" nil)))))
598 wlott 1.6
599 ram 1.20
600     ;;;; internal-error signal handler.
601 wlott 1.6
602 wlott 1.13 (defun internal-error (scp continuable)
603 wlott 1.22 (declare (type system-area-pointer scp) (ignore continuable))
604 ram 1.20 (infinite-error-protect
605 wlott 1.24 (let ((scp (locally
606     (declare (optimize (inhibit-warnings 3)))
607     (alien:sap-alien scp (* unix:sigcontext)))))
608 wlott 1.22 (multiple-value-bind
609     (error-number arguments)
610     (vm:internal-error-arguments scp)
611 wlott 1.23 (multiple-value-bind
612     (name debug:*stack-top-hint*)
613     (find-interrupted-name)
614     (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
615 wlott 1.24 (handler (and (< -1 error-number (length *internal-errors*))
616     (svref *internal-errors* error-number))))
617     (cond ((null handler)
618 wlott 1.23 (error 'simple-error
619     :function-name name
620 ram 1.28 :format-control
621 wlott 1.23 "Unknown internal error, ~D? args=~S"
622     :format-arguments
623     (list error-number
624     (mapcar #'(lambda (sc-offset)
625     (di::sub-access-debug-var-slot
626     fp sc-offset scp))
627     arguments))))
628 wlott 1.24 ((not (functionp handler))
629 wlott 1.23 (error 'simple-error
630     :function-name name
631 ram 1.28 :format-control
632 wlott 1.23 "Internal error ~D: ~A. args=~S"
633     :format-arguments
634     (list error-number
635 wlott 1.24 handler
636 wlott 1.23 (mapcar #'(lambda (sc-offset)
637     (di::sub-access-debug-var-slot
638     fp sc-offset scp))
639     arguments))))
640     (t
641 wlott 1.24 (funcall handler name fp scp arguments)))))))))
642 gerd 1.40
643     ;;;
644     ;;; Called from C when the yellow control stack guard zone is hit.
645     ;;; The yellow zone is unprotected in the C code prior to calling this
646     ;;; function, to give some room for debugging. The red zone is still
647     ;;; protected.
648     ;;;
649     #+stack-checking
650     (defun yellow-zone-hit ()
651     (let ((debug:*stack-top-hint* nil))
652     (format *error-output*
653     "~2&~@<A control stack overflow has occurred: ~
654     the program has entered the yellow control stack guard zone. ~
655     Please note that you will be returned to the Top-Level if you ~
656     enter the red control stack guard zone while debugging.~@:>~2%")
657     (infinite-error-protect (error 'stack-overflow))))
658    
659     ;;;
660     ;;; Called from C when the red control stack guard zone is hit. We
661     ;;; could ABORT here, which would usually take us back to the debugger
662     ;;; or top-level, and add code to the restarts re-protecting the red
663     ;;; zone (which can't be done here because we're still in the red
664     ;;; zone). Using ABORT is too dangerous because users may be using
665     ;;; abort restarts which don't do the necessary re-protecting of the
666     ;;; red zone, and would thus render CMUCL unprotected.
667     ;;;
668     #+stack-checking
669     (defun red-zone-hit ()
670     (format *error-output*
671     "~2&~@<Fatal control stack overflow. You have entered ~
672     the red control stack guard zone while debugging. ~
673     Returning to Top-Level.~@:>~2%")
674     (throw 'lisp::top-level-catcher nil))
675    
676 toy 1.43 #+heap-overflow-check
677     (defun dynamic-space-overflow-warning-hit ()
678     (let ((debug:*stack-top-hint* nil))
679     ;; Don't reserve any more pages
680     (setf lisp::reserved-heap-pages 0)
681     (format *error-output*
682     "~2&~@<Imminent dynamic space overflow has occurred: ~
683     Only a small amount of dynamic space is available now. ~
684     Please note that you will be returned to the Top-Level without ~
685     warning if you run out of space while debugging.~@:>~%")
686     (infinite-error-protect (error 'heap-overflow))))
687    
688     #+heap-overflow-check
689     (defun dynamic-space-overflow-error-hit ()
690     (throw 'lisp::top-level-catcher nil))
691 ram 1.20

  ViewVC Help
Powered by ViewVC 1.1.5