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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5