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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.52 - (hide annotations)
Tue Nov 18 16:55:57 1997 UTC (16 years, 5 months ago) by dtc
Branch: MAIN
Changes since 1.51: +3 -1 lines
Implement a pseudo-atomic macro for the x86 backend.
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.52 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/lispinit.lisp,v 1.52 1997/11/18 16:55:57 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 wlott 1.26 (t
328     (%primitive print
329     "Bogus fixup in *lisp-initialization-functions*")
330     (%halt))))
331     (t
332     (%primitive print
333     "Bogus function in *lisp-initialization-functions*")
334     (%halt)))))
335 ram 1.1 (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
336 wlott 1.26 (makunbound '*load-time-values*)
337 ram 1.1
338 wlott 1.10 ;; Only do this after top level forms have run, 'cause thats where
339     ;; deftypes are.
340 ram 1.34 (setf *type-system-initialized* t)
341 wlott 1.10
342 ram 1.1 (print-and-call os-init)
343     (print-and-call filesys-init)
344    
345     (print-and-call reader-init)
346 ram 1.38 ;; Note: sharpm and backq not yet loaded, so this is not the final RT.
347 wlott 1.12 (setf *readtable* (copy-readtable std-lisp-readtable))
348 ram 1.1
349     (print-and-call stream-init)
350 wlott 1.10 (print-and-call loader-init)
351 ram 1.1 (print-and-call package-init)
352 wlott 1.16 (print-and-call kernel::signal-init)
353 wlott 1.28 (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
354 ram 1.49
355     (set-floating-point-modes :traps '(:overflow #-x86 :underflow :invalid
356 ram 1.17 :divide-by-zero))
357 wlott 1.29 ;; This is necessary because some of the initial top level forms might
358     ;; have changed the compliation policy in strange ways.
359     (print-and-call c::proclaim-init)
360 ram 1.34
361     (print-and-call kernel::class-finalize)
362 ram 1.1
363 wlott 1.10 (%primitive print "Done initializing.")
364    
365 wlott 1.35 #-gengc (setf *already-maybe-gcing* nil)
366     #+gengc (setf *gc-verbose* t)
367 ram 1.1 (terpri)
368     (princ "CMU Common Lisp kernel core image ")
369     (princ (lisp-implementation-version))
370     (princ ".")
371     (terpri)
372     (princ "[You are in the LISP package.]")
373     (terpri)
374 ram 1.48 (let ((wot
375     (catch '%end-of-the-world
376     (loop
377     (%top-level)
378     (write-line "You're certainly a clever child.")))))
379     (unix:unix-exit wot)))
380 wlott 1.36
381     #+gengc
382 wlott 1.42 (defun do-load-time-value-fixup (object offset index)
383 wlott 1.36 (declare (type index offset))
384     (macrolet ((lose (msg)
385     `(progn
386     (%primitive print ,msg)
387     (%halt))))
388 wlott 1.42 (let ((value (svref *load-time-values* index)))
389     (typecase object
390     (list
391     (case offset
392     (0 (setf (car object) value))
393     (1 (setf (cdr object) value))
394     (t (lose "Bogus offset in cons cell."))))
395     (instance
396     (setf (%instance-ref object (- offset vm:instance-slots-offset))
397     value))
398     (code-component
399     (setf (code-header-ref object offset) value))
400     (simple-vector
401     (setf (svref object (- offset vm:vector-data-offset)) value))
402     (t
403     (lose "Unknown kind of object for load-time-value fixup."))))))
404 ram 1.1
405    
406     ;;;; Initialization functions:
407    
408 ram 1.49 ;;; Print seems to not like x86 NPX denormal floats like
409     ;;; least-negative-single-float, so the :underflow exceptions
410     ;;; is disabled by default. Joe User can explicitly enable them
411     ;;; if desired.
412    
413 ram 1.1 (defun reinit ()
414     (without-interrupts
415 wlott 1.33 (without-gcing
416     (os-init)
417     (stream-reinit)
418     (kernel::signal-init)
419     (gc-init)
420     (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
421     (set-floating-point-modes :traps
422 ram 1.49 '(:overflow #-x86 :underflow :invalid
423 wlott 1.33 :divide-by-zero)))))
424 ram 1.1
425    
426    
427     ;;;; Miscellaneous external functions:
428    
429     ;;; Quit gets us out, one way or another.
430    
431     (defun quit (&optional recklessly-p)
432     "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
433     non-Nil."
434     (if recklessly-p
435 wlott 1.28 (unix:unix-exit 0)
436 ram 1.48 (throw '%end-of-the-world 0)))
437 ram 1.1
438    
439     (defun sleep (n)
440     "This function causes execution to be suspended for N seconds. N may
441     be any non-negative, non-complex number."
442 wlott 1.13 (when (or (not (realp n))
443     (minusp n))
444     (error "Invalid argument to SLEEP: ~S.~%~
445     Must be a non-negative, non-complex number."
446     n))
447     (multiple-value-bind (sec usec)
448     (if (integerp n)
449     (values n 0)
450     (values (truncate n)
451     (truncate (* n 1000000))))
452 wlott 1.28 (unix:unix-select 0 0 0 0 sec usec))
453 ram 1.1 nil)
454    
455    
456 wlott 1.25 ;;;; SCRUB-CONTROL-STACK
457    
458    
459 wlott 1.30 (defconstant bytes-per-scrub-unit 2048)
460 wlott 1.25
461 ram 1.49 #-x86
462 wlott 1.25 (defun scrub-control-stack ()
463     "Zero the unused portion of the control stack so that old objects are not
464     kept alive because of uninitialized stack variables."
465     (declare (optimize (speed 3) (safety 0))
466     (values (unsigned-byte 20)))
467     (labels
468     ((scrub (ptr offset count)
469     (declare (type system-area-pointer ptr)
470     (type (unsigned-byte 16) offset)
471     (type (unsigned-byte 20) count)
472     (values (unsigned-byte 20)))
473 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
474     (look (sap+ ptr bytes-per-scrub-unit) 0 count))
475 wlott 1.25 (t
476     (setf (sap-ref-32 ptr offset) 0)
477 wlott 1.30 (scrub ptr (+ offset vm:word-bytes) count))))
478 wlott 1.25 (look (ptr offset count)
479     (declare (type system-area-pointer ptr)
480     (type (unsigned-byte 16) offset)
481     (type (unsigned-byte 20) count)
482     (values (unsigned-byte 20)))
483 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
484 wlott 1.25 count)
485     ((zerop (sap-ref-32 ptr offset))
486 wlott 1.30 (look ptr (+ offset vm:word-bytes) count))
487 wlott 1.25 (t
488 wlott 1.30 (scrub ptr offset (+ count vm:word-bytes))))))
489 wlott 1.25 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
490 wlott 1.30 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
491 wlott 1.25 (declare (type (unsigned-byte 32) csp))
492     (scrub (int-sap (- csp initial-offset))
493 wlott 1.30 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
494 wlott 1.25 0))))
495 ram 1.49
496     #+x86 ;; Stack grows downwards
497     (defun scrub-control-stack ()
498     "Zero the unused portion of the control stack so that old objects are not
499     kept alive because of uninitialized stack variables."
500     (declare (optimize (speed 3) (safety 0))
501     (values (unsigned-byte 20)))
502     (labels
503     ((scrub (ptr offset count)
504     (declare (type system-area-pointer ptr)
505     (type (unsigned-byte 16) offset)
506     (type (unsigned-byte 20) count)
507     (values (unsigned-byte 20)))
508     (let ((loc (int-sap (- (sap-int ptr) (+ offset vm:word-bytes)))))
509     (cond ((= offset bytes-per-scrub-unit)
510     (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit))
511     0 count))
512     (t ;; need to fix bug in %set-stack-ref
513     (setf (sap-ref-32 loc 0) 0)
514     (scrub ptr (+ offset vm:word-bytes) count)))))
515     (look (ptr offset count)
516     (declare (type system-area-pointer ptr)
517     (type (unsigned-byte 16) offset)
518     (type (unsigned-byte 20) count)
519     (values (unsigned-byte 20)))
520     (let ((loc (int-sap (- (sap-int ptr) offset))))
521     (cond ((= offset bytes-per-scrub-unit)
522     count)
523 dtc 1.51 ((zerop (kernel::get-lisp-obj-address (stack-ref loc 0)))
524     ; ((zerop (stack-ref loc 0))
525 ram 1.49 (look ptr (+ offset vm:word-bytes) count))
526     (t
527     (scrub ptr offset (+ count vm:word-bytes)))))))
528     (let* ((csp (sap-int (c::control-stack-pointer-sap)))
529     (initial-offset (logand csp (1- bytes-per-scrub-unit))))
530     (declare (type (unsigned-byte 32) csp))
531     (scrub (int-sap (+ csp initial-offset))
532     (* (floor initial-offset vm:word-bytes) vm:word-bytes)
533     0))))
534    
535 wlott 1.25
536    
537    
538 ram 1.1 ;;;; TOP-LEVEL loop.
539    
540     (defvar / nil
541     "Holds a list of all the values returned by 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 EVAL.")
545     (defvar ** nil "Gets the previous value of * when a new value is computed.")
546     (defvar *** nil "Gets the previous value of ** when a new value is computed.")
547     (defvar + nil "Holds the value of the most recent top-level READ.")
548     (defvar ++ nil "Gets the previous value of + when a new value is read.")
549     (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
550     (defvar - nil "Holds the form curently being evaluated.")
551 ram 1.3 (defvar *prompt* "* "
552     "The top-level prompt string. This also may be a function of no arguments
553     that returns a simple-string.")
554 ram 1.1 (defvar *in-top-level-catcher* nil
555     "True if we are within the Top-Level-Catcher. This is used by interrupt
556     handlers to see whether it is o.k. to throw.")
557    
558 ram 1.3 (defun interactive-eval (form)
559     "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
560     +, ///, //, /, and -."
561 ram 1.21 (setf - form)
562 ram 1.3 (let ((results (multiple-value-list (eval form))))
563     (setf /// //
564     // /
565     / results
566     *** **
567     ** *
568     * (car results)))
569 ram 1.21 (setf +++ ++
570     ++ +
571     + -)
572 ram 1.3 (unless (boundp '*)
573     ;; The bogon returned an unbound marker.
574     (setf * nil)
575     (cerror "Go on with * set to NIL."
576     "EVAL returned an unbound marker."))
577     (values-list /))
578 ram 1.21
579 ram 1.3
580     (defconstant eofs-before-quit 10)
581    
582 ram 1.1 (defun %top-level ()
583     "Top-level READ-EVAL-PRINT loop. Do not call this."
584 ram 1.3 (let ((* nil) (** nil) (*** nil)
585 ram 1.1 (- nil) (+ nil) (++ nil) (+++ nil)
586 ram 1.3 (/// nil) (// nil) (/ nil)
587     (magic-eof-cookie (cons :eof nil))
588     (number-of-eofs 0))
589 ram 1.1 (loop
590 wlott 1.25 (with-simple-restart (abort "Return to Top-Level.")
591     (catch 'top-level-catcher
592 wlott 1.28 (unix:unix-sigsetmask 0)
593 wlott 1.25 (let ((*in-top-level-catcher* t))
594     (loop
595     (scrub-control-stack)
596     (fresh-line)
597     (princ (if (functionp *prompt*)
598     (funcall *prompt*)
599     *prompt*))
600     (force-output)
601     (let ((form (read *standard-input* nil magic-eof-cookie)))
602     (cond ((not (eq form magic-eof-cookie))
603     (let ((results
604     (multiple-value-list (interactive-eval form))))
605     (dolist (result results)
606     (fresh-line)
607     (prin1 result)))
608     (setf number-of-eofs 0))
609     ((eql (incf number-of-eofs) 1)
610 phg 1.47 (if *batch-mode*
611 ram 1.48 (quit)
612 phg 1.47 (let ((stream (make-synonym-stream '*terminal-io*)))
613     (setf *standard-input* stream)
614     (setf *standard-output* stream)
615     (format t "~&Received EOF on *standard-input*, ~
616     switching to *terminal-io*.~%"))))
617 wlott 1.25 ((> number-of-eofs eofs-before-quit)
618     (format t "~&Received more than ~D EOFs; Aborting.~%"
619     eofs-before-quit)
620     (quit))
621     (t
622     (format t "~&Received EOF.~%")))))))))))
623 ram 1.1
624 phg 1.47 (defun %handled-top-level ()
625     "Wrap %top-level read-eval-print loop in an error handler for *batch-mode*."
626     (handler-case
627     (progn
628     (%top-level)
629 ram 1.48 (quit))
630 phg 1.47 (error (cond)
631 ram 1.48 (format *error-output* "Error in batch processing:~%~A" cond)
632     (throw '%end-of-the-world 1))))
633 ram 1.1
634 ram 1.3
635 ram 1.1 ;;; %Halt -- Interface
636     ;;;
637     ;;; A convenient way to get into the assembly level debugger.
638     ;;;
639     (defun %halt ()
640     (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5