/[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 - (hide 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 ram 1.1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.20 ;;; 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 rtoy 1.79.12.5 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/lispinit.lisp,v 1.79.12.5 2010/02/12 05:52:24 rtoy Exp $")
9 ram 1.20 ;;;
10 ram 1.1 ;;; **********************************************************************
11 wlott 1.10 ;;;
12 wlott 1.14 ;;; Initialization stuff for CMU Common Lisp, plus some other random functions
13     ;;; that we don't have any better place for.
14     ;;;
15 ram 1.1 ;;; Written by Skef Wholey and Rob MacLachlan.
16     ;;;
17 wlott 1.36 (in-package :lisp)
18 rtoy 1.79.12.2 (intl:textdomain "cmucl")
19 ram 1.1
20     (export '(most-positive-fixnum most-negative-fixnum sleep
21 wlott 1.33 ++ +++ ** *** // ///))
22 ram 1.1
23 toy 1.72 (defvar *features* '(:common :common-lisp :ansi-cl :ieee-floating-point :cmu)
24 rtoy 1.79.12.5 _N"Holds a list of symbols that describe features provided by the
25 toy 1.72 implementation.")
26    
27    
28 wlott 1.36 (in-package :system)
29 toy 1.72 (export '(compiler-version scrub-control-stack *runtime-features*))
30    
31     (defvar *runtime-features* nil
32 rtoy 1.79.12.5 _N"Features affecting the runtime")
33 ram 1.1
34 wlott 1.36 (in-package :extensions)
35 wlott 1.33 (export '(quit *prompt*))
36 ram 1.1
37 wlott 1.36 (in-package :lisp)
38 toy 1.72
39     #+stack-checking
40     (sys:register-lisp-runtime-feature :stack-checking)
41 ram 1.1
42 toy 1.73 #+heap-overflow-check
43     (sys:register-lisp-runtime-feature :heap-overflow-check)
44    
45 rtoy 1.76 #+double-double
46     (sys:register-lisp-feature :double-double)
47    
48 ram 1.1 ;;; Make the error system enable interrupts.
49    
50 wlott 1.10 (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum
51 rtoy 1.79.12.5 _N"The fixnum closest in value to positive infinity.")
52 ram 1.1
53 wlott 1.10 (defconstant most-negative-fixnum #.vm:target-most-negative-fixnum
54 rtoy 1.79.12.5 _N"The fixnum closest in value to negative infinity.")
55 ram 1.1
56    
57     ;;; Random information:
58    
59 wlott 1.10 (defvar *lisp-implementation-version* "4.0(?)")
60 ram 1.1
61    
62 ram 1.5 ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs...
63 wlott 1.35 (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 dtc 1.52 #+x86 *pseudo-atomic-atomic*
69     #+x86 *pseudo-atomic-interrupted*
70 wlott 1.35 unix::*interrupts-enabled*
71     unix::*interrupt-pending*
72 rtoy 1.79 *type-system-initialized*
73     unix::*filename-encoding*)
74 wlott 1.35 #+gengc
75     (special *gc-verbose* *before-gc-hooks* *after-gc-hooks*
76 rtoy 1.79 *type-system-initialized* unix::*filename-encoding*))
77 ram 1.1
78    
79 wlott 1.10 ;;;; Random magic specials.
80 ram 1.1
81    
82 wlott 1.10 ;;; These are filled in by Genesis.
83 ram 1.1
84 wlott 1.35 #-gengc
85     (progn
86    
87 wlott 1.10 (defvar *current-catch-block*)
88 dtc 1.50 (defvar *current-unwind-protect-block*)
89 wlott 1.10 (defvar *free-interrupt-context-index*)
90 ram 1.1
91 wlott 1.35 ); #-gengc progn
92 ram 1.1
93 wlott 1.10
94 ram 1.39 ;;;; 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 pw 1.63
107 ram 1.39 (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 pw 1.63 #+nil ;; Not ANSI compliant to disallow duplicate keywords.
122 ram 1.39 ((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 ram 1.40 (in-package "CONDITIONS")
143 ram 1.39
144     (defvar *break-on-signals* nil
145 rtoy 1.79.12.5 _N"When (typep condition *break-on-signals*) is true, then calls to SIGNAL will
146 ram 1.39 enter the debugger prior to signalling that condition.")
147    
148     (defun signal (datum &rest arguments)
149 rtoy 1.79.12.5 _N"Invokes the signal facility on a condition formed from datum and arguments.
150 ram 1.39 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 ram 1.45 (let ((obos *break-on-signals*)
157     (*break-on-signals* nil))
158     (when (typep condition obos)
159 rtoy 1.79.12.5 (break _"~A~%Break entered because of *break-on-signals* (now NIL.)"
160 ram 1.39 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 rtoy 1.79.12.5 (cerror _"Ignore the additional arguments."
177 ram 1.39 'simple-type-error
178     :datum arguments
179     :expected-type 'null
180 rtoy 1.79.12.5 :format-control _"You may not supply additional arguments ~
181 ram 1.39 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 rtoy 1.79.12.5 :format-control _"Bad argument to ~S: ~S"
195 ram 1.39 :format-arguments (list function-name datum)))))
196    
197     (defun error (datum &rest arguments)
198 rtoy 1.79.12.5 _N"Invokes the signal facility on a condition formed from datum and arguments.
199 ram 1.39 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 ram 1.43 (unless (and (condition-function-name condition) debug:*stack-top-hint*)
205 ram 1.39 (multiple-value-bind
206     (name frame)
207     (kernel:find-caller-name)
208 ram 1.43 (unless (condition-function-name condition)
209     (setf (condition-function-name condition) name))
210 ram 1.39 (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 ram 1.43 (unless (and (condition-function-name condition)
229     debug:*stack-top-hint*)
230 ram 1.39 (multiple-value-bind
231     (name frame)
232     (kernel:find-caller-name)
233 ram 1.43 (unless (condition-function-name condition)
234     (setf (condition-function-name condition) name))
235 ram 1.39 (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 rtoy 1.79.12.5 _N"Prints a message and invokes the debugger without allowing any possibility
245 ram 1.39 of condition handling occurring."
246     (kernel:infinite-error-protect
247 rtoy 1.79.12.3 (with-simple-restart (continue _"Return from BREAK.")
248 ram 1.39 (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 rtoy 1.79.12.5 _N"Warns about a situation by signalling a condition formed by datum and
257 ram 1.39 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 rtoy 1.79.12.5 (check-type condition warning _"a warning condition")
263 ram 1.39 (restart-case (signal condition)
264     (muffle-warning ()
265 rtoy 1.79.12.5 :report (lambda (condition stream)
266     (declare (ignore condition))
267     (write-string _"Skip warning." stream))
268 ram 1.39 (return-from warn nil)))
269 rtoy 1.79.12.3 (format *error-output* _"~&~@<Warning: ~3i~:_~A~:>~%" condition)))
270 ram 1.39 nil)
271 pmai 1.67
272     ;;; Utility functions
273    
274     (defun simple-program-error (datum &rest arguments)
275 rtoy 1.79.12.5 _N"Invokes the signal facility on a condition formed from datum and arguments.
276 pmai 1.67 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 ram 1.39
296     (in-package "LISP")
297    
298    
299 ram 1.1 ;;; %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 pw 1.62 (declaim (special *lisp-initialization-functions*
308     *load-time-values*))
309 ram 1.1
310     (eval-when (compile)
311     (defmacro print-and-call (name)
312     `(progn
313 wlott 1.10 (%primitive print ,(symbol-name name))
314 ram 1.1 (,name))))
315 ram 1.49 #+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 ram 1.1
330     (defun %initial-function ()
331 rtoy 1.79.12.5 _N"Gives the world a shove and hopes it spins."
332 wlott 1.36 (%primitive print "In initial-function, and running.")
333 wlott 1.35 #-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 wlott 1.12 (setf *before-gc-hooks* nil)
338     (setf *after-gc-hooks* nil)
339 wlott 1.35 #-gengc (setf unix::*interrupts-enabled* t)
340     #-gengc (setf unix::*interrupt-pending* nil)
341 ram 1.34 (setf *type-system-initialized* nil)
342 ram 1.41 (setf *break-on-signals* nil)
343 rtoy 1.79 (setf unix::*filename-encoding* nil)
344 wlott 1.44 #+gengc (setf conditions::*handler-clusters* nil)
345 rtoy 1.79.12.2 (setq intl::*default-domain* "cmucl")
346 rtoy 1.79.12.4 (setq intl::*locale* "C")
347 ram 1.1
348     ;; Many top-level forms call INFO, (SETF INFO).
349     (print-and-call c::globaldb-init)
350    
351 wlott 1.32 ;; 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 ram 1.34 (print-and-call typedef-init)
356     (print-and-call class-init)
357 rtoy 1.79.12.2
358 wlott 1.10 (print-and-call type-init)
359 ram 1.1
360 wlott 1.26 (let ((funs (nreverse *lisp-initialization-functions*)))
361     (%primitive print "Calling top-level forms.")
362 rtoy 1.79 #+nil (%primitive print (length funs))
363     (dolist (fun funs)
364     #+nil (%primitive print fun)
365 wlott 1.26 (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 wlott 1.36 #-gengc
375 cwang 1.74 (setf (#+amd64 sap-ref-64
376     #-amd64 sap-ref-32 (second fun) 0)
377 wlott 1.26 (get-lisp-obj-address
378 wlott 1.36 (svref *load-time-values* (third fun))))
379     #+gengc
380     (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))
381 cwang 1.74 #+(and (or x86 amd64) gencgc)
382 dtc 1.55 (:load-time-code-fixup
383     (vm::do-load-time-code-fixup (second fun) (third fun) (fourth fun)
384     (fifth fun)))
385 wlott 1.26 (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 ram 1.1 (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
394 wlott 1.26 (makunbound '*load-time-values*)
395 ram 1.1
396 wlott 1.10 ;; Only do this after top level forms have run, 'cause thats where
397     ;; deftypes are.
398 ram 1.34 (setf *type-system-initialized* t)
399 wlott 1.10
400 ram 1.1 (print-and-call os-init)
401     (print-and-call filesys-init)
402    
403     (print-and-call reader-init)
404 ram 1.38 ;; Note: sharpm and backq not yet loaded, so this is not the final RT.
405 wlott 1.12 (setf *readtable* (copy-readtable std-lisp-readtable))
406 ram 1.1
407     (print-and-call stream-init)
408 wlott 1.10 (print-and-call loader-init)
409 ram 1.1 (print-and-call package-init)
410 wlott 1.16 (print-and-call kernel::signal-init)
411 pw 1.56 (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
412 ram 1.49
413 cshapiro 1.78 (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero))
414 rtoy 1.79.12.1
415 wlott 1.29 ;; This is necessary because some of the initial top level forms might
416 cwang 1.74 ;; have changed the compilation policy in strange ways.
417 wlott 1.29 (print-and-call c::proclaim-init)
418 ram 1.34
419     (print-and-call kernel::class-finalize)
420 ram 1.1
421 rtoy 1.79.12.2 (setq intl::*default-domain* nil)
422 wlott 1.10 (%primitive print "Done initializing.")
423    
424 wlott 1.35 #-gengc (setf *already-maybe-gcing* nil)
425     #+gengc (setf *gc-verbose* t)
426 ram 1.1 (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 rtoy 1.79 (let ((wot (catch '%end-of-the-world
434     (loop
435     (%top-level)
436     (write-line "You're certainly a clever child.")))))
437 ram 1.48 (unix:unix-exit wot)))
438 wlott 1.36
439     #+gengc
440 wlott 1.42 (defun do-load-time-value-fixup (object offset index)
441 wlott 1.36 (declare (type index offset))
442     (macrolet ((lose (msg)
443     `(progn
444     (%primitive print ,msg)
445     (%halt))))
446 wlott 1.42 (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 ram 1.1
463    
464     ;;;; Initialization functions:
465    
466 ram 1.49 ;;; 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 ram 1.1 (defun reinit ()
472     (without-interrupts
473 wlott 1.33 (without-gcing
474     (os-init)
475     (stream-reinit)
476     (kernel::signal-init)
477     (gc-init)
478 pw 1.56 (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
479 wlott 1.33 (set-floating-point-modes :traps
480 toy 1.71 '(:overflow :invalid :divide-by-zero))
481 dtc 1.58 ;; Clear pseudo atomic in case this core wasn't compiled with support.
482 cwang 1.75 #+(or x86 amd64) (setf lisp::*pseudo-atomic-atomic* 0))))
483 ram 1.1
484    
485     ;;;; Miscellaneous external functions:
486    
487 pw 1.64 (defvar *cleanup-functions* nil
488 rtoy 1.79.12.5 _N"Functions to be invoked during cleanup at Lisp exit.")
489 pw 1.64
490 ram 1.1 ;;; Quit gets us out, one way or another.
491    
492     (defun quit (&optional recklessly-p)
493 rtoy 1.79.12.5 _N"Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
494 ram 1.1 non-Nil."
495     (if recklessly-p
496 wlott 1.28 (unix:unix-exit 0)
497 pw 1.64 (progn
498     (mapc (lambda (fn) (ignore-errors (funcall fn))) *cleanup-functions*)
499     (throw '%end-of-the-world 0))))
500 ram 1.1
501    
502 dtc 1.54 #-mp ; Multi-processing version defined in multi-proc.lisp.
503 ram 1.1 (defun sleep (n)
504 rtoy 1.79.12.5 _N"This function causes execution to be suspended for N seconds. N may
505 ram 1.1 be any non-negative, non-complex number."
506 wlott 1.13 (when (or (not (realp n))
507     (minusp n))
508 toy 1.66 (error 'simple-type-error
509     :format-control
510     "Invalid argument to SLEEP: ~S.~%~
511 wlott 1.13 Must be a non-negative, non-complex number."
512 toy 1.66 :format-arguments (list n)
513     :datum n
514     :expected-type '(real 0)))
515 wlott 1.13 (multiple-value-bind (sec usec)
516 pw 1.57 (if (integerp n)
517     (values n 0)
518 pw 1.64 (multiple-value-bind (sec frac) (truncate n)
519     (values sec (truncate frac 1e-6))))
520 wlott 1.28 (unix:unix-select 0 0 0 0 sec usec))
521 ram 1.1 nil)
522    
523 wlott 1.25 ;;;; SCRUB-CONTROL-STACK
524    
525 gerd 1.68 #+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 wlott 1.25
531 wlott 1.30 (defconstant bytes-per-scrub-unit 2048)
532 wlott 1.25
533 dtc 1.58 ;;; Scrub-control-stack.
534     ;;;
535 cwang 1.74 #-(or x86 amd64)
536 toy 1.69 (defun %scrub-control-stack ()
537 rtoy 1.79.12.5 _N"Zero the unused portion of the control stack so that old objects are not
538 wlott 1.25 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 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
548     (look (sap+ ptr bytes-per-scrub-unit) 0 count))
549 wlott 1.25 (t
550     (setf (sap-ref-32 ptr offset) 0)
551 wlott 1.30 (scrub ptr (+ offset vm:word-bytes) count))))
552 wlott 1.25 (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 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
558 wlott 1.25 count)
559     ((zerop (sap-ref-32 ptr offset))
560 wlott 1.30 (look ptr (+ offset vm:word-bytes) count))
561 wlott 1.25 (t
562 wlott 1.30 (scrub ptr offset (+ count vm:word-bytes))))))
563 wlott 1.25 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
564 wlott 1.30 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
565 wlott 1.25 (declare (type (unsigned-byte 32) csp))
566     (scrub (int-sap (- csp initial-offset))
567 wlott 1.30 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
568 wlott 1.25 0))))
569 dtc 1.59
570     ;;; Scrub-control-stack.
571     ;;;
572 cwang 1.74 ;;; On the x86 and amd64 port the stack grows downwards, and to support grow on
573 dtc 1.59 ;;; demand stacks the stack must be decreased as it is scrubbed.
574     ;;;
575 ram 1.49 (defun scrub-control-stack ()
576 rtoy 1.79.12.5 _N"Zero the unused portion of the control stack so that old objects are not
577 ram 1.49 kept alive because of uninitialized stack variables."
578 gerd 1.68 ;;
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 cwang 1.74 #+(or x86 amd64)
586 gerd 1.68 (defun %scrub-control-stack ()
587     (%scrub-control-stack))
588 wlott 1.25
589    
590 ram 1.1 ;;;; TOP-LEVEL loop.
591    
592     (defvar / nil
593 rtoy 1.79.12.5 _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 ram 1.3 (defvar *prompt* "* "
604 rtoy 1.79.12.5 _N"The top-level prompt string. This also may be a function of no arguments
605 ram 1.3 that returns a simple-string.")
606 ram 1.1 (defvar *in-top-level-catcher* nil
607 rtoy 1.79.12.5 _N"True if we are within the Top-Level-Catcher. This is used by interrupt
608 ram 1.1 handlers to see whether it is o.k. to throw.")
609    
610 ram 1.3 (defun interactive-eval (form)
611 rtoy 1.79.12.5 _N"Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
612 ram 1.3 +, ///, //, /, and -."
613 toy 1.70 (when (and (fboundp 'commandp) (funcall 'commandp form))
614     (return-from interactive-eval (funcall 'invoke-command-interactive form)))
615 ram 1.21 (setf - form)
616 toy 1.70 (let ((results (multiple-value-list (eval form))))
617 dtc 1.60 (finish-standard-output-streams)
618 ram 1.3 (setf /// //
619     // /
620     / results
621     *** **
622     ** *
623     * (car results)))
624 ram 1.21 (setf +++ ++
625     ++ +
626     + -)
627 ram 1.3 (unless (boundp '*)
628     ;; The bogon returned an unbound marker.
629     (setf * nil)
630 rtoy 1.79.12.5 (cerror _"Go on with * set to NIL."
631     _"EVAL returned an unbound marker."))
632 ram 1.3 (values-list /))
633 ram 1.21
634 ram 1.3
635     (defconstant eofs-before-quit 10)
636    
637 toy 1.73 (defparameter *reserved-heap-pages* 256
638 rtoy 1.79.12.5 _N"How many pages to reserve from the total heap space so we can handle
639 toy 1.73 heap overflow.")
640    
641     #+heap-overflow-check
642     (alien:def-alien-variable "reserved_heap_pages" c-call:unsigned-long)
643    
644 ram 1.1 (defun %top-level ()
645 rtoy 1.79.12.5 _N"Top-level READ-EVAL-PRINT loop. Do not call this."
646 ram 1.3 (let ((* nil) (** nil) (*** nil)
647 ram 1.1 (- nil) (+ nil) (++ nil) (+++ nil)
648 ram 1.3 (/// nil) (// nil) (/ nil)
649     (magic-eof-cookie (cons :eof nil))
650     (number-of-eofs 0))
651 ram 1.1 (loop
652 rtoy 1.79.12.5 (with-simple-restart (abort _"Return to Top-Level.")
653 wlott 1.25 (catch 'top-level-catcher
654 wlott 1.28 (unix:unix-sigsetmask 0)
655 wlott 1.25 (let ((*in-top-level-catcher* t))
656     (loop
657     (scrub-control-stack)
658     (fresh-line)
659 toy 1.73 ;; Reset reserved pages in the heap
660     #+heap-overflow-check (setf reserved-heap-pages *reserved-heap-pages*)
661 wlott 1.25 (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 phg 1.47 (if *batch-mode*
675 ram 1.48 (quit)
676 phg 1.47 (let ((stream (make-synonym-stream '*terminal-io*)))
677     (setf *standard-input* stream)
678     (setf *standard-output* stream)
679 rtoy 1.79.12.5 (format t _"~&Received EOF on *standard-input*, ~
680 phg 1.47 switching to *terminal-io*.~%"))))
681 wlott 1.25 ((> number-of-eofs eofs-before-quit)
682 rtoy 1.79.12.5 (format t _"~&Received more than ~D EOFs; Aborting.~%"
683 wlott 1.25 eofs-before-quit)
684     (quit))
685     (t
686 rtoy 1.79.12.5 (format t _"~&Received EOF.~%")))))))))))
687 ram 1.1
688 ram 1.3
689 ram 1.1 ;;; %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