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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33.1.2 - (hide annotations) (vendor branch)
Sun Feb 21 16:27:10 1993 UTC (21 years, 1 month ago) by ram
Branch: new_struct
Changes since 1.33.1.1: +3 -1 lines
Added call to CLASS-FINALIZE after all top-level forms & other 
initializations.
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     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 ram 1.33.1.2 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/lispinit.lisp,v 1.33.1.2 1993/02/21 16:27:10 ram Exp $")
11 ram 1.20 ;;;
12 ram 1.1 ;;; **********************************************************************
13 wlott 1.10 ;;;
14 wlott 1.14 ;;; Initialization stuff for CMU Common Lisp, plus some other random functions
15     ;;; that we don't have any better place for.
16     ;;;
17 ram 1.1 ;;; Written by Skef Wholey and Rob MacLachlan.
18     ;;;
19     (in-package "LISP" :use '("SYSTEM" "DEBUG"))
20    
21     (export '(most-positive-fixnum most-negative-fixnum sleep
22 wlott 1.33 ++ +++ ** *** // ///))
23 ram 1.1
24 ram 1.4 (in-package "SYSTEM" :nicknames '("SYS"))
25 wlott 1.33 (export '(compiler-version scrub-control-stack))
26 ram 1.1
27     (in-package "EXTENSIONS")
28 wlott 1.33 (export '(quit *prompt*))
29 ram 1.1
30     (in-package "LISP")
31    
32     ;;; Make the error system enable interrupts.
33    
34 wlott 1.10 (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum
35 ram 1.1 "The fixnum closest in value to positive infinity.")
36    
37 wlott 1.10 (defconstant most-negative-fixnum #.vm:target-most-negative-fixnum
38 ram 1.1 "The fixnum closest in value to negative infinity.")
39    
40    
41     ;;; Random information:
42    
43 wlott 1.10 (defvar *lisp-implementation-version* "4.0(?)")
44 ram 1.1
45    
46 ram 1.5 ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs...
47     (proclaim '(special *gc-inhibit* *already-maybe-gcing*
48 ram 1.6 *need-to-collect-garbage* *gc-verbose*
49 ram 1.7 *before-gc-hooks* *after-gc-hooks*
50 wlott 1.28 unix::*interrupts-enabled*
51     unix::*interrupt-pending*
52 ram 1.33.1.1 *type-system-initialized*))
53 ram 1.1
54    
55 wlott 1.10 ;;;; Random magic specials.
56 ram 1.1
57    
58 wlott 1.10 ;;; These are filled in by Genesis.
59 ram 1.1
60 wlott 1.10 (defvar *current-catch-block*)
61     (defvar *current-unwind-block*)
62     (defvar *free-interrupt-context-index*)
63 ram 1.1
64    
65 wlott 1.10
66 ram 1.1 ;;; %Initial-Function is called when a cold system starts up. First we zoom
67     ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
68     ;;; at "load time." Then we initialize the various subsystems and call the
69     ;;; read-eval-print loop. The top-level Read-Eval-Print loop is executed until
70     ;;; someone (most likely the Quit function) throws to the tag
71     ;;; %End-Of-The-World. We quit this way so that all outstanding cleanup forms
72     ;;; in Unwind-Protects will get executed.
73    
74 wlott 1.26 (proclaim '(special *lisp-initialization-functions*
75     *load-time-values*))
76 ram 1.1
77     (eval-when (compile)
78     (defmacro print-and-call (name)
79     `(progn
80 wlott 1.10 (%primitive print ,(symbol-name name))
81 ram 1.1 (,name))))
82    
83     (defun %initial-function ()
84     "Gives the world a shove and hopes it spins."
85 wlott 1.12 (setf *already-maybe-gcing* t)
86 ram 1.2 (setf *gc-inhibit* t)
87 ram 1.1 (setf *need-to-collect-garbage* nil)
88 wlott 1.12 (setf *gc-verbose* t)
89     (setf *before-gc-hooks* nil)
90     (setf *after-gc-hooks* nil)
91 wlott 1.28 (setf unix::*interrupts-enabled* t)
92     (setf unix::*interrupt-pending* nil)
93 ram 1.33.1.1 (setf *type-system-initialized* nil)
94 ram 1.1 (%primitive print "In initial-function, and running.")
95    
96     ;; Many top-level forms call INFO, (SETF INFO).
97     (print-and-call c::globaldb-init)
98    
99 wlott 1.32 ;; Set up the fdefn database.
100     (print-and-call fdefn-init)
101    
102     ;; Some of the random top-level forms call Make-Array, which calls Subtypep
103 ram 1.33.1.1 (print-and-call typedef-init)
104     (print-and-call class-init)
105 wlott 1.10 (print-and-call type-init)
106 ram 1.1
107 wlott 1.26 (let ((funs (nreverse *lisp-initialization-functions*)))
108     (%primitive print "Calling top-level forms.")
109     (dolist (fun funs)
110     (typecase fun
111     (function
112     (funcall fun))
113     (cons
114     (case (car fun)
115     (:load-time-value
116     (setf (svref *load-time-values* (third fun))
117     (funcall (second fun))))
118     (:load-time-value-fixup
119     (setf (sap-ref-32 (second fun) 0)
120     (get-lisp-obj-address
121     (svref *load-time-values* (third fun)))))
122     (t
123     (%primitive print
124     "Bogus fixup in *lisp-initialization-functions*")
125     (%halt))))
126     (t
127     (%primitive print
128     "Bogus function in *lisp-initialization-functions*")
129     (%halt)))))
130 ram 1.1 (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
131 wlott 1.26 (makunbound '*load-time-values*)
132 ram 1.1
133 wlott 1.10 ;; Only do this after top level forms have run, 'cause thats where
134     ;; deftypes are.
135 ram 1.33.1.1 (setf *type-system-initialized* t)
136 wlott 1.10
137 ram 1.1 (print-and-call os-init)
138     (print-and-call filesys-init)
139    
140     (print-and-call reader-init)
141     (print-and-call backq-init)
142     (print-and-call sharp-init)
143     ;; After the various reader subsystems have done their thing to the standard
144     ;; readtable, copy it to *readtable*.
145 wlott 1.12 (setf *readtable* (copy-readtable std-lisp-readtable))
146 ram 1.1
147     (print-and-call stream-init)
148 wlott 1.10 (print-and-call loader-init)
149 ram 1.1 (print-and-call package-init)
150 wlott 1.16 (print-and-call kernel::signal-init)
151 wlott 1.28 (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
152 ram 1.17 (set-floating-point-modes :traps '(:overflow :underflow :invalid
153     :divide-by-zero))
154 wlott 1.29 ;; This is necessary because some of the initial top level forms might
155     ;; have changed the compliation policy in strange ways.
156     (print-and-call c::proclaim-init)
157 ram 1.33.1.2
158     (print-and-call kernel::class-finalize)
159 ram 1.1
160 wlott 1.10 (%primitive print "Done initializing.")
161    
162 wlott 1.12 (setf *already-maybe-gcing* nil)
163 ram 1.1 (terpri)
164     (princ "CMU Common Lisp kernel core image ")
165     (princ (lisp-implementation-version))
166     (princ ".")
167     (terpri)
168     (princ "[You are in the LISP package.]")
169     (terpri)
170     (catch '%end-of-the-world
171     (loop
172     (%top-level)
173     (write-line "You're certainly a clever child.")))
174 wlott 1.28 (unix:unix-exit 0))
175 ram 1.1
176    
177     ;;;; Initialization functions:
178    
179     (defun reinit ()
180     (without-interrupts
181 wlott 1.33 (without-gcing
182     (os-init)
183     (stream-reinit)
184     (kernel::signal-init)
185     (gc-init)
186     (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
187     (set-floating-point-modes :traps
188     '(:overflow :underflow :invalid
189     :divide-by-zero)))))
190 ram 1.1
191    
192    
193     ;;;; Miscellaneous external functions:
194    
195     ;;; Quit gets us out, one way or another.
196    
197     (defun quit (&optional recklessly-p)
198     "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
199     non-Nil."
200     (if recklessly-p
201 wlott 1.28 (unix:unix-exit 0)
202 ram 1.1 (throw '%end-of-the-world nil)))
203    
204    
205     (defun sleep (n)
206     "This function causes execution to be suspended for N seconds. N may
207     be any non-negative, non-complex number."
208 wlott 1.13 (when (or (not (realp n))
209     (minusp n))
210     (error "Invalid argument to SLEEP: ~S.~%~
211     Must be a non-negative, non-complex number."
212     n))
213     (multiple-value-bind (sec usec)
214     (if (integerp n)
215     (values n 0)
216     (values (truncate n)
217     (truncate (* n 1000000))))
218 wlott 1.28 (unix:unix-select 0 0 0 0 sec usec))
219 ram 1.1 nil)
220    
221    
222 wlott 1.25 ;;;; SCRUB-CONTROL-STACK
223    
224    
225 wlott 1.30 (defconstant bytes-per-scrub-unit 2048)
226 wlott 1.25
227     (defun scrub-control-stack ()
228     "Zero the unused portion of the control stack so that old objects are not
229     kept alive because of uninitialized stack variables."
230     (declare (optimize (speed 3) (safety 0))
231     (values (unsigned-byte 20)))
232     (labels
233     ((scrub (ptr offset count)
234     (declare (type system-area-pointer ptr)
235     (type (unsigned-byte 16) offset)
236     (type (unsigned-byte 20) count)
237     (values (unsigned-byte 20)))
238 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
239     (look (sap+ ptr bytes-per-scrub-unit) 0 count))
240 wlott 1.25 (t
241     (setf (sap-ref-32 ptr offset) 0)
242 wlott 1.30 (scrub ptr (+ offset vm:word-bytes) count))))
243 wlott 1.25 (look (ptr offset count)
244     (declare (type system-area-pointer ptr)
245     (type (unsigned-byte 16) offset)
246     (type (unsigned-byte 20) count)
247     (values (unsigned-byte 20)))
248 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
249 wlott 1.25 count)
250     ((zerop (sap-ref-32 ptr offset))
251 wlott 1.30 (look ptr (+ offset vm:word-bytes) count))
252 wlott 1.25 (t
253 wlott 1.30 (scrub ptr offset (+ count vm:word-bytes))))))
254 wlott 1.25 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
255 wlott 1.30 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
256 wlott 1.25 (declare (type (unsigned-byte 32) csp))
257     (scrub (int-sap (- csp initial-offset))
258 wlott 1.30 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
259 wlott 1.25 0))))
260    
261    
262    
263 ram 1.1 ;;;; TOP-LEVEL loop.
264    
265     (defvar / nil
266     "Holds a list of all the values returned by the most recent top-level EVAL.")
267     (defvar // nil "Gets the previous value of / when a new value is computed.")
268     (defvar /// nil "Gets the previous value of // when a new value is computed.")
269     (defvar * nil "Holds the value of the most recent top-level EVAL.")
270     (defvar ** nil "Gets the previous value of * when a new value is computed.")
271     (defvar *** nil "Gets the previous value of ** when a new value is computed.")
272     (defvar + nil "Holds the value of the most recent top-level READ.")
273     (defvar ++ nil "Gets the previous value of + when a new value is read.")
274     (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
275     (defvar - nil "Holds the form curently being evaluated.")
276 ram 1.3 (defvar *prompt* "* "
277     "The top-level prompt string. This also may be a function of no arguments
278     that returns a simple-string.")
279 ram 1.1 (defvar *in-top-level-catcher* nil
280     "True if we are within the Top-Level-Catcher. This is used by interrupt
281     handlers to see whether it is o.k. to throw.")
282    
283 ram 1.3 (defun interactive-eval (form)
284     "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
285     +, ///, //, /, and -."
286 ram 1.21 (setf - form)
287 ram 1.3 (let ((results (multiple-value-list (eval form))))
288     (setf /// //
289     // /
290     / results
291     *** **
292     ** *
293     * (car results)))
294 ram 1.21 (setf +++ ++
295     ++ +
296     + -)
297 ram 1.3 (unless (boundp '*)
298     ;; The bogon returned an unbound marker.
299     (setf * nil)
300     (cerror "Go on with * set to NIL."
301     "EVAL returned an unbound marker."))
302     (values-list /))
303 ram 1.21
304 ram 1.3
305     (defconstant eofs-before-quit 10)
306    
307 ram 1.1 (defun %top-level ()
308     "Top-level READ-EVAL-PRINT loop. Do not call this."
309 ram 1.3 (let ((* nil) (** nil) (*** nil)
310 ram 1.1 (- nil) (+ nil) (++ nil) (+++ nil)
311 ram 1.3 (/// nil) (// nil) (/ nil)
312     (magic-eof-cookie (cons :eof nil))
313     (number-of-eofs 0))
314 ram 1.1 (loop
315 wlott 1.25 (with-simple-restart (abort "Return to Top-Level.")
316     (catch 'top-level-catcher
317 wlott 1.28 (unix:unix-sigsetmask 0)
318 wlott 1.25 (let ((*in-top-level-catcher* t))
319     (loop
320     (scrub-control-stack)
321     (fresh-line)
322     (princ (if (functionp *prompt*)
323     (funcall *prompt*)
324     *prompt*))
325     (force-output)
326     (let ((form (read *standard-input* nil magic-eof-cookie)))
327     (cond ((not (eq form magic-eof-cookie))
328     (let ((results
329     (multiple-value-list (interactive-eval form))))
330     (dolist (result results)
331     (fresh-line)
332     (prin1 result)))
333     (setf number-of-eofs 0))
334     ((eql (incf number-of-eofs) 1)
335     (let ((stream (make-synonym-stream '*terminal-io*)))
336     (setf *standard-input* stream)
337     (setf *standard-output* stream)
338     (format t "~&Received EOF on *standard-input*, ~
339     switching to *terminal-io*.~%")))
340     ((> number-of-eofs eofs-before-quit)
341     (format t "~&Received more than ~D EOFs; Aborting.~%"
342     eofs-before-quit)
343     (quit))
344     (t
345     (format t "~&Received EOF.~%")))))))))))
346 ram 1.1
347    
348 ram 1.3
349 ram 1.1 ;;; %Halt -- Interface
350     ;;;
351     ;;; A convenient way to get into the assembly level debugger.
352     ;;;
353     (defun %halt ()
354     (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5