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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.51 - (show annotations)
Tue Nov 4 09:10:45 1997 UTC (16 years, 5 months ago) by dtc
Branch: MAIN
Changes since 1.50: +3 -2 lines
Merge in changes to the x86 backend from the gencgc branch, allowing
common binaries to be run on both:

* The immediate-stack storage class has been removed, this is
unnecessary as the descriptor-stack SC can be used. It may have once
been part of some GC stragety to reduce the number of stack slots that
needed to be noted for a GC.

* The object allocation has been abstracted and cleaned up. This
should produce slightly faster smaller code with CGC, and can be
compiled to support inline allocation with GENCGC.  CGC compiled code
will run under GENCGC, and GENCGC binaries that don't use inline
allocation will run under CGC.

* A random hash is now placed in the unused symbol object slot (the
symbol-hash slot). This saves flushing the info cache at each GC, and
may have other uses for symbol based hash tables. Should help MP
safety.

* Common set of static symbols used by both CGC and GENCGC.

* Corrections to the stack-ref VOP; now returns lisp objects not
unsigned numbers. Required some patches to debug-int.

* Inline unsigned/signed byte 32 to bignum allocation enabled.

* Support for the x86 xadd instruction applied to instance slot and
symbol values - may be handy for some MP code.

* Bump up the FASL file version from 1 to 2.
1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/lispinit.lisp,v 1.51 1997/11/04 09:10:45 dtc Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Initialization stuff for CMU Common Lisp, plus some other random functions
13 ;;; that we don't have any better place for.
14 ;;;
15 ;;; Written by Skef Wholey and Rob MacLachlan.
16 ;;;
17 (in-package :lisp)
18
19 (export '(most-positive-fixnum most-negative-fixnum sleep
20 ++ +++ ** *** // ///))
21
22 (in-package :system)
23 (export '(compiler-version scrub-control-stack))
24
25 (in-package :extensions)
26 (export '(quit *prompt*))
27
28 (in-package :lisp)
29
30 ;;; Make the error system enable interrupts.
31
32 (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum
33 "The fixnum closest in value to positive infinity.")
34
35 (defconstant most-negative-fixnum #.vm:target-most-negative-fixnum
36 "The fixnum closest in value to negative infinity.")
37
38
39 ;;; Random information:
40
41 (defvar *lisp-implementation-version* "4.0(?)")
42
43
44 ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs...
45 (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
57
58 ;;;; Random magic specials.
59
60
61 ;;; These are filled in by Genesis.
62
63 #-gengc
64 (progn
65
66 (defvar *current-catch-block*)
67 (defvar *current-unwind-protect-block*)
68 (defvar *free-interrupt-context-index*)
69
70 ); #-gengc progn
71
72
73 ;;;; 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 (in-package "CONDITIONS")
120
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 (let ((obos *break-on-signals*)
134 (*break-on-signals* nil))
135 (when (typep condition obos)
136 (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 (unless (and (condition-function-name condition) debug:*stack-top-hint*)
182 (multiple-value-bind
183 (name frame)
184 (kernel:find-caller-name)
185 (unless (condition-function-name condition)
186 (setf (condition-function-name condition) name))
187 (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 (unless (and (condition-function-name condition)
206 debug:*stack-top-hint*)
207 (multiple-value-bind
208 (name frame)
209 (kernel:find-caller-name)
210 (unless (condition-function-name condition)
211 (setf (condition-function-name condition) name))
212 (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 ;;; %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 (proclaim '(special *lisp-initialization-functions*
259 *load-time-values*))
260
261 (eval-when (compile)
262 (defmacro print-and-call (name)
263 `(progn
264 (%primitive print ,(symbol-name name))
265 (,name))))
266 #+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
281 (defun %initial-function ()
282 "Gives the world a shove and hopes it spins."
283 (%primitive print "In initial-function, and running.")
284 #-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 (setf *before-gc-hooks* nil)
289 (setf *after-gc-hooks* nil)
290 #-gengc (setf unix::*interrupts-enabled* t)
291 #-gengc (setf unix::*interrupt-pending* nil)
292 (setf *type-system-initialized* nil)
293 (setf *break-on-signals* nil)
294 #+gengc (setf conditions::*handler-clusters* nil)
295
296 ;; Many top-level forms call INFO, (SETF INFO).
297 (print-and-call c::globaldb-init)
298
299 ;; 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 (print-and-call typedef-init)
304 (print-and-call class-init)
305 (print-and-call type-init)
306
307 (let ((funs (nreverse *lisp-initialization-functions*)))
308 (%primitive print "Calling top-level forms.")
309 (dolist (fun funs) #+nil (%primitive print (hexstr fun))
310 (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 #-gengc
320 (setf (sap-ref-32 (second fun) 0)
321 (get-lisp-obj-address
322 (svref *load-time-values* (third fun))))
323 #+gengc
324 (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))
325 (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 (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
334 (makunbound '*load-time-values*)
335
336 ;; Only do this after top level forms have run, 'cause thats where
337 ;; deftypes are.
338 (setf *type-system-initialized* t)
339
340 (print-and-call os-init)
341 (print-and-call filesys-init)
342
343 (print-and-call reader-init)
344 ;; Note: sharpm and backq not yet loaded, so this is not the final RT.
345 (setf *readtable* (copy-readtable std-lisp-readtable))
346
347 (print-and-call stream-init)
348 (print-and-call loader-init)
349 (print-and-call package-init)
350 (print-and-call kernel::signal-init)
351 (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
352
353 (set-floating-point-modes :traps '(:overflow #-x86 :underflow :invalid
354 :divide-by-zero))
355 ;; 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
359 (print-and-call kernel::class-finalize)
360
361 (%primitive print "Done initializing.")
362
363 #-gengc (setf *already-maybe-gcing* nil)
364 #+gengc (setf *gc-verbose* t)
365 (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 (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
379 #+gengc
380 (defun do-load-time-value-fixup (object offset index)
381 (declare (type index offset))
382 (macrolet ((lose (msg)
383 `(progn
384 (%primitive print ,msg)
385 (%halt))))
386 (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
403
404 ;;;; Initialization functions:
405
406 ;;; 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 (defun reinit ()
412 (without-interrupts
413 (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 '(:overflow #-x86 :underflow :invalid
421 :divide-by-zero)))))
422
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 (unix:unix-exit 0)
434 (throw '%end-of-the-world 0)))
435
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 (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 (unix:unix-select 0 0 0 0 sec usec))
451 nil)
452
453
454 ;;;; SCRUB-CONTROL-STACK
455
456
457 (defconstant bytes-per-scrub-unit 2048)
458
459 #-x86
460 (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 (cond ((= offset bytes-per-scrub-unit)
472 (look (sap+ ptr bytes-per-scrub-unit) 0 count))
473 (t
474 (setf (sap-ref-32 ptr offset) 0)
475 (scrub ptr (+ offset vm:word-bytes) count))))
476 (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 (cond ((= offset bytes-per-scrub-unit)
482 count)
483 ((zerop (sap-ref-32 ptr offset))
484 (look ptr (+ offset vm:word-bytes) count))
485 (t
486 (scrub ptr offset (+ count vm:word-bytes))))))
487 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
488 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
489 (declare (type (unsigned-byte 32) csp))
490 (scrub (int-sap (- csp initial-offset))
491 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
492 0))))
493
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 (kernel::get-lisp-obj-address (stack-ref loc 0)))
522 ; ((zerop (stack-ref loc 0))
523 (look ptr (+ offset vm:word-bytes) count))
524 (t
525 (scrub ptr offset (+ count vm:word-bytes)))))))
526 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
527 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
528 (declare (type (unsigned-byte 32) csp))
529 (scrub (int-sap (+ csp initial-offset))
530 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
531 0))))
532
533
534
535
536 ;;;; TOP-LEVEL loop.
537
538 (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 (defvar *prompt* "* "
550 "The top-level prompt string. This also may be a function of no arguments
551 that returns a simple-string.")
552 (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 (defun interactive-eval (form)
557 "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
558 +, ///, //, /, and -."
559 (setf - form)
560 (let ((results (multiple-value-list (eval form))))
561 (setf /// //
562 // /
563 / results
564 *** **
565 ** *
566 * (car results)))
567 (setf +++ ++
568 ++ +
569 + -)
570 (unless (boundp '*)
571 ;; The bogon returned an unbound marker.
572 (setf * nil)
573 (cerror "Go on with * set to NIL."
574 "EVAL returned an unbound marker."))
575 (values-list /))
576
577
578 (defconstant eofs-before-quit 10)
579
580 (defun %top-level ()
581 "Top-level READ-EVAL-PRINT loop. Do not call this."
582 (let ((* nil) (** nil) (*** nil)
583 (- nil) (+ nil) (++ nil) (+++ nil)
584 (/// nil) (// nil) (/ nil)
585 (magic-eof-cookie (cons :eof nil))
586 (number-of-eofs 0))
587 (loop
588 (with-simple-restart (abort "Return to Top-Level.")
589 (catch 'top-level-catcher
590 (unix:unix-sigsetmask 0)
591 (let ((*in-top-level-catcher* t))
592 (loop
593 (scrub-control-stack)
594 (fresh-line)
595 (princ (if (functionp *prompt*)
596 (funcall *prompt*)
597 *prompt*))
598 (force-output)
599 (let ((form (read *standard-input* nil magic-eof-cookie)))
600 (cond ((not (eq form magic-eof-cookie))
601 (let ((results
602 (multiple-value-list (interactive-eval form))))
603 (dolist (result results)
604 (fresh-line)
605 (prin1 result)))
606 (setf number-of-eofs 0))
607 ((eql (incf number-of-eofs) 1)
608 (if *batch-mode*
609 (quit)
610 (let ((stream (make-synonym-stream '*terminal-io*)))
611 (setf *standard-input* stream)
612 (setf *standard-output* stream)
613 (format t "~&Received EOF on *standard-input*, ~
614 switching to *terminal-io*.~%"))))
615 ((> number-of-eofs eofs-before-quit)
616 (format t "~&Received more than ~D EOFs; Aborting.~%"
617 eofs-before-quit)
618 (quit))
619 (t
620 (format t "~&Received EOF.~%")))))))))))
621
622 (defun %handled-top-level ()
623 "Wrap %top-level read-eval-print loop in an error handler for *batch-mode*."
624 (handler-case
625 (progn
626 (%top-level)
627 (quit))
628 (error (cond)
629 (format *error-output* "Error in batch processing:~%~A" cond)
630 (throw '%end-of-the-world 1))))
631
632
633 ;;; %Halt -- Interface
634 ;;;
635 ;;; A convenient way to get into the assembly level debugger.
636 ;;;
637 (defun %halt ()
638 (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5