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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.75 - (show annotations)
Tue Oct 19 20:13:30 2004 UTC (9 years, 6 months ago) by cwang
Branch: MAIN
CVS Tags: release-19b-pre1, release-19b-pre2, double-double-base, ppc_gencgc_snap_2006-01-06, release-19c, release-19c-base, snapshot-2004-12, snapshot-2004-11, ppc_gencgc_snap_2005-12-17, snapshot-2005-07, snapshot-2005-03, release-19b-base, snapshot-2005-11, snapshot-2005-10, snapshot-2005-12, snapshot-2005-01, release-19c-pre1, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, snapshot-2005-09, snapshot-2005-08, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-04, snapshot-2006-05
Branch point for: release-19b-branch, ppc_gencgc_branch, double-double-branch, release-19c-branch
Changes since 1.74: +2 -2 lines
set lisp::*pseudo-atomic-atomic* to 0
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.75 2004/10/19 20:13:30 cwang 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 (#+amd64 sap-ref-64
363 #-amd64 sap-ref-32 (second fun) 0)
364 (get-lisp-obj-address
365 (svref *load-time-values* (third fun))))
366 #+gengc
367 (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))
368 #+(and (or x86 amd64) gencgc)
369 (:load-time-code-fixup
370 (vm::do-load-time-code-fixup (second fun) (third fun) (fourth fun)
371 (fifth fun)))
372 (t
373 (%primitive print
374 "Bogus fixup in *lisp-initialization-functions*")
375 (%halt))))
376 (t
377 (%primitive print
378 "Bogus function in *lisp-initialization-functions*")
379 (%halt)))))
380 (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
381 (makunbound '*load-time-values*)
382
383 ;; Only do this after top level forms have run, 'cause thats where
384 ;; deftypes are.
385 (setf *type-system-initialized* t)
386
387 (print-and-call os-init)
388 (print-and-call filesys-init)
389
390 (print-and-call reader-init)
391 ;; Note: sharpm and backq not yet loaded, so this is not the final RT.
392 (setf *readtable* (copy-readtable std-lisp-readtable))
393
394 (print-and-call stream-init)
395 (print-and-call loader-init)
396 (print-and-call package-init)
397 (print-and-call kernel::signal-init)
398 (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
399
400 (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero))
401 ;; This is necessary because some of the initial top level forms might
402 ;; have changed the compilation policy in strange ways.
403 (print-and-call c::proclaim-init)
404
405 (print-and-call kernel::class-finalize)
406
407 (%primitive print "Done initializing.")
408
409 #-gengc (setf *already-maybe-gcing* nil)
410 #+gengc (setf *gc-verbose* t)
411 (terpri)
412 (princ "CMU Common Lisp kernel core image ")
413 (princ (lisp-implementation-version))
414 (princ ".")
415 (terpri)
416 (princ "[You are in the LISP package.]")
417 (terpri)
418 (let ((wot
419 (catch '%end-of-the-world
420 (loop
421 (%top-level)
422 (write-line "You're certainly a clever child.")))))
423 (unix:unix-exit wot)))
424
425 #+gengc
426 (defun do-load-time-value-fixup (object offset index)
427 (declare (type index offset))
428 (macrolet ((lose (msg)
429 `(progn
430 (%primitive print ,msg)
431 (%halt))))
432 (let ((value (svref *load-time-values* index)))
433 (typecase object
434 (list
435 (case offset
436 (0 (setf (car object) value))
437 (1 (setf (cdr object) value))
438 (t (lose "Bogus offset in cons cell."))))
439 (instance
440 (setf (%instance-ref object (- offset vm:instance-slots-offset))
441 value))
442 (code-component
443 (setf (code-header-ref object offset) value))
444 (simple-vector
445 (setf (svref object (- offset vm:vector-data-offset)) value))
446 (t
447 (lose "Unknown kind of object for load-time-value fixup."))))))
448
449
450 ;;;; Initialization functions:
451
452 ;;; Print seems to not like x86 NPX denormal floats like
453 ;;; least-negative-single-float, so the :underflow exceptions
454 ;;; is disabled by default. Joe User can explicitly enable them
455 ;;; if desired.
456
457 (defun reinit ()
458 (without-interrupts
459 (without-gcing
460 (os-init)
461 (stream-reinit)
462 (kernel::signal-init)
463 (gc-init)
464 (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
465 (set-floating-point-modes :traps
466 '(:overflow :invalid :divide-by-zero))
467 ;; Clear pseudo atomic in case this core wasn't compiled with support.
468 #+(or x86 amd64) (setf lisp::*pseudo-atomic-atomic* 0))))
469
470
471 ;;;; Miscellaneous external functions:
472
473 (defvar *cleanup-functions* nil
474 "Functions to be invoked during cleanup at Lisp exit.")
475
476 ;;; Quit gets us out, one way or another.
477
478 (defun quit (&optional recklessly-p)
479 "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
480 non-Nil."
481 (if recklessly-p
482 (unix:unix-exit 0)
483 (progn
484 (mapc (lambda (fn) (ignore-errors (funcall fn))) *cleanup-functions*)
485 (throw '%end-of-the-world 0))))
486
487
488 #-mp ; Multi-processing version defined in multi-proc.lisp.
489 (defun sleep (n)
490 "This function causes execution to be suspended for N seconds. N may
491 be any non-negative, non-complex number."
492 (when (or (not (realp n))
493 (minusp n))
494 (error 'simple-type-error
495 :format-control
496 "Invalid argument to SLEEP: ~S.~%~
497 Must be a non-negative, non-complex number."
498 :format-arguments (list n)
499 :datum n
500 :expected-type '(real 0)))
501 (multiple-value-bind (sec usec)
502 (if (integerp n)
503 (values n 0)
504 (multiple-value-bind (sec frac) (truncate n)
505 (values sec (truncate frac 1e-6))))
506 (unix:unix-select 0 0 0 0 sec usec))
507 nil)
508
509 ;;;; SCRUB-CONTROL-STACK
510
511 #+stack-checking
512 (alien:def-alien-routine "os_guard_control_stack" c-call:void
513 (zone c-call:int)
514 (guardp c-call:int))
515
516
517 (defconstant bytes-per-scrub-unit 2048)
518
519 ;;; Scrub-control-stack.
520 ;;;
521 #-(or x86 amd64)
522 (defun %scrub-control-stack ()
523 "Zero the unused portion of the control stack so that old objects are not
524 kept alive because of uninitialized stack variables."
525 (declare (optimize (speed 3) (safety 0))
526 (values (unsigned-byte 20)))
527 (labels
528 ((scrub (ptr offset count)
529 (declare (type system-area-pointer ptr)
530 (type (unsigned-byte 16) offset)
531 (type (unsigned-byte 20) count)
532 (values (unsigned-byte 20)))
533 (cond ((= offset bytes-per-scrub-unit)
534 (look (sap+ ptr bytes-per-scrub-unit) 0 count))
535 (t
536 (setf (sap-ref-32 ptr offset) 0)
537 (scrub ptr (+ offset vm:word-bytes) count))))
538 (look (ptr offset count)
539 (declare (type system-area-pointer ptr)
540 (type (unsigned-byte 16) offset)
541 (type (unsigned-byte 20) count)
542 (values (unsigned-byte 20)))
543 (cond ((= offset bytes-per-scrub-unit)
544 count)
545 ((zerop (sap-ref-32 ptr offset))
546 (look ptr (+ offset vm:word-bytes) count))
547 (t
548 (scrub ptr offset (+ count vm:word-bytes))))))
549 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
550 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
551 (declare (type (unsigned-byte 32) csp))
552 (scrub (int-sap (- csp initial-offset))
553 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
554 0))))
555
556 ;;; Scrub-control-stack.
557 ;;;
558 ;;; On the x86 and amd64 port the stack grows downwards, and to support grow on
559 ;;; demand stacks the stack must be decreased as it is scrubbed.
560 ;;;
561 (defun scrub-control-stack ()
562 "Zero the unused portion of the control stack so that old objects are not
563 kept alive because of uninitialized stack variables."
564 ;;
565 ;; The guard zone of the control stack is used by Lisp sometimes,
566 ;; so I think it should be zero'd out, too.
567 #+stack-checking (os-guard-control-stack 0 0)
568 (%scrub-control-stack)
569 #+stack-checking (os-guard-control-stack 0 1))
570
571 #+(or x86 amd64)
572 (defun %scrub-control-stack ()
573 (%scrub-control-stack))
574
575
576 ;;;; TOP-LEVEL loop.
577
578 (defvar / nil
579 "Holds a list of all the values returned by the most recent top-level EVAL.")
580 (defvar // nil "Gets the previous value of / when a new value is computed.")
581 (defvar /// nil "Gets the previous value of // when a new value is computed.")
582 (defvar * nil "Holds the value of the most recent top-level EVAL.")
583 (defvar ** nil "Gets the previous value of * when a new value is computed.")
584 (defvar *** nil "Gets the previous value of ** when a new value is computed.")
585 (defvar + nil "Holds the value of the most recent top-level READ.")
586 (defvar ++ nil "Gets the previous value of + when a new value is read.")
587 (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
588 (defvar - nil "Holds the form curently being evaluated.")
589 (defvar *prompt* "* "
590 "The top-level prompt string. This also may be a function of no arguments
591 that returns a simple-string.")
592 (defvar *in-top-level-catcher* nil
593 "True if we are within the Top-Level-Catcher. This is used by interrupt
594 handlers to see whether it is o.k. to throw.")
595
596 (defun interactive-eval (form)
597 "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
598 +, ///, //, /, and -."
599 (when (and (fboundp 'commandp) (funcall 'commandp form))
600 (return-from interactive-eval (funcall 'invoke-command-interactive form)))
601 (setf - form)
602 (let ((results (multiple-value-list (eval form))))
603 (finish-standard-output-streams)
604 (setf /// //
605 // /
606 / results
607 *** **
608 ** *
609 * (car results)))
610 (setf +++ ++
611 ++ +
612 + -)
613 (unless (boundp '*)
614 ;; The bogon returned an unbound marker.
615 (setf * nil)
616 (cerror "Go on with * set to NIL."
617 "EVAL returned an unbound marker."))
618 (values-list /))
619
620
621 (defconstant eofs-before-quit 10)
622
623 (defparameter *reserved-heap-pages* 256
624 "How many pages to reserve from the total heap space so we can handle
625 heap overflow.")
626
627 #+heap-overflow-check
628 (alien:def-alien-variable "reserved_heap_pages" c-call:unsigned-long)
629
630 (defun %top-level ()
631 "Top-level READ-EVAL-PRINT loop. Do not call this."
632 (let ((* nil) (** nil) (*** nil)
633 (- nil) (+ nil) (++ nil) (+++ nil)
634 (/// nil) (// nil) (/ nil)
635 (magic-eof-cookie (cons :eof nil))
636 (number-of-eofs 0))
637 (loop
638 (with-simple-restart (abort "Return to Top-Level.")
639 (catch 'top-level-catcher
640 (unix:unix-sigsetmask 0)
641 (let ((*in-top-level-catcher* t))
642 (loop
643 (scrub-control-stack)
644 (fresh-line)
645 ;; Reset reserved pages in the heap
646 #+heap-overflow-check (setf reserved-heap-pages *reserved-heap-pages*)
647 (princ (if (functionp *prompt*)
648 (funcall *prompt*)
649 *prompt*))
650 (force-output)
651 (let ((form (read *standard-input* nil magic-eof-cookie)))
652 (cond ((not (eq form magic-eof-cookie))
653 (let ((results
654 (multiple-value-list (interactive-eval form))))
655 (dolist (result results)
656 (fresh-line)
657 (prin1 result)))
658 (setf number-of-eofs 0))
659 ((eql (incf number-of-eofs) 1)
660 (if *batch-mode*
661 (quit)
662 (let ((stream (make-synonym-stream '*terminal-io*)))
663 (setf *standard-input* stream)
664 (setf *standard-output* stream)
665 (format t "~&Received EOF on *standard-input*, ~
666 switching to *terminal-io*.~%"))))
667 ((> number-of-eofs eofs-before-quit)
668 (format t "~&Received more than ~D EOFs; Aborting.~%"
669 eofs-before-quit)
670 (quit))
671 (t
672 (format t "~&Received EOF.~%")))))))))))
673
674
675 ;;; %Halt -- Interface
676 ;;;
677 ;;; A convenient way to get into the assembly level debugger.
678 ;;;
679 (defun %halt ()
680 (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5