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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.56 - (hide annotations)
Fri Apr 10 11:42:42 1998 UTC (16 years ago) by pw
Branch: MAIN
Changes since 1.55: +3 -3 lines
Export type boolean from common-lisp package.
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 pw 1.56 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/lispinit.lisp,v 1.56 1998/04/10 11:42:42 pw 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     ;; Clear pseudo atomic in case it this core wasn't compiled with
429     ;; support.
430     #+x86 (setf lisp::*pseudo-atomic-atomic* 0))))
431 ram 1.1
432    
433    
434     ;;;; Miscellaneous external functions:
435    
436     ;;; Quit gets us out, one way or another.
437    
438     (defun quit (&optional recklessly-p)
439     "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
440     non-Nil."
441     (if recklessly-p
442 wlott 1.28 (unix:unix-exit 0)
443 ram 1.48 (throw '%end-of-the-world 0)))
444 ram 1.1
445    
446 dtc 1.54 #-mp ; Multi-processing version defined in multi-proc.lisp.
447 ram 1.1 (defun sleep (n)
448     "This function causes execution to be suspended for N seconds. N may
449     be any non-negative, non-complex number."
450 wlott 1.13 (when (or (not (realp n))
451     (minusp n))
452     (error "Invalid argument to SLEEP: ~S.~%~
453     Must be a non-negative, non-complex number."
454     n))
455     (multiple-value-bind (sec usec)
456     (if (integerp n)
457     (values n 0)
458     (values (truncate n)
459     (truncate (* n 1000000))))
460 wlott 1.28 (unix:unix-select 0 0 0 0 sec usec))
461 ram 1.1 nil)
462    
463    
464 wlott 1.25 ;;;; SCRUB-CONTROL-STACK
465    
466    
467 wlott 1.30 (defconstant bytes-per-scrub-unit 2048)
468 wlott 1.25
469 ram 1.49 #-x86
470 wlott 1.25 (defun scrub-control-stack ()
471     "Zero the unused portion of the control stack so that old objects are not
472     kept alive because of uninitialized stack variables."
473     (declare (optimize (speed 3) (safety 0))
474     (values (unsigned-byte 20)))
475     (labels
476     ((scrub (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     (look (sap+ ptr bytes-per-scrub-unit) 0 count))
483 wlott 1.25 (t
484     (setf (sap-ref-32 ptr offset) 0)
485 wlott 1.30 (scrub ptr (+ offset vm:word-bytes) count))))
486 wlott 1.25 (look (ptr offset count)
487     (declare (type system-area-pointer ptr)
488     (type (unsigned-byte 16) offset)
489     (type (unsigned-byte 20) count)
490     (values (unsigned-byte 20)))
491 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
492 wlott 1.25 count)
493     ((zerop (sap-ref-32 ptr offset))
494 wlott 1.30 (look ptr (+ offset vm:word-bytes) count))
495 wlott 1.25 (t
496 wlott 1.30 (scrub ptr offset (+ count vm:word-bytes))))))
497 wlott 1.25 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
498 wlott 1.30 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
499 wlott 1.25 (declare (type (unsigned-byte 32) csp))
500     (scrub (int-sap (- csp initial-offset))
501 wlott 1.30 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
502 wlott 1.25 0))))
503 ram 1.49
504     #+x86 ;; Stack grows downwards
505     (defun scrub-control-stack ()
506     "Zero the unused portion of the control stack so that old objects are not
507     kept alive because of uninitialized stack variables."
508     (declare (optimize (speed 3) (safety 0))
509     (values (unsigned-byte 20)))
510     (labels
511     ((scrub (ptr offset count)
512     (declare (type system-area-pointer ptr)
513     (type (unsigned-byte 16) offset)
514     (type (unsigned-byte 20) count)
515     (values (unsigned-byte 20)))
516     (let ((loc (int-sap (- (sap-int ptr) (+ offset vm:word-bytes)))))
517     (cond ((= offset bytes-per-scrub-unit)
518     (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit))
519     0 count))
520     (t ;; need to fix bug in %set-stack-ref
521     (setf (sap-ref-32 loc 0) 0)
522     (scrub ptr (+ offset vm:word-bytes) count)))))
523     (look (ptr offset count)
524     (declare (type system-area-pointer ptr)
525     (type (unsigned-byte 16) offset)
526     (type (unsigned-byte 20) count)
527     (values (unsigned-byte 20)))
528     (let ((loc (int-sap (- (sap-int ptr) offset))))
529     (cond ((= offset bytes-per-scrub-unit)
530     count)
531 dtc 1.51 ((zerop (kernel::get-lisp-obj-address (stack-ref loc 0)))
532     ; ((zerop (stack-ref loc 0))
533 ram 1.49 (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 wlott 1.25
544    
545    
546 ram 1.1 ;;;; TOP-LEVEL loop.
547    
548     (defvar / nil
549     "Holds a list of all the values returned by the most recent top-level EVAL.")
550     (defvar // nil "Gets the previous value of / when a new value is computed.")
551     (defvar /// nil "Gets the previous value of // when a new value is computed.")
552     (defvar * nil "Holds the value of the most recent top-level EVAL.")
553     (defvar ** nil "Gets the previous value of * when a new value is computed.")
554     (defvar *** nil "Gets the previous value of ** when a new value is computed.")
555     (defvar + nil "Holds the value of the most recent top-level READ.")
556     (defvar ++ nil "Gets the previous value of + when a new value is read.")
557     (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
558     (defvar - nil "Holds the form curently being evaluated.")
559 ram 1.3 (defvar *prompt* "* "
560     "The top-level prompt string. This also may be a function of no arguments
561     that returns a simple-string.")
562 ram 1.1 (defvar *in-top-level-catcher* nil
563     "True if we are within the Top-Level-Catcher. This is used by interrupt
564     handlers to see whether it is o.k. to throw.")
565    
566 ram 1.3 (defun interactive-eval (form)
567     "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
568     +, ///, //, /, and -."
569 ram 1.21 (setf - form)
570 ram 1.3 (let ((results (multiple-value-list (eval form))))
571     (setf /// //
572     // /
573     / results
574     *** **
575     ** *
576     * (car results)))
577 ram 1.21 (setf +++ ++
578     ++ +
579     + -)
580 ram 1.3 (unless (boundp '*)
581     ;; The bogon returned an unbound marker.
582     (setf * nil)
583     (cerror "Go on with * set to NIL."
584     "EVAL returned an unbound marker."))
585     (values-list /))
586 ram 1.21
587 ram 1.3
588     (defconstant eofs-before-quit 10)
589    
590 ram 1.1 (defun %top-level ()
591     "Top-level READ-EVAL-PRINT loop. Do not call this."
592 ram 1.3 (let ((* nil) (** nil) (*** nil)
593 ram 1.1 (- nil) (+ nil) (++ nil) (+++ nil)
594 ram 1.3 (/// nil) (// nil) (/ nil)
595     (magic-eof-cookie (cons :eof nil))
596     (number-of-eofs 0))
597 ram 1.1 (loop
598 wlott 1.25 (with-simple-restart (abort "Return to Top-Level.")
599     (catch 'top-level-catcher
600 wlott 1.28 (unix:unix-sigsetmask 0)
601 wlott 1.25 (let ((*in-top-level-catcher* t))
602     (loop
603     (scrub-control-stack)
604     (fresh-line)
605     (princ (if (functionp *prompt*)
606     (funcall *prompt*)
607     *prompt*))
608     (force-output)
609     (let ((form (read *standard-input* nil magic-eof-cookie)))
610     (cond ((not (eq form magic-eof-cookie))
611     (let ((results
612     (multiple-value-list (interactive-eval form))))
613     (dolist (result results)
614     (fresh-line)
615     (prin1 result)))
616     (setf number-of-eofs 0))
617     ((eql (incf number-of-eofs) 1)
618 phg 1.47 (if *batch-mode*
619 ram 1.48 (quit)
620 phg 1.47 (let ((stream (make-synonym-stream '*terminal-io*)))
621     (setf *standard-input* stream)
622     (setf *standard-output* stream)
623     (format t "~&Received EOF on *standard-input*, ~
624     switching to *terminal-io*.~%"))))
625 wlott 1.25 ((> number-of-eofs eofs-before-quit)
626     (format t "~&Received more than ~D EOFs; Aborting.~%"
627     eofs-before-quit)
628     (quit))
629     (t
630     (format t "~&Received EOF.~%")))))))))))
631 ram 1.1
632 phg 1.47 (defun %handled-top-level ()
633     "Wrap %top-level read-eval-print loop in an error handler for *batch-mode*."
634     (handler-case
635     (progn
636     (%top-level)
637 ram 1.48 (quit))
638 phg 1.47 (error (cond)
639 ram 1.48 (format *error-output* "Error in batch processing:~%~A" cond)
640     (throw '%end-of-the-world 1))))
641 ram 1.1
642 ram 1.3
643 ram 1.1 ;;; %Halt -- Interface
644     ;;;
645     ;;; A convenient way to get into the assembly level debugger.
646     ;;;
647     (defun %halt ()
648     (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5