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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5