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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.68 - (show annotations)
Sun Mar 23 21:23:42 2003 UTC (11 years, 1 month ago) by gerd
Branch: MAIN
CVS Tags: remove_negative_zero_not_zero
Changes since 1.67: +16 -2 lines
	Optional control stack checking.  This is controlled by the
	feature :stack-checking because it's not implemented for other
	systems/architectures yet.  It is currently known to work on
	FreeBSD 4.8-RC/x86 and Debian 2.2.20/x86.

	* bootfiles/18e/boot3.lisp: New boot file, well, only a
	description of the boot procedure since no boot file is needed.

	* lisp/x86-validate.h (SIGNAL_STACK_START, SIGNAL_STACK_SIZE)
	[__FreeBSD__, __linux__]: New defines.
	(CONTROL_STACK_SIZE) {__FreeBSD__, __linux__]:
	Adjust for signal stack.

	* lisp/validate.c (validate) [RED_ZONE_HIT]: Call
	os_guard_control_stack.  Some cleanup.

	* lisp/os.h (BOTH_ZONES, YELLOW_ZONE, RED_ZONE): New enums.
	Add function prototypes.

	* lisp/interrupt.c (interrupt_install_low_level_handler)
	[RED_ZONE_HIT]: Deliver protection violations on a dedicated
	signal stack.

	* lisp/os-common.c (os_stack_grows_down_1, os_stack_grows_down):
	New functions.
	(guard_zones, control_stack_zone, os_guard_control_stack)
	(os_control_stack_overflow) [RED_ZONE_HIT]: New functions.
	(os_control_stack_overflow) [!RED_ZONE_HIT]: Dummy function.

	* lisp/Linux-os.c (sigsegv_handler) [RED_ZONE_HIT]: Handle control
	stack overflows.

	* lisp/FreeBSD-os.c: General cleansing.
	(sigbus_handler) [RED_ZONE_HIT]: Handle control stack overflows.

	* lisp/FreeBSD-os.h (PROTECTION_VIOLATION_SIGNAL): New define.

	* lisp/Linux-os.h (PROTECTION_VIOLATION_SIGNAL): New define.

	* compiler/x86/system.lisp (lisp::%scrub-control-stack): Change
	defknown from sys:scrub-control-stack.
	(%scrub-control-stack): Rename VOP.

	* code/lispinit.lisp (os-guard-control-stack) [#+stack-checking]:
	Define alien os_guard_control_stack.
	(%scrub-control-stack) [#+x86]: New function.
	(scrub-control-stack) [#+x86]: Call %scrub-control-stack,
	call os-guard-control-stack if #+stack-checking.

	* code/interr.lisp (yellow-zone-hit,
	red-zone-hit) [#+stack-checking]: New functions.

	* code/error.lisp (stack-overflow) [#+stack-checking]: New
	condition.

	* compiler/generic/new-genesis.lisp (finish-symbols)
	[#+stack-checking]: Add symbols for control stack checking.

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

  ViewVC Help
Powered by ViewVC 1.1.5