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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.73 - (show annotations)
Fri Oct 24 02:56:59 2003 UTC (10 years, 5 months ago) by toy
Branch: MAIN
CVS Tags: snapshot-2004-05, mod-arith-base, amd64-merge-start, snapshot-2003-11, release-19a-base, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, release-19a, snapshot-2004-04
Branch point for: mod-arith-branch, release-19a-branch
Changes since 1.72: +13 -1 lines
Add support for catching heap overflows, similar to the control stack
overflow checking.  Enable with :heap-overflow-check.  We reserve some
number of pages on the heap.  When the heap reaches the reserved
pages, an overflow warning is signalled.  The reserved pages are set
0.  This allows some additional allocation to happen during debugging,
if necessary.  If another overflow happens, we throw to top-level.

Sparc only right now.

	* lisp/sparc-assem.S (_do_dynamic_space_overflow_error): New
	function to handle a heap overflow error.
	(_do_dynamic_space_overflow_warning): New function to handle heap
	overflow warning.

	* lisp/sparc-arch.c (sigill_handler): Handle the two new traps
	caused by heap overflows.

	* lisp/interrupt.c (interrupt_handle_space_overflow): New function
	to handle interrupt caused by heap space overflows.

	* lisp/gencgc.c (handle_heap_overflow): New function to handle
	heap overflows.
	(gc_alloc_new_region): Use handle_heap_overflow.
	(gc_alloc_large): Use handle_heap_overflow

	* compiler/sparc/parms.lisp (static-symbols): Add new static
	symbols for heap overflow checking:
	dynamic-space-overflow-error-hit and
	dynamic-space-overflow-warning-hit.

	* compiler/generic/new-genesis.lisp (finish-symbols): Initialize
	the new dynamic-space-overflow-error-hit and
	dynamic-space-overflow-warning-hit static symbols.

	* code/lispinit.lisp (:heap-overflow-check): Add
	heap-overflow-check to *runtime-features*, if necessary.
	("reserved_heap_pages"): Access to alien variable for heap
	overflow.
	(*reserved-heap-pages*): Default number of heap pages to reserve
	for heap overflow.
	(%top-level): Set reserved-heap-pages to the default.

	* code/interr.lisp (dynamic-space-overflow-warning-hit): Add
	function to handle heap overflow warnings.
	(dynamic-space-overflow-error-hit): Add function to handle heap
	overflow error.

	* code/error.lisp (heap-overflow): Add new condition type for heap
	overflow
1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/lispinit.lisp,v 1.73 2003/10/24 02:56:59 toy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Initialization stuff for CMU Common Lisp, plus some other random functions
13 ;;; that we don't have any better place for.
14 ;;;
15 ;;; Written by Skef Wholey and Rob MacLachlan.
16 ;;;
17 (in-package :lisp)
18
19 (export '(most-positive-fixnum most-negative-fixnum sleep
20 ++ +++ ** *** // ///))
21
22 (defvar *features* '(:common :common-lisp :ansi-cl :ieee-floating-point :cmu)
23 "Holds a list of symbols that describe features provided by the
24 implementation.")
25
26
27 (in-package :system)
28 (export '(compiler-version scrub-control-stack *runtime-features*))
29
30 (defvar *runtime-features* nil
31 "Features affecting the runtime")
32
33 (in-package :extensions)
34 (export '(quit *prompt*))
35
36 (in-package :lisp)
37
38 #+stack-checking
39 (sys:register-lisp-runtime-feature :stack-checking)
40
41 #+heap-overflow-check
42 (sys:register-lisp-runtime-feature :heap-overflow-check)
43
44 ;;; Make the error system enable interrupts.
45
46 (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum
47 "The fixnum closest in value to positive infinity.")
48
49 (defconstant most-negative-fixnum #.vm:target-most-negative-fixnum
50 "The fixnum closest in value to negative infinity.")
51
52
53 ;;; Random information:
54
55 (defvar *lisp-implementation-version* "4.0(?)")
56
57
58 ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs...
59 (declaim
60 #-gengc
61 (special *gc-inhibit* *already-maybe-gcing*
62 *need-to-collect-garbage* *gc-verbose*
63 *before-gc-hooks* *after-gc-hooks*
64 #+x86 *pseudo-atomic-atomic*
65 #+x86 *pseudo-atomic-interrupted*
66 unix::*interrupts-enabled*
67 unix::*interrupt-pending*
68 *type-system-initialized*)
69 #+gengc
70 (special *gc-verbose* *before-gc-hooks* *after-gc-hooks*
71 *type-system-initialized*))
72
73
74 ;;;; Random magic specials.
75
76
77 ;;; These are filled in by Genesis.
78
79 #-gengc
80 (progn
81
82 (defvar *current-catch-block*)
83 (defvar *current-unwind-protect-block*)
84 (defvar *free-interrupt-context-index*)
85
86 ); #-gengc progn
87
88
89 ;;;; Random stuff that needs to be in the cold load which would otherwise be
90 ;;;; byte-compiled.
91 ;;;;
92 (defvar hi::*in-the-editor* nil)
93
94 ;;;; Called by defmacro expanders...
95
96 ;;; VERIFY-KEYWORDS -- internal
97 ;;;
98 ;;; Determine if key-list is a valid list of keyword/value pairs. Do not
99 ;;; signal the error directly, 'cause we don't know how it should be signaled.
100 ;;;
101
102 (defun verify-keywords (key-list valid-keys allow-other-keys)
103 (do ((already-processed nil)
104 (unknown-keyword nil)
105 (remaining key-list (cddr remaining)))
106 ((null remaining)
107 (if (and unknown-keyword
108 (not allow-other-keys)
109 (not (lookup-keyword :allow-other-keys key-list)))
110 (values :unknown-keyword (list unknown-keyword valid-keys))
111 (values nil nil)))
112 (cond ((not (and (consp remaining) (listp (cdr remaining))))
113 (return (values :dotted-list key-list)))
114 ((null (cdr remaining))
115 (return (values :odd-length key-list)))
116 #+nil ;; Not ANSI compliant to disallow duplicate keywords.
117 ((member (car remaining) already-processed)
118 (return (values :duplicate (car remaining))))
119 ((or (eq (car remaining) :allow-other-keys)
120 (member (car remaining) valid-keys))
121 (push (car remaining) already-processed))
122 (t
123 (setf unknown-keyword (car remaining))))))
124
125 (defun lookup-keyword (keyword key-list)
126 (do ((remaining key-list (cddr remaining)))
127 ((endp remaining))
128 (when (eq keyword (car remaining))
129 (return (cadr remaining)))))
130 ;;;
131 (defun keyword-supplied-p (keyword key-list)
132 (do ((remaining key-list (cddr remaining)))
133 ((endp remaining))
134 (when (eq keyword (car remaining))
135 (return t))))
136
137 (in-package "CONDITIONS")
138
139 (defvar *break-on-signals* nil
140 "When (typep condition *break-on-signals*) is true, then calls to SIGNAL will
141 enter the debugger prior to signalling that condition.")
142
143 (defun signal (datum &rest arguments)
144 "Invokes the signal facility on a condition formed from datum and arguments.
145 If the condition is not handled, nil is returned. If
146 (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked before
147 any signalling is done."
148 (let ((condition (coerce-to-condition datum arguments
149 'simple-condition 'signal))
150 (*handler-clusters* *handler-clusters*))
151 (let ((obos *break-on-signals*)
152 (*break-on-signals* nil))
153 (when (typep condition obos)
154 (break "~A~%Break entered because of *break-on-signals* (now NIL.)"
155 condition)))
156 (loop
157 (unless *handler-clusters* (return))
158 (let ((cluster (pop *handler-clusters*)))
159 (dolist (handler cluster)
160 (when (typep condition (car handler))
161 (funcall (cdr handler) condition)))))
162 nil))
163
164 ;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and
165 ;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a single
166 ;;; argument that's directly usable by all the other routines.
167 ;;;
168 (defun coerce-to-condition (datum arguments default-type function-name)
169 (cond ((typep datum 'condition)
170 (if arguments
171 (cerror "Ignore the additional arguments."
172 'simple-type-error
173 :datum arguments
174 :expected-type 'null
175 :format-control "You may not supply additional arguments ~
176 when giving ~S to ~S."
177 :format-arguments (list datum function-name)))
178 datum)
179 ((symbolp datum) ;Roughly, (subtypep datum 'condition).
180 (apply #'make-condition datum arguments))
181 ((or (stringp datum) (functionp datum))
182 (make-condition default-type
183 :format-control datum
184 :format-arguments arguments))
185 (t
186 (error 'simple-type-error
187 :datum datum
188 :expected-type '(or symbol string)
189 :format-control "Bad argument to ~S: ~S"
190 :format-arguments (list function-name datum)))))
191
192 (defun error (datum &rest arguments)
193 "Invokes the signal facility on a condition formed from datum and arguments.
194 If the condition is not handled, the debugger is invoked."
195 (kernel:infinite-error-protect
196 (let ((condition (coerce-to-condition datum arguments
197 'simple-error 'error))
198 (debug:*stack-top-hint* debug:*stack-top-hint*))
199 (unless (and (condition-function-name condition) debug:*stack-top-hint*)
200 (multiple-value-bind
201 (name frame)
202 (kernel:find-caller-name)
203 (unless (condition-function-name condition)
204 (setf (condition-function-name condition) name))
205 (unless debug:*stack-top-hint*
206 (setf debug:*stack-top-hint* frame))))
207 (let ((debug:*stack-top-hint* nil))
208 (signal condition))
209 (invoke-debugger condition))))
210
211 ;;; CERROR must take care to not use arguments when datum is already a
212 ;;; condition object.
213 ;;;
214 (defun cerror (continue-string datum &rest arguments)
215 (kernel:infinite-error-protect
216 (with-simple-restart
217 (continue "~A" (apply #'format nil continue-string arguments))
218 (let ((condition (if (typep datum 'condition)
219 datum
220 (coerce-to-condition datum arguments
221 'simple-error 'error)))
222 (debug:*stack-top-hint* debug:*stack-top-hint*))
223 (unless (and (condition-function-name condition)
224 debug:*stack-top-hint*)
225 (multiple-value-bind
226 (name frame)
227 (kernel:find-caller-name)
228 (unless (condition-function-name condition)
229 (setf (condition-function-name condition) name))
230 (unless debug:*stack-top-hint*
231 (setf debug:*stack-top-hint* frame))))
232 (with-condition-restarts condition (list (find-restart 'continue))
233 (let ((debug:*stack-top-hint* nil))
234 (signal condition))
235 (invoke-debugger condition)))))
236 nil)
237
238 (defun break (&optional (datum "Break") &rest arguments)
239 "Prints a message and invokes the debugger without allowing any possibility
240 of condition handling occurring."
241 (kernel:infinite-error-protect
242 (with-simple-restart (continue "Return from BREAK.")
243 (let ((debug:*stack-top-hint*
244 (or debug:*stack-top-hint*
245 (nth-value 1 (kernel:find-caller-name)))))
246 (invoke-debugger
247 (coerce-to-condition datum arguments 'simple-condition 'break)))))
248 nil)
249
250 (defun warn (datum &rest arguments)
251 "Warns about a situation by signalling a condition formed by datum and
252 arguments. While the condition is being signaled, a muffle-warning restart
253 exists that causes WARN to immediately return nil."
254 (kernel:infinite-error-protect
255 (let ((condition (coerce-to-condition datum arguments
256 'simple-warning 'warn)))
257 (check-type condition warning "a warning condition")
258 (restart-case (signal condition)
259 (muffle-warning ()
260 :report "Skip warning."
261 (return-from warn nil)))
262 (format *error-output* "~&~@<Warning: ~3i~:_~A~:>~%" condition)))
263 nil)
264
265 ;;; Utility functions
266
267 (defun simple-program-error (datum &rest arguments)
268 "Invokes the signal facility on a condition formed from datum and arguments.
269 If the condition is not handled, the debugger is invoked. This function
270 is just like error, except that the condition type defaults to the type
271 simple-program-error, instead of program-error."
272 (kernel:infinite-error-protect
273 (let ((condition (coerce-to-condition datum arguments
274 'simple-program-error
275 'simple-program-error))
276 (debug:*stack-top-hint* debug:*stack-top-hint*))
277 (unless (and (condition-function-name condition) debug:*stack-top-hint*)
278 (multiple-value-bind
279 (name frame)
280 (kernel:find-caller-name)
281 (unless (condition-function-name condition)
282 (setf (condition-function-name condition) name))
283 (unless debug:*stack-top-hint*
284 (setf debug:*stack-top-hint* frame))))
285 (let ((debug:*stack-top-hint* nil))
286 (signal condition))
287 (invoke-debugger condition))))
288
289 (in-package "LISP")
290
291
292 ;;; %Initial-Function is called when a cold system starts up. First we zoom
293 ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
294 ;;; at "load time." Then we initialize the various subsystems and call the
295 ;;; read-eval-print loop. The top-level Read-Eval-Print loop is executed until
296 ;;; someone (most likely the Quit function) throws to the tag
297 ;;; %End-Of-The-World. We quit this way so that all outstanding cleanup forms
298 ;;; in Unwind-Protects will get executed.
299
300 (declaim (special *lisp-initialization-functions*
301 *load-time-values*))
302
303 (eval-when (compile)
304 (defmacro print-and-call (name)
305 `(progn
306 (%primitive print ,(symbol-name name))
307 (,name))))
308 #+nil
309 (defun hexstr(thing)
310 (let ((addr (kernel:get-lisp-obj-address thing))
311 (str (make-string 10)))
312 (setf (char str 0) #\0
313 (char str 1) #\x)
314 (dotimes (i 8)
315 (let* ((nib (ldb (byte 4 0) addr))
316 (chr (char "0123456789abcdef" nib)))
317 (declare (type (unsigned-byte 4) nib)
318 (base-char chr))
319 (setf (char str (- 9 i)) chr
320 addr (ash addr -4))))
321 str))
322
323 (defun %initial-function ()
324 "Gives the world a shove and hopes it spins."
325 (%primitive print "In initial-function, and running.")
326 #-gengc (setf *already-maybe-gcing* t)
327 #-gengc (setf *gc-inhibit* t)
328 #-gengc (setf *need-to-collect-garbage* nil)
329 (setf *gc-verbose* #-gengc t #+gengc nil)
330 (setf *before-gc-hooks* nil)
331 (setf *after-gc-hooks* nil)
332 #-gengc (setf unix::*interrupts-enabled* t)
333 #-gengc (setf unix::*interrupt-pending* nil)
334 (setf *type-system-initialized* nil)
335 (setf *break-on-signals* nil)
336 #+gengc (setf conditions::*handler-clusters* nil)
337
338 ;; Many top-level forms call INFO, (SETF INFO).
339 (print-and-call c::globaldb-init)
340
341 ;; Set up the fdefn database.
342 (print-and-call fdefn-init)
343
344 ;; Some of the random top-level forms call Make-Array, which calls Subtypep
345 (print-and-call typedef-init)
346 (print-and-call class-init)
347 (print-and-call type-init)
348
349 (let ((funs (nreverse *lisp-initialization-functions*)))
350 (%primitive print "Calling top-level forms.")
351 (dolist (fun funs) #+nil (%primitive print (hexstr fun))
352 (typecase fun
353 (function
354 (funcall fun))
355 (cons
356 (case (car fun)
357 (:load-time-value
358 (setf (svref *load-time-values* (third fun))
359 (funcall (second fun))))
360 (:load-time-value-fixup
361 #-gengc
362 (setf (sap-ref-32 (second fun) 0)
363 (get-lisp-obj-address
364 (svref *load-time-values* (third fun))))
365 #+gengc
366 (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))
367 #+(and x86 gencgc)
368 (:load-time-code-fixup
369 (vm::do-load-time-code-fixup (second fun) (third fun) (fourth fun)
370 (fifth fun)))
371 (t
372 (%primitive print
373 "Bogus fixup in *lisp-initialization-functions*")
374 (%halt))))
375 (t
376 (%primitive print
377 "Bogus function in *lisp-initialization-functions*")
378 (%halt)))))
379 (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
380 (makunbound '*load-time-values*)
381
382 ;; Only do this after top level forms have run, 'cause thats where
383 ;; deftypes are.
384 (setf *type-system-initialized* t)
385
386 (print-and-call os-init)
387 (print-and-call filesys-init)
388
389 (print-and-call reader-init)
390 ;; Note: sharpm and backq not yet loaded, so this is not the final RT.
391 (setf *readtable* (copy-readtable std-lisp-readtable))
392
393 (print-and-call stream-init)
394 (print-and-call loader-init)
395 (print-and-call package-init)
396 (print-and-call kernel::signal-init)
397 (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
398
399 (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero))
400 ;; This is necessary because some of the initial top level forms might
401 ;; have changed the compliation policy in strange ways.
402 (print-and-call c::proclaim-init)
403
404 (print-and-call kernel::class-finalize)
405
406 (%primitive print "Done initializing.")
407
408 #-gengc (setf *already-maybe-gcing* nil)
409 #+gengc (setf *gc-verbose* t)
410 (terpri)
411 (princ "CMU Common Lisp kernel core image ")
412 (princ (lisp-implementation-version))
413 (princ ".")
414 (terpri)
415 (princ "[You are in the LISP package.]")
416 (terpri)
417 (let ((wot
418 (catch '%end-of-the-world
419 (loop
420 (%top-level)
421 (write-line "You're certainly a clever child.")))))
422 (unix:unix-exit wot)))
423
424 #+gengc
425 (defun do-load-time-value-fixup (object offset index)
426 (declare (type index offset))
427 (macrolet ((lose (msg)
428 `(progn
429 (%primitive print ,msg)
430 (%halt))))
431 (let ((value (svref *load-time-values* index)))
432 (typecase object
433 (list
434 (case offset
435 (0 (setf (car object) value))
436 (1 (setf (cdr object) value))
437 (t (lose "Bogus offset in cons cell."))))
438 (instance
439 (setf (%instance-ref object (- offset vm:instance-slots-offset))
440 value))
441 (code-component
442 (setf (code-header-ref object offset) value))
443 (simple-vector
444 (setf (svref object (- offset vm:vector-data-offset)) value))
445 (t
446 (lose "Unknown kind of object for load-time-value fixup."))))))
447
448
449 ;;;; Initialization functions:
450
451 ;;; Print seems to not like x86 NPX denormal floats like
452 ;;; least-negative-single-float, so the :underflow exceptions
453 ;;; is disabled by default. Joe User can explicitly enable them
454 ;;; if desired.
455
456 (defun reinit ()
457 (without-interrupts
458 (without-gcing
459 (os-init)
460 (stream-reinit)
461 (kernel::signal-init)
462 (gc-init)
463 (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
464 (set-floating-point-modes :traps
465 '(:overflow :invalid :divide-by-zero))
466 ;; Clear pseudo atomic in case this core wasn't compiled with support.
467 #+x86 (setf lisp::*pseudo-atomic-atomic* 0))))
468
469
470 ;;;; Miscellaneous external functions:
471
472 (defvar *cleanup-functions* nil
473 "Functions to be invoked during cleanup at Lisp exit.")
474
475 ;;; Quit gets us out, one way or another.
476
477 (defun quit (&optional recklessly-p)
478 "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
479 non-Nil."
480 (if recklessly-p
481 (unix:unix-exit 0)
482 (progn
483 (mapc (lambda (fn) (ignore-errors (funcall fn))) *cleanup-functions*)
484 (throw '%end-of-the-world 0))))
485
486
487 #-mp ; Multi-processing version defined in multi-proc.lisp.
488 (defun sleep (n)
489 "This function causes execution to be suspended for N seconds. N may
490 be any non-negative, non-complex number."
491 (when (or (not (realp n))
492 (minusp n))
493 (error 'simple-type-error
494 :format-control
495 "Invalid argument to SLEEP: ~S.~%~
496 Must be a non-negative, non-complex number."
497 :format-arguments (list n)
498 :datum n
499 :expected-type '(real 0)))
500 (multiple-value-bind (sec usec)
501 (if (integerp n)
502 (values n 0)
503 (multiple-value-bind (sec frac) (truncate n)
504 (values sec (truncate frac 1e-6))))
505 (unix:unix-select 0 0 0 0 sec usec))
506 nil)
507
508 ;;;; SCRUB-CONTROL-STACK
509
510 #+stack-checking
511 (alien:def-alien-routine "os_guard_control_stack" c-call:void
512 (zone c-call:int)
513 (guardp c-call:int))
514
515
516 (defconstant bytes-per-scrub-unit 2048)
517
518 ;;; Scrub-control-stack.
519 ;;;
520 #-x86
521 (defun %scrub-control-stack ()
522 "Zero the unused portion of the control stack so that old objects are not
523 kept alive because of uninitialized stack variables."
524 (declare (optimize (speed 3) (safety 0))
525 (values (unsigned-byte 20)))
526 (labels
527 ((scrub (ptr offset count)
528 (declare (type system-area-pointer ptr)
529 (type (unsigned-byte 16) offset)
530 (type (unsigned-byte 20) count)
531 (values (unsigned-byte 20)))
532 (cond ((= offset bytes-per-scrub-unit)
533 (look (sap+ ptr bytes-per-scrub-unit) 0 count))
534 (t
535 (setf (sap-ref-32 ptr offset) 0)
536 (scrub ptr (+ offset vm:word-bytes) count))))
537 (look (ptr offset count)
538 (declare (type system-area-pointer ptr)
539 (type (unsigned-byte 16) offset)
540 (type (unsigned-byte 20) count)
541 (values (unsigned-byte 20)))
542 (cond ((= offset bytes-per-scrub-unit)
543 count)
544 ((zerop (sap-ref-32 ptr offset))
545 (look ptr (+ offset vm:word-bytes) count))
546 (t
547 (scrub ptr offset (+ count vm:word-bytes))))))
548 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
549 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
550 (declare (type (unsigned-byte 32) csp))
551 (scrub (int-sap (- csp initial-offset))
552 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
553 0))))
554
555 ;;; Scrub-control-stack.
556 ;;;
557 ;;; On the x86 port the stack grows downwards, and to support grow on
558 ;;; demand stacks the stack must be decreased as it is scrubbed.
559 ;;;
560 (defun scrub-control-stack ()
561 "Zero the unused portion of the control stack so that old objects are not
562 kept alive because of uninitialized stack variables."
563 ;;
564 ;; The guard zone of the control stack is used by Lisp sometimes,
565 ;; so I think it should be zero'd out, too.
566 #+stack-checking (os-guard-control-stack 0 0)
567 (%scrub-control-stack)
568 #+stack-checking (os-guard-control-stack 0 1))
569
570 #+x86
571 (defun %scrub-control-stack ()
572 (%scrub-control-stack))
573
574
575 ;;;; TOP-LEVEL loop.
576
577 (defvar / nil
578 "Holds a list of all the values returned by the most recent top-level EVAL.")
579 (defvar // nil "Gets the previous value of / when a new value is computed.")
580 (defvar /// nil "Gets the previous value of // when a new value is computed.")
581 (defvar * nil "Holds the value of the most recent top-level EVAL.")
582 (defvar ** nil "Gets the previous value of * when a new value is computed.")
583 (defvar *** nil "Gets the previous value of ** when a new value is computed.")
584 (defvar + nil "Holds the value of the most recent top-level READ.")
585 (defvar ++ nil "Gets the previous value of + when a new value is read.")
586 (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
587 (defvar - nil "Holds the form curently being evaluated.")
588 (defvar *prompt* "* "
589 "The top-level prompt string. This also may be a function of no arguments
590 that returns a simple-string.")
591 (defvar *in-top-level-catcher* nil
592 "True if we are within the Top-Level-Catcher. This is used by interrupt
593 handlers to see whether it is o.k. to throw.")
594
595 (defun interactive-eval (form)
596 "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
597 +, ///, //, /, and -."
598 (when (and (fboundp 'commandp) (funcall 'commandp form))
599 (return-from interactive-eval (funcall 'invoke-command-interactive form)))
600 (setf - form)
601 (let ((results (multiple-value-list (eval form))))
602 (finish-standard-output-streams)
603 (setf /// //
604 // /
605 / results
606 *** **
607 ** *
608 * (car results)))
609 (setf +++ ++
610 ++ +
611 + -)
612 (unless (boundp '*)
613 ;; The bogon returned an unbound marker.
614 (setf * nil)
615 (cerror "Go on with * set to NIL."
616 "EVAL returned an unbound marker."))
617 (values-list /))
618
619
620 (defconstant eofs-before-quit 10)
621
622 (defparameter *reserved-heap-pages* 256
623 "How many pages to reserve from the total heap space so we can handle
624 heap overflow.")
625
626 #+heap-overflow-check
627 (alien:def-alien-variable "reserved_heap_pages" c-call:unsigned-long)
628
629 (defun %top-level ()
630 "Top-level READ-EVAL-PRINT loop. Do not call this."
631 (let ((* nil) (** nil) (*** nil)
632 (- nil) (+ nil) (++ nil) (+++ nil)
633 (/// nil) (// nil) (/ nil)
634 (magic-eof-cookie (cons :eof nil))
635 (number-of-eofs 0))
636 (loop
637 (with-simple-restart (abort "Return to Top-Level.")
638 (catch 'top-level-catcher
639 (unix:unix-sigsetmask 0)
640 (let ((*in-top-level-catcher* t))
641 (loop
642 (scrub-control-stack)
643 (fresh-line)
644 ;; Reset reserved pages in the heap
645 #+heap-overflow-check (setf reserved-heap-pages *reserved-heap-pages*)
646 (princ (if (functionp *prompt*)
647 (funcall *prompt*)
648 *prompt*))
649 (force-output)
650 (let ((form (read *standard-input* nil magic-eof-cookie)))
651 (cond ((not (eq form magic-eof-cookie))
652 (let ((results
653 (multiple-value-list (interactive-eval form))))
654 (dolist (result results)
655 (fresh-line)
656 (prin1 result)))
657 (setf number-of-eofs 0))
658 ((eql (incf number-of-eofs) 1)
659 (if *batch-mode*
660 (quit)
661 (let ((stream (make-synonym-stream '*terminal-io*)))
662 (setf *standard-input* stream)
663 (setf *standard-output* stream)
664 (format t "~&Received EOF on *standard-input*, ~
665 switching to *terminal-io*.~%"))))
666 ((> number-of-eofs eofs-before-quit)
667 (format t "~&Received more than ~D EOFs; Aborting.~%"
668 eofs-before-quit)
669 (quit))
670 (t
671 (format t "~&Received EOF.~%")))))))))))
672
673
674 ;;; %Halt -- Interface
675 ;;;
676 ;;; A convenient way to get into the assembly level debugger.
677 ;;;
678 (defun %halt ()
679 (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5