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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.79.12.5 - (show annotations)
Fri Feb 12 05:52:24 2010 UTC (4 years, 2 months ago) by rtoy
Branch: intl-branch
Changes since 1.79.12.4: +46 -44 lines
code/lispinit.lisp:
o Mark translatable strings.

compiler/ctype.lisp:
o Forgot to mark one translatable string.

i18n/locale/cmucl.pot
i18n/locale/ko/LC_MESSAGES/cmucl.po
o Regenerated.
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.12.5 2010/02/12 05:52:24 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 _N"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 _N"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 _N"The fixnum closest in value to positive infinity.")
52
53 (defconstant most-negative-fixnum #.vm:target-most-negative-fixnum
54 _N"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 _N"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 _N"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 _N"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 _N"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 _N"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 (condition stream)
266 (declare (ignore condition))
267 (write-string _"Skip warning." stream))
268 (return-from warn nil)))
269 (format *error-output* _"~&~@<Warning: ~3i~:_~A~:>~%" condition)))
270 nil)
271
272 ;;; Utility functions
273
274 (defun simple-program-error (datum &rest arguments)
275 _N"Invokes the signal facility on a condition formed from datum and arguments.
276 If the condition is not handled, the debugger is invoked. This function
277 is just like error, except that the condition type defaults to the type
278 simple-program-error, instead of program-error."
279 (kernel:infinite-error-protect
280 (let ((condition (coerce-to-condition datum arguments
281 'simple-program-error
282 'simple-program-error))
283 (debug:*stack-top-hint* debug:*stack-top-hint*))
284 (unless (and (condition-function-name condition) debug:*stack-top-hint*)
285 (multiple-value-bind
286 (name frame)
287 (kernel:find-caller-name)
288 (unless (condition-function-name condition)
289 (setf (condition-function-name condition) name))
290 (unless debug:*stack-top-hint*
291 (setf debug:*stack-top-hint* frame))))
292 (let ((debug:*stack-top-hint* nil))
293 (signal condition))
294 (invoke-debugger condition))))
295
296 (in-package "LISP")
297
298
299 ;;; %Initial-Function is called when a cold system starts up. First we zoom
300 ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
301 ;;; at "load time." Then we initialize the various subsystems and call the
302 ;;; read-eval-print loop. The top-level Read-Eval-Print loop is executed until
303 ;;; someone (most likely the Quit function) throws to the tag
304 ;;; %End-Of-The-World. We quit this way so that all outstanding cleanup forms
305 ;;; in Unwind-Protects will get executed.
306
307 (declaim (special *lisp-initialization-functions*
308 *load-time-values*))
309
310 (eval-when (compile)
311 (defmacro print-and-call (name)
312 `(progn
313 (%primitive print ,(symbol-name name))
314 (,name))))
315 #+nil
316 (defun hexstr(thing)
317 (let ((addr (kernel:get-lisp-obj-address thing))
318 (str (make-string 10)))
319 (setf (char str 0) #\0
320 (char str 1) #\x)
321 (dotimes (i 8)
322 (let* ((nib (ldb (byte 4 0) addr))
323 (chr (char "0123456789abcdef" nib)))
324 (declare (type (unsigned-byte 4) nib)
325 (base-char chr))
326 (setf (char str (- 9 i)) chr
327 addr (ash addr -4))))
328 str))
329
330 (defun %initial-function ()
331 _N"Gives the world a shove and hopes it spins."
332 (%primitive print "In initial-function, and running.")
333 #-gengc (setf *already-maybe-gcing* t)
334 #-gengc (setf *gc-inhibit* t)
335 #-gengc (setf *need-to-collect-garbage* nil)
336 (setf *gc-verbose* #-gengc t #+gengc nil)
337 (setf *before-gc-hooks* nil)
338 (setf *after-gc-hooks* nil)
339 #-gengc (setf unix::*interrupts-enabled* t)
340 #-gengc (setf unix::*interrupt-pending* nil)
341 (setf *type-system-initialized* nil)
342 (setf *break-on-signals* nil)
343 (setf unix::*filename-encoding* nil)
344 #+gengc (setf conditions::*handler-clusters* nil)
345 (setq intl::*default-domain* "cmucl")
346 (setq intl::*locale* "C")
347
348 ;; Many top-level forms call INFO, (SETF INFO).
349 (print-and-call c::globaldb-init)
350
351 ;; Set up the fdefn database.
352 (print-and-call fdefn-init)
353
354 ;; Some of the random top-level forms call Make-Array, which calls Subtypep
355 (print-and-call typedef-init)
356 (print-and-call class-init)
357
358 (print-and-call type-init)
359
360 (let ((funs (nreverse *lisp-initialization-functions*)))
361 (%primitive print "Calling top-level forms.")
362 #+nil (%primitive print (length funs))
363 (dolist (fun funs)
364 #+nil (%primitive print fun)
365 (typecase fun
366 (function
367 (funcall fun))
368 (cons
369 (case (car fun)
370 (:load-time-value
371 (setf (svref *load-time-values* (third fun))
372 (funcall (second fun))))
373 (:load-time-value-fixup
374 #-gengc
375 (setf (#+amd64 sap-ref-64
376 #-amd64 sap-ref-32 (second fun) 0)
377 (get-lisp-obj-address
378 (svref *load-time-values* (third fun))))
379 #+gengc
380 (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))
381 #+(and (or x86 amd64) gencgc)
382 (:load-time-code-fixup
383 (vm::do-load-time-code-fixup (second fun) (third fun) (fourth fun)
384 (fifth fun)))
385 (t
386 (%primitive print
387 "Bogus fixup in *lisp-initialization-functions*")
388 (%halt))))
389 (t
390 (%primitive print
391 "Bogus function in *lisp-initialization-functions*")
392 (%halt)))))
393 (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
394 (makunbound '*load-time-values*)
395
396 ;; Only do this after top level forms have run, 'cause thats where
397 ;; deftypes are.
398 (setf *type-system-initialized* t)
399
400 (print-and-call os-init)
401 (print-and-call filesys-init)
402
403 (print-and-call reader-init)
404 ;; Note: sharpm and backq not yet loaded, so this is not the final RT.
405 (setf *readtable* (copy-readtable std-lisp-readtable))
406
407 (print-and-call stream-init)
408 (print-and-call loader-init)
409 (print-and-call package-init)
410 (print-and-call kernel::signal-init)
411 (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
412
413 (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero))
414
415 ;; This is necessary because some of the initial top level forms might
416 ;; have changed the compilation policy in strange ways.
417 (print-and-call c::proclaim-init)
418
419 (print-and-call kernel::class-finalize)
420
421 (setq intl::*default-domain* nil)
422 (%primitive print "Done initializing.")
423
424 #-gengc (setf *already-maybe-gcing* nil)
425 #+gengc (setf *gc-verbose* t)
426 (terpri)
427 (princ "CMU Common Lisp kernel core image ")
428 (princ (lisp-implementation-version))
429 (princ ".")
430 (terpri)
431 (princ "[You are in the LISP package.]")
432 (terpri)
433 (let ((wot (catch '%end-of-the-world
434 (loop
435 (%top-level)
436 (write-line "You're certainly a clever child.")))))
437 (unix:unix-exit wot)))
438
439 #+gengc
440 (defun do-load-time-value-fixup (object offset index)
441 (declare (type index offset))
442 (macrolet ((lose (msg)
443 `(progn
444 (%primitive print ,msg)
445 (%halt))))
446 (let ((value (svref *load-time-values* index)))
447 (typecase object
448 (list
449 (case offset
450 (0 (setf (car object) value))
451 (1 (setf (cdr object) value))
452 (t (lose "Bogus offset in cons cell."))))
453 (instance
454 (setf (%instance-ref object (- offset vm:instance-slots-offset))
455 value))
456 (code-component
457 (setf (code-header-ref object offset) value))
458 (simple-vector
459 (setf (svref object (- offset vm:vector-data-offset)) value))
460 (t
461 (lose "Unknown kind of object for load-time-value fixup."))))))
462
463
464 ;;;; Initialization functions:
465
466 ;;; Print seems to not like x86 NPX denormal floats like
467 ;;; least-negative-single-float, so the :underflow exceptions
468 ;;; is disabled by default. Joe User can explicitly enable them
469 ;;; if desired.
470
471 (defun reinit ()
472 (without-interrupts
473 (without-gcing
474 (os-init)
475 (stream-reinit)
476 (kernel::signal-init)
477 (gc-init)
478 (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
479 (set-floating-point-modes :traps
480 '(:overflow :invalid :divide-by-zero))
481 ;; Clear pseudo atomic in case this core wasn't compiled with support.
482 #+(or x86 amd64) (setf lisp::*pseudo-atomic-atomic* 0))))
483
484
485 ;;;; Miscellaneous external functions:
486
487 (defvar *cleanup-functions* nil
488 _N"Functions to be invoked during cleanup at Lisp exit.")
489
490 ;;; Quit gets us out, one way or another.
491
492 (defun quit (&optional recklessly-p)
493 _N"Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
494 non-Nil."
495 (if recklessly-p
496 (unix:unix-exit 0)
497 (progn
498 (mapc (lambda (fn) (ignore-errors (funcall fn))) *cleanup-functions*)
499 (throw '%end-of-the-world 0))))
500
501
502 #-mp ; Multi-processing version defined in multi-proc.lisp.
503 (defun sleep (n)
504 _N"This function causes execution to be suspended for N seconds. N may
505 be any non-negative, non-complex number."
506 (when (or (not (realp n))
507 (minusp n))
508 (error 'simple-type-error
509 :format-control
510 "Invalid argument to SLEEP: ~S.~%~
511 Must be a non-negative, non-complex number."
512 :format-arguments (list n)
513 :datum n
514 :expected-type '(real 0)))
515 (multiple-value-bind (sec usec)
516 (if (integerp n)
517 (values n 0)
518 (multiple-value-bind (sec frac) (truncate n)
519 (values sec (truncate frac 1e-6))))
520 (unix:unix-select 0 0 0 0 sec usec))
521 nil)
522
523 ;;;; SCRUB-CONTROL-STACK
524
525 #+stack-checking
526 (alien:def-alien-routine "os_guard_control_stack" c-call:void
527 (zone c-call:int)
528 (guardp c-call:int))
529
530
531 (defconstant bytes-per-scrub-unit 2048)
532
533 ;;; Scrub-control-stack.
534 ;;;
535 #-(or x86 amd64)
536 (defun %scrub-control-stack ()
537 _N"Zero the unused portion of the control stack so that old objects are not
538 kept alive because of uninitialized stack variables."
539 (declare (optimize (speed 3) (safety 0))
540 (values (unsigned-byte 20)))
541 (labels
542 ((scrub (ptr offset count)
543 (declare (type system-area-pointer ptr)
544 (type (unsigned-byte 16) offset)
545 (type (unsigned-byte 20) count)
546 (values (unsigned-byte 20)))
547 (cond ((= offset bytes-per-scrub-unit)
548 (look (sap+ ptr bytes-per-scrub-unit) 0 count))
549 (t
550 (setf (sap-ref-32 ptr offset) 0)
551 (scrub ptr (+ offset vm:word-bytes) count))))
552 (look (ptr offset count)
553 (declare (type system-area-pointer ptr)
554 (type (unsigned-byte 16) offset)
555 (type (unsigned-byte 20) count)
556 (values (unsigned-byte 20)))
557 (cond ((= offset bytes-per-scrub-unit)
558 count)
559 ((zerop (sap-ref-32 ptr offset))
560 (look ptr (+ offset vm:word-bytes) count))
561 (t
562 (scrub ptr offset (+ count vm:word-bytes))))))
563 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
564 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
565 (declare (type (unsigned-byte 32) csp))
566 (scrub (int-sap (- csp initial-offset))
567 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
568 0))))
569
570 ;;; Scrub-control-stack.
571 ;;;
572 ;;; On the x86 and amd64 port the stack grows downwards, and to support grow on
573 ;;; demand stacks the stack must be decreased as it is scrubbed.
574 ;;;
575 (defun scrub-control-stack ()
576 _N"Zero the unused portion of the control stack so that old objects are not
577 kept alive because of uninitialized stack variables."
578 ;;
579 ;; The guard zone of the control stack is used by Lisp sometimes,
580 ;; so I think it should be zero'd out, too.
581 #+stack-checking (os-guard-control-stack 0 0)
582 (%scrub-control-stack)
583 #+stack-checking (os-guard-control-stack 0 1))
584
585 #+(or x86 amd64)
586 (defun %scrub-control-stack ()
587 (%scrub-control-stack))
588
589
590 ;;;; TOP-LEVEL loop.
591
592 (defvar / nil
593 _N"Holds a list of all the values returned by the most recent top-level EVAL.")
594 (defvar // nil _N"Gets the previous value of / when a new value is computed.")
595 (defvar /// nil _N"Gets the previous value of // when a new value is computed.")
596 (defvar * nil _N"Holds the value of the most recent top-level EVAL.")
597 (defvar ** nil _N"Gets the previous value of * when a new value is computed.")
598 (defvar *** nil _N"Gets the previous value of ** when a new value is computed.")
599 (defvar + nil _N"Holds the value of the most recent top-level READ.")
600 (defvar ++ nil _N"Gets the previous value of + when a new value is read.")
601 (defvar +++ nil _N"Gets the previous value of ++ when a new value is read.")
602 (defvar - nil _N"Holds the form curently being evaluated.")
603 (defvar *prompt* "* "
604 _N"The top-level prompt string. This also may be a function of no arguments
605 that returns a simple-string.")
606 (defvar *in-top-level-catcher* nil
607 _N"True if we are within the Top-Level-Catcher. This is used by interrupt
608 handlers to see whether it is o.k. to throw.")
609
610 (defun interactive-eval (form)
611 _N"Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
612 +, ///, //, /, and -."
613 (when (and (fboundp 'commandp) (funcall 'commandp form))
614 (return-from interactive-eval (funcall 'invoke-command-interactive form)))
615 (setf - form)
616 (let ((results (multiple-value-list (eval form))))
617 (finish-standard-output-streams)
618 (setf /// //
619 // /
620 / results
621 *** **
622 ** *
623 * (car results)))
624 (setf +++ ++
625 ++ +
626 + -)
627 (unless (boundp '*)
628 ;; The bogon returned an unbound marker.
629 (setf * nil)
630 (cerror _"Go on with * set to NIL."
631 _"EVAL returned an unbound marker."))
632 (values-list /))
633
634
635 (defconstant eofs-before-quit 10)
636
637 (defparameter *reserved-heap-pages* 256
638 _N"How many pages to reserve from the total heap space so we can handle
639 heap overflow.")
640
641 #+heap-overflow-check
642 (alien:def-alien-variable "reserved_heap_pages" c-call:unsigned-long)
643
644 (defun %top-level ()
645 _N"Top-level READ-EVAL-PRINT loop. Do not call this."
646 (let ((* nil) (** nil) (*** nil)
647 (- nil) (+ nil) (++ nil) (+++ nil)
648 (/// nil) (// nil) (/ nil)
649 (magic-eof-cookie (cons :eof nil))
650 (number-of-eofs 0))
651 (loop
652 (with-simple-restart (abort _"Return to Top-Level.")
653 (catch 'top-level-catcher
654 (unix:unix-sigsetmask 0)
655 (let ((*in-top-level-catcher* t))
656 (loop
657 (scrub-control-stack)
658 (fresh-line)
659 ;; Reset reserved pages in the heap
660 #+heap-overflow-check (setf reserved-heap-pages *reserved-heap-pages*)
661 (princ (if (functionp *prompt*)
662 (funcall *prompt*)
663 *prompt*))
664 (force-output)
665 (let ((form (read *standard-input* nil magic-eof-cookie)))
666 (cond ((not (eq form magic-eof-cookie))
667 (let ((results
668 (multiple-value-list (interactive-eval form))))
669 (dolist (result results)
670 (fresh-line)
671 (prin1 result)))
672 (setf number-of-eofs 0))
673 ((eql (incf number-of-eofs) 1)
674 (if *batch-mode*
675 (quit)
676 (let ((stream (make-synonym-stream '*terminal-io*)))
677 (setf *standard-input* stream)
678 (setf *standard-output* stream)
679 (format t _"~&Received EOF on *standard-input*, ~
680 switching to *terminal-io*.~%"))))
681 ((> number-of-eofs eofs-before-quit)
682 (format t _"~&Received more than ~D EOFs; Aborting.~%"
683 eofs-before-quit)
684 (quit))
685 (t
686 (format t _"~&Received EOF.~%")))))))))))
687
688
689 ;;; %Halt -- Interface
690 ;;;
691 ;;; A convenient way to get into the assembly level debugger.
692 ;;;
693 (defun %halt ()
694 (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5