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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.78.4.2.2.3 - (show annotations)
Wed Jul 2 14:53:44 2008 UTC (5 years, 9 months ago) by rtoy
Branch: unicode-utf16-extfmt-branch
CVS Tags: unicode-utf16-extfmt-2009-03-27, unicode-snapshot-2009-05, unicode-utf16-extfmts-sync-2008-12, unicode-utf16-extfmts-pre-sync-2008-11
Changes since 1.78.4.2.2.2: +1 -7 lines
code/lispinit.lisp:
o Revert previous change, preserving order of initialization.

Changes from Paul to allow building of the new code from non-unicode
version:

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

  ViewVC Help
Powered by ViewVC 1.1.5