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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.79 - (show annotations)
Thu Jun 11 16:03:58 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: merged-unicode-utf16-extfmt-2009-06-11, unicode-string-buffer-impl-base, unicode-string-buffer-base, amd64-dd-start, intl-2-branch-base, release-20a-base, pre-merge-intl-branch, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, portable-clx-import-2009-06-16, intl-branch-base, portable-clx-base, snapshot-2009-08, snapshot-2009-07
Branch point for: portable-clx-branch, unicode-string-buffer-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, intl-2-branch
Changes since 1.78: +12 -9 lines
Merge Unicode work to trunk.  From label
unicode-utf16-extfmt-2009-06-11.
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.79 2009/06/11 16:03:58 rtoy Rel $")
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 (catch '%end-of-the-world
426 (loop
427 (%top-level)
428 (write-line "You're certainly a clever child.")))))
429 (unix:unix-exit wot)))
430
431 #+gengc
432 (defun do-load-time-value-fixup (object offset index)
433 (declare (type index offset))
434 (macrolet ((lose (msg)
435 `(progn
436 (%primitive print ,msg)
437 (%halt))))
438 (let ((value (svref *load-time-values* index)))
439 (typecase object
440 (list
441 (case offset
442 (0 (setf (car object) value))
443 (1 (setf (cdr object) value))
444 (t (lose "Bogus offset in cons cell."))))
445 (instance
446 (setf (%instance-ref object (- offset vm:instance-slots-offset))
447 value))
448 (code-component
449 (setf (code-header-ref object offset) value))
450 (simple-vector
451 (setf (svref object (- offset vm:vector-data-offset)) value))
452 (t
453 (lose "Unknown kind of object for load-time-value fixup."))))))
454
455
456 ;;;; Initialization functions:
457
458 ;;; Print seems to not like x86 NPX denormal floats like
459 ;;; least-negative-single-float, so the :underflow exceptions
460 ;;; is disabled by default. Joe User can explicitly enable them
461 ;;; if desired.
462
463 (defun reinit ()
464 (without-interrupts
465 (without-gcing
466 (os-init)
467 (stream-reinit)
468 (kernel::signal-init)
469 (gc-init)
470 (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
471 (set-floating-point-modes :traps
472 '(:overflow :invalid :divide-by-zero))
473 ;; Clear pseudo atomic in case this core wasn't compiled with support.
474 #+(or x86 amd64) (setf lisp::*pseudo-atomic-atomic* 0))))
475
476
477 ;;;; Miscellaneous external functions:
478
479 (defvar *cleanup-functions* nil
480 "Functions to be invoked during cleanup at Lisp exit.")
481
482 ;;; Quit gets us out, one way or another.
483
484 (defun quit (&optional recklessly-p)
485 "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
486 non-Nil."
487 (if recklessly-p
488 (unix:unix-exit 0)
489 (progn
490 (mapc (lambda (fn) (ignore-errors (funcall fn))) *cleanup-functions*)
491 (throw '%end-of-the-world 0))))
492
493
494 #-mp ; Multi-processing version defined in multi-proc.lisp.
495 (defun sleep (n)
496 "This function causes execution to be suspended for N seconds. N may
497 be any non-negative, non-complex number."
498 (when (or (not (realp n))
499 (minusp n))
500 (error 'simple-type-error
501 :format-control
502 "Invalid argument to SLEEP: ~S.~%~
503 Must be a non-negative, non-complex number."
504 :format-arguments (list n)
505 :datum n
506 :expected-type '(real 0)))
507 (multiple-value-bind (sec usec)
508 (if (integerp n)
509 (values n 0)
510 (multiple-value-bind (sec frac) (truncate n)
511 (values sec (truncate frac 1e-6))))
512 (unix:unix-select 0 0 0 0 sec usec))
513 nil)
514
515 ;;;; SCRUB-CONTROL-STACK
516
517 #+stack-checking
518 (alien:def-alien-routine "os_guard_control_stack" c-call:void
519 (zone c-call:int)
520 (guardp c-call:int))
521
522
523 (defconstant bytes-per-scrub-unit 2048)
524
525 ;;; Scrub-control-stack.
526 ;;;
527 #-(or x86 amd64)
528 (defun %scrub-control-stack ()
529 "Zero the unused portion of the control stack so that old objects are not
530 kept alive because of uninitialized stack variables."
531 (declare (optimize (speed 3) (safety 0))
532 (values (unsigned-byte 20)))
533 (labels
534 ((scrub (ptr offset count)
535 (declare (type system-area-pointer ptr)
536 (type (unsigned-byte 16) offset)
537 (type (unsigned-byte 20) count)
538 (values (unsigned-byte 20)))
539 (cond ((= offset bytes-per-scrub-unit)
540 (look (sap+ ptr bytes-per-scrub-unit) 0 count))
541 (t
542 (setf (sap-ref-32 ptr offset) 0)
543 (scrub ptr (+ offset vm:word-bytes) count))))
544 (look (ptr offset count)
545 (declare (type system-area-pointer ptr)
546 (type (unsigned-byte 16) offset)
547 (type (unsigned-byte 20) count)
548 (values (unsigned-byte 20)))
549 (cond ((= offset bytes-per-scrub-unit)
550 count)
551 ((zerop (sap-ref-32 ptr offset))
552 (look ptr (+ offset vm:word-bytes) count))
553 (t
554 (scrub ptr offset (+ count vm:word-bytes))))))
555 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
556 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
557 (declare (type (unsigned-byte 32) csp))
558 (scrub (int-sap (- csp initial-offset))
559 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
560 0))))
561
562 ;;; Scrub-control-stack.
563 ;;;
564 ;;; On the x86 and amd64 port the stack grows downwards, and to support grow on
565 ;;; demand stacks the stack must be decreased as it is scrubbed.
566 ;;;
567 (defun scrub-control-stack ()
568 "Zero the unused portion of the control stack so that old objects are not
569 kept alive because of uninitialized stack variables."
570 ;;
571 ;; The guard zone of the control stack is used by Lisp sometimes,
572 ;; so I think it should be zero'd out, too.
573 #+stack-checking (os-guard-control-stack 0 0)
574 (%scrub-control-stack)
575 #+stack-checking (os-guard-control-stack 0 1))
576
577 #+(or x86 amd64)
578 (defun %scrub-control-stack ()
579 (%scrub-control-stack))
580
581
582 ;;;; TOP-LEVEL loop.
583
584 (defvar / nil
585 "Holds a list of all the values returned by the most recent top-level EVAL.")
586 (defvar // nil "Gets the previous value of / when a new value is computed.")
587 (defvar /// nil "Gets the previous value of // when a new value is computed.")
588 (defvar * nil "Holds the value of the most recent top-level EVAL.")
589 (defvar ** nil "Gets the previous value of * when a new value is computed.")
590 (defvar *** nil "Gets the previous value of ** when a new value is computed.")
591 (defvar + nil "Holds the value of the most recent top-level READ.")
592 (defvar ++ nil "Gets the previous value of + when a new value is read.")
593 (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
594 (defvar - nil "Holds the form curently being evaluated.")
595 (defvar *prompt* "* "
596 "The top-level prompt string. This also may be a function of no arguments
597 that returns a simple-string.")
598 (defvar *in-top-level-catcher* nil
599 "True if we are within the Top-Level-Catcher. This is used by interrupt
600 handlers to see whether it is o.k. to throw.")
601
602 (defun interactive-eval (form)
603 "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
604 +, ///, //, /, and -."
605 (when (and (fboundp 'commandp) (funcall 'commandp form))
606 (return-from interactive-eval (funcall 'invoke-command-interactive form)))
607 (setf - form)
608 (let ((results (multiple-value-list (eval form))))
609 (finish-standard-output-streams)
610 (setf /// //
611 // /
612 / results
613 *** **
614 ** *
615 * (car results)))
616 (setf +++ ++
617 ++ +
618 + -)
619 (unless (boundp '*)
620 ;; The bogon returned an unbound marker.
621 (setf * nil)
622 (cerror "Go on with * set to NIL."
623 "EVAL returned an unbound marker."))
624 (values-list /))
625
626
627 (defconstant eofs-before-quit 10)
628
629 (defparameter *reserved-heap-pages* 256
630 "How many pages to reserve from the total heap space so we can handle
631 heap overflow.")
632
633 #+heap-overflow-check
634 (alien:def-alien-variable "reserved_heap_pages" c-call:unsigned-long)
635
636 (defun %top-level ()
637 "Top-level READ-EVAL-PRINT loop. Do not call this."
638 (let ((* nil) (** nil) (*** nil)
639 (- nil) (+ nil) (++ nil) (+++ nil)
640 (/// nil) (// nil) (/ nil)
641 (magic-eof-cookie (cons :eof nil))
642 (number-of-eofs 0))
643 (loop
644 (with-simple-restart (abort "Return to Top-Level.")
645 (catch 'top-level-catcher
646 (unix:unix-sigsetmask 0)
647 (let ((*in-top-level-catcher* t))
648 (loop
649 (scrub-control-stack)
650 (fresh-line)
651 ;; Reset reserved pages in the heap
652 #+heap-overflow-check (setf reserved-heap-pages *reserved-heap-pages*)
653 (princ (if (functionp *prompt*)
654 (funcall *prompt*)
655 *prompt*))
656 (force-output)
657 (let ((form (read *standard-input* nil magic-eof-cookie)))
658 (cond ((not (eq form magic-eof-cookie))
659 (let ((results
660 (multiple-value-list (interactive-eval form))))
661 (dolist (result results)
662 (fresh-line)
663 (prin1 result)))
664 (setf number-of-eofs 0))
665 ((eql (incf number-of-eofs) 1)
666 (if *batch-mode*
667 (quit)
668 (let ((stream (make-synonym-stream '*terminal-io*)))
669 (setf *standard-input* stream)
670 (setf *standard-output* stream)
671 (format t "~&Received EOF on *standard-input*, ~
672 switching to *terminal-io*.~%"))))
673 ((> number-of-eofs eofs-before-quit)
674 (format t "~&Received more than ~D EOFs; Aborting.~%"
675 eofs-before-quit)
676 (quit))
677 (t
678 (format t "~&Received EOF.~%")))))))))))
679
680
681 ;;; %Halt -- Interface
682 ;;;
683 ;;; A convenient way to get into the assembly level debugger.
684 ;;;
685 (defun %halt ()
686 (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5