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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5