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

Diff of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.33.1.2 by ram, Sun Feb 21 16:27:10 1993 UTC revision 1.82 by rtoy, Tue Apr 20 17:57:44 2010 UTC
# Line 3  Line 3 
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the CMU Common Lisp project at  ;;; 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.  ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact  
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.  
6  ;;;  ;;;
7  (ext:file-comment  (ext:file-comment
8    "$Header$")    "$Header$")
# Line 16  Line 14 
14  ;;;  ;;;
15  ;;; Written by Skef Wholey and Rob MacLachlan.  ;;; Written by Skef Wholey and Rob MacLachlan.
16  ;;;  ;;;
17  (in-package "LISP" :use '("SYSTEM" "DEBUG"))  (in-package :lisp)
18    (intl:textdomain "cmucl")
19    
20  (export '(most-positive-fixnum most-negative-fixnum sleep  (export '(most-positive-fixnum most-negative-fixnum sleep
21            ++ +++ ** *** // ///))            ++ +++ ** *** // ///))
22    
23  (in-package "SYSTEM" :nicknames '("SYS"))  (defvar *features* '(:common :common-lisp :ansi-cl :ieee-floating-point :cmu)
24  (export '(compiler-version scrub-control-stack))    "Holds a list of symbols that describe features provided by the
25       implementation.")
26    
27  (in-package "EXTENSIONS")  
28    (in-package :system)
29    (export '(compiler-version scrub-control-stack *runtime-features*))
30    
31    (defvar *runtime-features* nil
32      "Features affecting the runtime")
33    
34    (in-package :extensions)
35  (export '(quit *prompt*))  (export '(quit *prompt*))
36    
37  (in-package "LISP")  (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.  ;;; Make the error system enable interrupts.
49    
# Line 44  Line 60 
60    
61    
62  ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs...  ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs...
63  (proclaim '(special *gc-inhibit* *already-maybe-gcing*  (declaim
64                      *need-to-collect-garbage* *gc-verbose*    #-gengc
65                      *before-gc-hooks* *after-gc-hooks*    (special *gc-inhibit* *already-maybe-gcing*
66                      unix::*interrupts-enabled*             *need-to-collect-garbage* *gc-verbose*
67                      unix::*interrupt-pending*             *before-gc-hooks* *after-gc-hooks*
68                      *type-system-initialized*))             #+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.  ;;;; Random magic specials.
# Line 57  Line 81 
81    
82  ;;; These are filled in by Genesis.  ;;; These are filled in by Genesis.
83    
84    #-gengc
85    (progn
86    
87  (defvar *current-catch-block*)  (defvar *current-catch-block*)
88  (defvar *current-unwind-block*)  (defvar *current-unwind-protect-block*)
89  (defvar *free-interrupt-context-index*)  (defvar *free-interrupt-context-index*)
90    
91    ); #-gengc progn
92    
93    
94    ;;;; Random stuff that needs to be in the cold load which would otherwise be
95    ;;;; byte-compiled.
96    ;;;;
97    (defvar hi::*in-the-editor* nil)
98    
99    ;;;; Called by defmacro expanders...
100    
101    ;;; VERIFY-KEYWORDS -- internal
102    ;;;
103    ;;; Determine if key-list is a valid list of keyword/value pairs.  Do not
104    ;;; signal the error directly, 'cause we don't know how it should be signaled.
105    ;;;
106    
107    (defun verify-keywords (key-list valid-keys allow-other-keys)
108      (do ((already-processed nil)
109           (unknown-keyword nil)
110           (remaining key-list (cddr remaining)))
111          ((null remaining)
112           (if (and unknown-keyword
113                    (not allow-other-keys)
114                    (not (lookup-keyword :allow-other-keys key-list)))
115               (values :unknown-keyword (list unknown-keyword valid-keys))
116               (values nil nil)))
117        (cond ((not (and (consp remaining) (listp (cdr remaining))))
118               (return (values :dotted-list key-list)))
119              ((null (cdr remaining))
120               (return (values :odd-length key-list)))
121              #+nil ;; Not ANSI compliant to disallow duplicate keywords.
122              ((member (car remaining) already-processed)
123               (return (values :duplicate (car remaining))))
124              ((or (eq (car remaining) :allow-other-keys)
125                   (member (car remaining) valid-keys))
126               (push (car remaining) already-processed))
127              (t
128               (setf unknown-keyword (car remaining))))))
129    
130    (defun lookup-keyword (keyword key-list)
131      (do ((remaining key-list (cddr remaining)))
132          ((endp remaining))
133        (when (eq keyword (car remaining))
134          (return (cadr remaining)))))
135    ;;;
136    (defun keyword-supplied-p (keyword key-list)
137      (do ((remaining key-list (cddr remaining)))
138          ((endp remaining))
139        (when (eq keyword (car remaining))
140          (return t))))
141    
142    (in-package "CONDITIONS")
143    
144    (defvar *break-on-signals* nil
145      "When (typep condition *break-on-signals*) is true, then calls to SIGNAL will
146       enter the debugger prior to signalling that condition.")
147    
148    (defun signal (datum &rest arguments)
149      "Invokes the signal facility on a condition formed from datum and arguments.
150       If the condition is not handled, nil is returned.  If
151       (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked before
152       any signalling is done."
153      (let ((condition (coerce-to-condition datum arguments
154                                            'simple-condition 'signal))
155            (*handler-clusters* *handler-clusters*))
156        (let ((obos *break-on-signals*)
157              (*break-on-signals* nil))
158          (when (typep condition obos)
159            (break (intl:gettext "~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 (intl:gettext "Ignore the additional arguments.")
177                         'simple-type-error
178                         :datum arguments
179                         :expected-type 'null
180                         :format-control (intl:gettext "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 (intl:gettext "Bad argument to ~S: ~S")
195                    :format-arguments (list function-name datum)))))
196    
197    (defun error (datum &rest arguments)
198      "Invokes the signal facility on a condition formed from datum and arguments.
199       If the condition is not handled, the debugger is invoked."
200      (kernel:infinite-error-protect
201        (let ((condition (coerce-to-condition datum arguments
202                                              'simple-error 'error))
203              (debug:*stack-top-hint* debug:*stack-top-hint*))
204          (unless (and (condition-function-name condition) debug:*stack-top-hint*)
205            (multiple-value-bind
206                (name frame)
207                (kernel:find-caller-name)
208              (unless (condition-function-name condition)
209                (setf (condition-function-name condition) name))
210              (unless debug:*stack-top-hint*
211                (setf debug:*stack-top-hint* frame))))
212          (let ((debug:*stack-top-hint* nil))
213            (signal condition))
214          (invoke-debugger condition))))
215    
216    ;;; CERROR must take care to not use arguments when datum is already a
217    ;;; condition object.
218    ;;;
219    (defun cerror (continue-string datum &rest arguments)
220      (kernel:infinite-error-protect
221        (with-simple-restart
222            (continue "~A" (apply #'format nil continue-string arguments))
223          (let ((condition (if (typep datum 'condition)
224                               datum
225                               (coerce-to-condition datum arguments
226                                                    'simple-error 'error)))
227                (debug:*stack-top-hint* debug:*stack-top-hint*))
228            (unless (and (condition-function-name condition)
229                         debug:*stack-top-hint*)
230              (multiple-value-bind
231                  (name frame)
232                  (kernel:find-caller-name)
233                (unless (condition-function-name condition)
234                  (setf (condition-function-name condition) name))
235                (unless debug:*stack-top-hint*
236                  (setf debug:*stack-top-hint* frame))))
237            (with-condition-restarts condition (list (find-restart 'continue))
238              (let ((debug:*stack-top-hint* nil))
239                (signal condition))
240              (invoke-debugger condition)))))
241      nil)
242    
243    (defun break (&optional (datum "Break") &rest arguments)
244      "Prints a message and invokes the debugger without allowing any possibility
245       of condition handling occurring."
246      (kernel:infinite-error-protect
247        (with-simple-restart (continue (intl:gettext "Return from BREAK."))
248          (let ((debug:*stack-top-hint*
249                 (or debug:*stack-top-hint*
250                     (nth-value 1 (kernel:find-caller-name)))))
251            (invoke-debugger
252             (coerce-to-condition datum arguments 'simple-condition 'break)))))
253      nil)
254    
255    (defun warn (datum &rest arguments)
256      "Warns about a situation by signalling a condition formed by datum and
257       arguments.  While the condition is being signaled, a muffle-warning restart
258       exists that causes WARN to immediately return nil."
259      (kernel:infinite-error-protect
260        (let ((condition (coerce-to-condition datum arguments
261                                              'simple-warning 'warn)))
262          (check-type condition warning (intl:gettext "a warning condition"))
263          (restart-case (signal condition)
264            (muffle-warning ()
265              :report (lambda (stream)
266                        (write-string (intl:gettext "Skip warning.") stream))
267              (return-from warn nil)))
268          (format *error-output* (intl:gettext "~&~@<Warning:  ~3i~:_~A~:>~%") condition)))
269      nil)
270    
271    ;;; Utility functions
272    
273    (defun simple-program-error (datum &rest arguments)
274      "Invokes the signal facility on a condition formed from datum and arguments.
275       If the condition is not handled, the debugger is invoked.  This function
276       is just like error, except that the condition type defaults to the type
277       simple-program-error, instead of program-error."
278      (kernel:infinite-error-protect
279        (let ((condition (coerce-to-condition datum arguments
280                                              'simple-program-error
281                                              'simple-program-error))
282              (debug:*stack-top-hint* debug:*stack-top-hint*))
283          (unless (and (condition-function-name condition) debug:*stack-top-hint*)
284            (multiple-value-bind
285                (name frame)
286                (kernel:find-caller-name)
287              (unless (condition-function-name condition)
288                (setf (condition-function-name condition) name))
289              (unless debug:*stack-top-hint*
290                (setf debug:*stack-top-hint* frame))))
291          (let ((debug:*stack-top-hint* nil))
292            (signal condition))
293          (invoke-debugger condition))))
294    
295    (in-package "LISP")
296    
297    
298  ;;; %Initial-Function is called when a cold system starts up.  First we zoom  ;;; %Initial-Function is called when a cold system starts up.  First we zoom
# Line 71  Line 303 
303  ;;; %End-Of-The-World.  We quit this way so that all outstanding cleanup forms  ;;; %End-Of-The-World.  We quit this way so that all outstanding cleanup forms
304  ;;; in Unwind-Protects will get executed.  ;;; in Unwind-Protects will get executed.
305    
306  (proclaim '(special *lisp-initialization-functions*  (declaim (special *lisp-initialization-functions*
307                      *load-time-values*))                    *load-time-values*))
308    
309  (eval-when (compile)  (eval-when (compile)
310    (defmacro print-and-call (name)    (defmacro print-and-call (name)
311      `(progn      `(progn
312         (%primitive print ,(symbol-name name))         (%primitive print ,(symbol-name name))
313         (,name))))         (,name))))
314    #+nil
315    (defun hexstr(thing)
316      (let ((addr (kernel:get-lisp-obj-address thing))
317            (str (make-string 10)))
318        (setf (char str 0) #\0
319              (char str 1) #\x)
320        (dotimes (i 8)
321          (let* ((nib (ldb (byte 4 0) addr))
322                 (chr (char "0123456789abcdef" nib)))
323            (declare (type (unsigned-byte 4) nib)
324                     (base-char chr))
325            (setf (char str (- 9 i)) chr
326                  addr (ash addr -4))))
327        str))
328    
329  (defun %initial-function ()  (defun %initial-function ()
330    "Gives the world a shove and hopes it spins."    "Gives the world a shove and hopes it spins."
331    (setf *already-maybe-gcing* t)    (%primitive print "In initial-function, and running.")
332    (setf *gc-inhibit* t)    #-gengc (setf *already-maybe-gcing* t)
333    (setf *need-to-collect-garbage* nil)    #-gengc (setf *gc-inhibit* t)
334    (setf *gc-verbose* t)    #-gengc (setf *need-to-collect-garbage* nil)
335      (setf *gc-verbose* #-gengc t #+gengc nil)
336    (setf *before-gc-hooks* nil)    (setf *before-gc-hooks* nil)
337    (setf *after-gc-hooks* nil)    (setf *after-gc-hooks* nil)
338    (setf unix::*interrupts-enabled* t)    #-gengc (setf unix::*interrupts-enabled* t)
339    (setf unix::*interrupt-pending* nil)    #-gengc (setf unix::*interrupt-pending* nil)
340    (setf *type-system-initialized* nil)    (setf *type-system-initialized* nil)
341    (%primitive print "In initial-function, and running.")    (setf *break-on-signals* nil)
342      (setf unix::*filename-encoding* nil)
343      #+gengc (setf conditions::*handler-clusters* nil)
344      (setq intl::*default-domain* "cmucl")
345      (setq intl::*locale* "C")
346    
347    ;; Many top-level forms call INFO, (SETF INFO).    ;; Many top-level forms call INFO, (SETF INFO).
348    (print-and-call c::globaldb-init)    (print-and-call c::globaldb-init)
# Line 102  Line 353 
353    ;; Some of the random top-level forms call Make-Array, which calls Subtypep    ;; Some of the random top-level forms call Make-Array, which calls Subtypep
354    (print-and-call typedef-init)    (print-and-call typedef-init)
355    (print-and-call class-init)    (print-and-call class-init)
356    
357    (print-and-call type-init)    (print-and-call type-init)
358    
359    (let ((funs (nreverse *lisp-initialization-functions*)))    (let ((funs (nreverse *lisp-initialization-functions*)))
360      (%primitive print "Calling top-level forms.")      (%primitive print "Calling top-level forms.")
361        #+nil (%primitive print (length funs))
362      (dolist (fun funs)      (dolist (fun funs)
363          #+nil (%primitive print fun)
364        (typecase fun        (typecase fun
365          (function          (function
366           (funcall fun))           (funcall fun))
# Line 116  Line 370 
370              (setf (svref *load-time-values* (third fun))              (setf (svref *load-time-values* (third fun))
371                    (funcall (second fun))))                    (funcall (second fun))))
372             (:load-time-value-fixup             (:load-time-value-fixup
373              (setf (sap-ref-32 (second fun) 0)              #-gengc
374                (setf (#+amd64 sap-ref-64
375                       #-amd64 sap-ref-32 (second fun) 0)
376                    (get-lisp-obj-address                    (get-lisp-obj-address
377                     (svref *load-time-values* (third fun)))))                     (svref *load-time-values* (third fun))))
378                #+gengc
379                (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))
380               #+(and (or x86 amd64) gencgc)
381               (:load-time-code-fixup
382                (vm::do-load-time-code-fixup (second fun) (third fun) (fourth fun)
383                                             (fifth fun)))
384             (t             (t
385              (%primitive print              (%primitive print
386                          "Bogus fixup in *lisp-initialization-functions*")                          "Bogus fixup in *lisp-initialization-functions*")
# Line 138  Line 400 
400    (print-and-call filesys-init)    (print-and-call filesys-init)
401    
402    (print-and-call reader-init)    (print-and-call reader-init)
403    (print-and-call backq-init)    ;; Note: sharpm and backq not yet loaded, so this is not the final RT.
   (print-and-call sharp-init)  
   ;; After the various reader subsystems have done their thing to the standard  
   ;; readtable, copy it to *readtable*.  
404    (setf *readtable* (copy-readtable std-lisp-readtable))    (setf *readtable* (copy-readtable std-lisp-readtable))
405    
406    (print-and-call stream-init)    (print-and-call stream-init)
407    (print-and-call loader-init)    (print-and-call loader-init)
408    (print-and-call package-init)    (print-and-call package-init)
409    (print-and-call kernel::signal-init)    (print-and-call kernel::signal-init)
410    (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)    (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
411    (set-floating-point-modes :traps '(:overflow :underflow :invalid  
412                                                 :divide-by-zero))    (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero))
413    
414    ;; This is necessary because some of the initial top level forms might    ;; This is necessary because some of the initial top level forms might
415    ;; have changed the compliation policy in strange ways.    ;; have changed the compilation policy in strange ways.
416    (print-and-call c::proclaim-init)    (print-and-call c::proclaim-init)
417    
418    (print-and-call kernel::class-finalize)    (print-and-call kernel::class-finalize)
419    
420      (setq intl::*default-domain* nil)
421    (%primitive print "Done initializing.")    (%primitive print "Done initializing.")
422    
423    (setf *already-maybe-gcing* nil)    #-gengc (setf *already-maybe-gcing* nil)
424      #+gengc (setf *gc-verbose* t)
425    (terpri)    (terpri)
426    (princ "CMU Common Lisp kernel core image ")    (princ "CMU Common Lisp kernel core image ")
427    (princ (lisp-implementation-version))    (princ (lisp-implementation-version))
# Line 167  Line 429 
429    (terpri)    (terpri)
430    (princ "[You are in the LISP package.]")    (princ "[You are in the LISP package.]")
431    (terpri)    (terpri)
432    (catch '%end-of-the-world    (let ((wot (catch '%end-of-the-world
433      (loop                 (loop
434       (%top-level)                   (%top-level)
435       (write-line "You're certainly a clever child.")))                   (write-line "You're certainly a clever child.")))))
436    (unix:unix-exit 0))      (unix:unix-exit wot)))
437    
438    #+gengc
439    (defun do-load-time-value-fixup (object offset index)
440      (declare (type index offset))
441      (macrolet ((lose (msg)
442                   `(progn
443                      (%primitive print ,msg)
444                      (%halt))))
445        (let ((value (svref *load-time-values* index)))
446          (typecase object
447            (list
448             (case offset
449               (0 (setf (car object) value))
450               (1 (setf (cdr object) value))
451               (t (lose "Bogus offset in cons cell."))))
452            (instance
453             (setf (%instance-ref object (- offset vm:instance-slots-offset))
454                   value))
455            (code-component
456             (setf (code-header-ref object offset) value))
457            (simple-vector
458             (setf (svref object (- offset vm:vector-data-offset)) value))
459            (t
460             (lose "Unknown kind of object for load-time-value fixup."))))))
461    
462    
463  ;;;; Initialization functions:  ;;;; Initialization functions:
464    
465    ;;; Print seems to not like x86 NPX denormal floats like
466    ;;; least-negative-single-float, so the :underflow exceptions
467    ;;; is disabled by default. Joe User can explicitly enable them
468    ;;; if desired.
469    
470  (defun reinit ()  (defun reinit ()
471    (without-interrupts    (without-interrupts
472     (without-gcing     (without-gcing
# Line 183  Line 474 
474      (stream-reinit)      (stream-reinit)
475      (kernel::signal-init)      (kernel::signal-init)
476      (gc-init)      (gc-init)
477      (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)      (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
478      (set-floating-point-modes :traps      (set-floating-point-modes :traps
479                                '(:overflow :underflow :invalid                                '(:overflow :invalid :divide-by-zero))
480                                            :divide-by-zero)))))      ;; Clear pseudo atomic in case this core wasn't compiled with support.
481        #+(or x86 amd64) (setf lisp::*pseudo-atomic-atomic* 0))))
482    
483    
484  ;;;; Miscellaneous external functions:  ;;;; Miscellaneous external functions:
485    
486    (defvar *cleanup-functions* nil
487      "Functions to be invoked during cleanup at Lisp exit.")
488    
489  ;;; Quit gets us out, one way or another.  ;;; Quit gets us out, one way or another.
490    
491  (defun quit (&optional recklessly-p)  (defun quit (&optional recklessly-p)
# Line 199  Line 493 
493    non-Nil."    non-Nil."
494    (if recklessly-p    (if recklessly-p
495        (unix:unix-exit 0)        (unix:unix-exit 0)
496        (throw '%end-of-the-world nil)))        (progn
497            (mapc (lambda (fn) (ignore-errors (funcall fn))) *cleanup-functions*)
498            (throw '%end-of-the-world 0))))
499    
500    
501    #-mp ; Multi-processing version defined in multi-proc.lisp.
502  (defun sleep (n)  (defun sleep (n)
503    "This function causes execution to be suspended for N seconds.  N may    _N"This function causes execution to be suspended for N seconds.  N may
504    be any non-negative, non-complex number."    be any non-negative, non-complex number."
505    (when (or (not (realp n))    (when (or (not (realp n))
506              (minusp n))              (minusp n))
507      (error "Invalid argument to SLEEP: ~S.~%~      (error 'simple-type-error
508               :format-control
509               "Invalid argument to SLEEP: ~S.~%~
510              Must be a non-negative, non-complex number."              Must be a non-negative, non-complex number."
511             n))             :format-arguments (list n)
512               :datum n
513               :expected-type '(real 0)))
514    (multiple-value-bind (sec usec)    (multiple-value-bind (sec usec)
515                         (if (integerp n)      (if (integerp n)
516                             (values n 0)          (values n 0)
517                             (values (truncate n)          (multiple-value-bind (sec frac) (truncate n)
518                                     (truncate (* n 1000000))))            (values sec (truncate frac 1e-6))))
519      (unix:unix-select 0 0 0 0 sec usec))      (unix:unix-select 0 0 0 0 sec usec))
520    nil)    nil)
   
521    
522  ;;;; SCRUB-CONTROL-STACK  ;;;; SCRUB-CONTROL-STACK
523    
524    #+stack-checking
525    (alien:def-alien-routine "os_guard_control_stack" c-call:void
526      (zone   c-call:int)
527      (guardp c-call:int))
528    
529    
530  (defconstant bytes-per-scrub-unit 2048)  (defconstant bytes-per-scrub-unit 2048)
531    
532  (defun scrub-control-stack ()  ;;; Scrub-control-stack.
533    "Zero the unused portion of the control stack so that old objects are not  ;;;
534    #-(or x86 amd64)
535    (defun %scrub-control-stack ()
536      _N"Zero the unused portion of the control stack so that old objects are not
537     kept alive because of uninitialized stack variables."     kept alive because of uninitialized stack variables."
538    (declare (optimize (speed 3) (safety 0))    (declare (optimize (speed 3) (safety 0))
539             (values (unsigned-byte 20)))             (values (unsigned-byte 20)))
# Line 258  Line 566 
566               (* (floor initial-offset vm:word-bytes) vm:word-bytes)               (* (floor initial-offset vm:word-bytes) vm:word-bytes)
567               0))))               0))))
568    
569    ;;; Scrub-control-stack.
570    ;;;
571    ;;; On the x86 and amd64 port the stack grows downwards, and to support grow on
572    ;;; demand stacks the stack must be decreased as it is scrubbed.
573    ;;;
574    (defun scrub-control-stack ()
575      "Zero the unused portion of the control stack so that old objects are not
576       kept alive because of uninitialized stack variables."
577      ;;
578      ;; The guard zone of the control stack is used by Lisp sometimes,
579      ;; so I think it should be zero'd out, too.
580      #+stack-checking (os-guard-control-stack 0 0)
581      (%scrub-control-stack)
582      #+stack-checking (os-guard-control-stack 0 1))
583    
584    #+(or x86 amd64)
585    (defun %scrub-control-stack ()
586      (%scrub-control-stack))
587    
588    
589  ;;;; TOP-LEVEL loop.  ;;;; TOP-LEVEL loop.
# Line 283  Line 609 
609  (defun interactive-eval (form)  (defun interactive-eval (form)
610    "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,    "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
611    +, ///, //, /, and -."    +, ///, //, /, and -."
612      (when (and (fboundp 'commandp) (funcall 'commandp form))
613        (return-from interactive-eval (funcall 'invoke-command-interactive form)))
614    (setf - form)    (setf - form)
615    (let ((results (multiple-value-list (eval form))))    (let ((results (multiple-value-list (eval form))))
616        (finish-standard-output-streams)
617      (setf /// //      (setf /// //
618            // /            // /
619            / results            / results
# Line 297  Line 626 
626    (unless (boundp '*)    (unless (boundp '*)
627      ;; The bogon returned an unbound marker.      ;; The bogon returned an unbound marker.
628      (setf * nil)      (setf * nil)
629      (cerror "Go on with * set to NIL."      (cerror (intl:gettext "Go on with * set to NIL.")
630              "EVAL returned an unbound marker."))              (intl:gettext "EVAL returned an unbound marker.")))
631    (values-list /))    (values-list /))
632    
633    
634  (defconstant eofs-before-quit 10)  (defconstant eofs-before-quit 10)
635    
636    (defparameter *reserved-heap-pages* 256
637      "How many pages to reserve from the total heap space so we can handle
638    heap overflow.")
639    
640    #+heap-overflow-check
641    (alien:def-alien-variable "reserved_heap_pages" c-call:unsigned-long)
642    
643  (defun %top-level ()  (defun %top-level ()
644    "Top-level READ-EVAL-PRINT loop.  Do not call this."    "Top-level READ-EVAL-PRINT loop.  Do not call this."
645    (let  ((* nil) (** nil) (*** nil)    (let  ((* nil) (** nil) (*** nil)
# Line 312  Line 648 
648           (magic-eof-cookie (cons :eof nil))           (magic-eof-cookie (cons :eof nil))
649           (number-of-eofs 0))           (number-of-eofs 0))
650      (loop      (loop
651        (with-simple-restart (abort "Return to Top-Level.")        (with-simple-restart (abort (intl:gettext "Return to Top-Level."))
652          (catch 'top-level-catcher          (catch 'top-level-catcher
653            (unix:unix-sigsetmask 0)            (unix:unix-sigsetmask 0)
654            (let ((*in-top-level-catcher* t))            (let ((*in-top-level-catcher* t))
655              (loop              (loop
656                (scrub-control-stack)                (scrub-control-stack)
657                (fresh-line)                (fresh-line)
658                  ;; Reset reserved pages in the heap
659                  #+heap-overflow-check (setf reserved-heap-pages *reserved-heap-pages*)
660                (princ (if (functionp *prompt*)                (princ (if (functionp *prompt*)
661                           (funcall *prompt*)                           (funcall *prompt*)
662                           *prompt*))                           *prompt*))
# Line 332  Line 670 
670                             (prin1 result)))                             (prin1 result)))
671                         (setf number-of-eofs 0))                         (setf number-of-eofs 0))
672                        ((eql (incf number-of-eofs) 1)                        ((eql (incf number-of-eofs) 1)
673                         (let ((stream (make-synonym-stream '*terminal-io*)))                         (if *batch-mode*
674                           (setf *standard-input* stream)                             (quit)
675                           (setf *standard-output* stream)                             (let ((stream (make-synonym-stream '*terminal-io*)))
676                           (format t "~&Received EOF on *standard-input*, ~                               (setf *standard-input* stream)
677                                      switching to *terminal-io*.~%")))                               (setf *standard-output* stream)
678                                 (format t (intl:gettext "~&Received EOF on *standard-input*, ~
679                                            switching to *terminal-io*.~%")))))
680                        ((> number-of-eofs eofs-before-quit)                        ((> number-of-eofs eofs-before-quit)
681                         (format t "~&Received more than ~D EOFs; Aborting.~%"                         (format t (intl:gettext "~&Received more than ~D EOFs; Aborting.~%")
682                                 eofs-before-quit)                                 eofs-before-quit)
683                         (quit))                         (quit))
684                        (t                        (t
685                         (format t "~&Received EOF.~%")))))))))))                         (format t (intl:gettext "~&Received EOF.~%"))))))))))))
   
686    
687    
688  ;;; %Halt  --  Interface  ;;; %Halt  --  Interface

Legend:
Removed from v.1.33.1.2  
changed lines
  Added in v.1.82

  ViewVC Help
Powered by ViewVC 1.1.5