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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5