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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (hide annotations)
Sun Apr 12 00:24:12 1992 UTC (22 years ago) by wlott
Branch: MAIN
Branch point for: new_struct
Changes since 1.32: +13 -418 lines
Moved lots of exports into the files that contain the thing being
exported.  Moved the object-set stuff into serve-event.lisp.
Added a call to GC-INIT to REINIT to facilitate making sure set-auto-gc-
trigger gets called.
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 wlott 1.33 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/lispinit.lisp,v 1.33 1992/04/12 00:24:12 wlott 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.7 c::*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 wlott 1.12 (setf c::*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 wlott 1.10 (print-and-call type-init)
104 ram 1.1
105 wlott 1.26 (let ((funs (nreverse *lisp-initialization-functions*)))
106     (%primitive print "Calling top-level forms.")
107     (dolist (fun funs)
108     (typecase fun
109     (function
110     (funcall fun))
111     (cons
112     (case (car fun)
113     (:load-time-value
114     (setf (svref *load-time-values* (third fun))
115     (funcall (second fun))))
116     (:load-time-value-fixup
117     (setf (sap-ref-32 (second fun) 0)
118     (get-lisp-obj-address
119     (svref *load-time-values* (third fun)))))
120     (t
121     (%primitive print
122     "Bogus fixup in *lisp-initialization-functions*")
123     (%halt))))
124     (t
125     (%primitive print
126     "Bogus function in *lisp-initialization-functions*")
127     (%halt)))))
128 ram 1.1 (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
129 wlott 1.26 (makunbound '*load-time-values*)
130 ram 1.1
131 wlott 1.10 ;; Only do this after top level forms have run, 'cause thats where
132     ;; deftypes are.
133 wlott 1.12 (setf c::*type-system-initialized* t)
134 wlott 1.10
135 ram 1.1 (print-and-call os-init)
136     (print-and-call filesys-init)
137    
138     (print-and-call reader-init)
139     (print-and-call backq-init)
140     (print-and-call sharp-init)
141     ;; After the various reader subsystems have done their thing to the standard
142     ;; readtable, copy it to *readtable*.
143 wlott 1.12 (setf *readtable* (copy-readtable std-lisp-readtable))
144 ram 1.1
145     (print-and-call stream-init)
146 wlott 1.10 (print-and-call loader-init)
147 ram 1.1 (print-and-call package-init)
148 wlott 1.16 (print-and-call kernel::signal-init)
149 wlott 1.28 (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
150 ram 1.17 (set-floating-point-modes :traps '(:overflow :underflow :invalid
151     :divide-by-zero))
152 wlott 1.29 ;; This is necessary because some of the initial top level forms might
153     ;; have changed the compliation policy in strange ways.
154     (print-and-call c::proclaim-init)
155 ram 1.1
156 wlott 1.10 (%primitive print "Done initializing.")
157    
158 wlott 1.12 (setf *already-maybe-gcing* nil)
159 ram 1.1 (terpri)
160     (princ "CMU Common Lisp kernel core image ")
161     (princ (lisp-implementation-version))
162     (princ ".")
163     (terpri)
164     (princ "[You are in the LISP package.]")
165     (terpri)
166     (catch '%end-of-the-world
167     (loop
168     (%top-level)
169     (write-line "You're certainly a clever child.")))
170 wlott 1.28 (unix:unix-exit 0))
171 ram 1.1
172    
173     ;;;; Initialization functions:
174    
175     (defun reinit ()
176     (without-interrupts
177 wlott 1.33 (without-gcing
178     (os-init)
179     (stream-reinit)
180     (kernel::signal-init)
181     (gc-init)
182     (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
183     (set-floating-point-modes :traps
184     '(:overflow :underflow :invalid
185     :divide-by-zero)))))
186 ram 1.1
187    
188    
189     ;;;; Miscellaneous external functions:
190    
191     ;;; Quit gets us out, one way or another.
192    
193     (defun quit (&optional recklessly-p)
194     "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
195     non-Nil."
196     (if recklessly-p
197 wlott 1.28 (unix:unix-exit 0)
198 ram 1.1 (throw '%end-of-the-world nil)))
199    
200    
201     (defun sleep (n)
202     "This function causes execution to be suspended for N seconds. N may
203     be any non-negative, non-complex number."
204 wlott 1.13 (when (or (not (realp n))
205     (minusp n))
206     (error "Invalid argument to SLEEP: ~S.~%~
207     Must be a non-negative, non-complex number."
208     n))
209     (multiple-value-bind (sec usec)
210     (if (integerp n)
211     (values n 0)
212     (values (truncate n)
213     (truncate (* n 1000000))))
214 wlott 1.28 (unix:unix-select 0 0 0 0 sec usec))
215 ram 1.1 nil)
216    
217    
218 wlott 1.25 ;;;; SCRUB-CONTROL-STACK
219    
220    
221 wlott 1.30 (defconstant bytes-per-scrub-unit 2048)
222 wlott 1.25
223     (defun scrub-control-stack ()
224     "Zero the unused portion of the control stack so that old objects are not
225     kept alive because of uninitialized stack variables."
226     (declare (optimize (speed 3) (safety 0))
227     (values (unsigned-byte 20)))
228     (labels
229     ((scrub (ptr offset count)
230     (declare (type system-area-pointer ptr)
231     (type (unsigned-byte 16) offset)
232     (type (unsigned-byte 20) count)
233     (values (unsigned-byte 20)))
234 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
235     (look (sap+ ptr bytes-per-scrub-unit) 0 count))
236 wlott 1.25 (t
237     (setf (sap-ref-32 ptr offset) 0)
238 wlott 1.30 (scrub ptr (+ offset vm:word-bytes) count))))
239 wlott 1.25 (look (ptr offset count)
240     (declare (type system-area-pointer ptr)
241     (type (unsigned-byte 16) offset)
242     (type (unsigned-byte 20) count)
243     (values (unsigned-byte 20)))
244 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
245 wlott 1.25 count)
246     ((zerop (sap-ref-32 ptr offset))
247 wlott 1.30 (look ptr (+ offset vm:word-bytes) count))
248 wlott 1.25 (t
249 wlott 1.30 (scrub ptr offset (+ count vm:word-bytes))))))
250 wlott 1.25 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
251 wlott 1.30 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
252 wlott 1.25 (declare (type (unsigned-byte 32) csp))
253     (scrub (int-sap (- csp initial-offset))
254 wlott 1.30 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
255 wlott 1.25 0))))
256    
257    
258    
259 ram 1.1 ;;;; TOP-LEVEL loop.
260    
261     (defvar / nil
262     "Holds a list of all the values returned by the most recent top-level EVAL.")
263     (defvar // nil "Gets the previous value of / when a new value is computed.")
264     (defvar /// nil "Gets the previous value of // when a new value is computed.")
265     (defvar * nil "Holds the value of the most recent top-level EVAL.")
266     (defvar ** nil "Gets the previous value of * when a new value is computed.")
267     (defvar *** nil "Gets the previous value of ** when a new value is computed.")
268     (defvar + nil "Holds the value of the most recent top-level READ.")
269     (defvar ++ nil "Gets the previous value of + when a new value is read.")
270     (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
271     (defvar - nil "Holds the form curently being evaluated.")
272 ram 1.3 (defvar *prompt* "* "
273     "The top-level prompt string. This also may be a function of no arguments
274     that returns a simple-string.")
275 ram 1.1 (defvar *in-top-level-catcher* nil
276     "True if we are within the Top-Level-Catcher. This is used by interrupt
277     handlers to see whether it is o.k. to throw.")
278    
279 ram 1.3 (defun interactive-eval (form)
280     "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
281     +, ///, //, /, and -."
282 ram 1.21 (setf - form)
283 ram 1.3 (let ((results (multiple-value-list (eval form))))
284     (setf /// //
285     // /
286     / results
287     *** **
288     ** *
289     * (car results)))
290 ram 1.21 (setf +++ ++
291     ++ +
292     + -)
293 ram 1.3 (unless (boundp '*)
294     ;; The bogon returned an unbound marker.
295     (setf * nil)
296     (cerror "Go on with * set to NIL."
297     "EVAL returned an unbound marker."))
298     (values-list /))
299 ram 1.21
300 ram 1.3
301     (defconstant eofs-before-quit 10)
302    
303 ram 1.1 (defun %top-level ()
304     "Top-level READ-EVAL-PRINT loop. Do not call this."
305 ram 1.3 (let ((* nil) (** nil) (*** nil)
306 ram 1.1 (- nil) (+ nil) (++ nil) (+++ nil)
307 ram 1.3 (/// nil) (// nil) (/ nil)
308     (magic-eof-cookie (cons :eof nil))
309     (number-of-eofs 0))
310 ram 1.1 (loop
311 wlott 1.25 (with-simple-restart (abort "Return to Top-Level.")
312     (catch 'top-level-catcher
313 wlott 1.28 (unix:unix-sigsetmask 0)
314 wlott 1.25 (let ((*in-top-level-catcher* t))
315     (loop
316     (scrub-control-stack)
317     (fresh-line)
318     (princ (if (functionp *prompt*)
319     (funcall *prompt*)
320     *prompt*))
321     (force-output)
322     (let ((form (read *standard-input* nil magic-eof-cookie)))
323     (cond ((not (eq form magic-eof-cookie))
324     (let ((results
325     (multiple-value-list (interactive-eval form))))
326     (dolist (result results)
327     (fresh-line)
328     (prin1 result)))
329     (setf number-of-eofs 0))
330     ((eql (incf number-of-eofs) 1)
331     (let ((stream (make-synonym-stream '*terminal-io*)))
332     (setf *standard-input* stream)
333     (setf *standard-output* stream)
334     (format t "~&Received EOF on *standard-input*, ~
335     switching to *terminal-io*.~%")))
336     ((> number-of-eofs eofs-before-quit)
337     (format t "~&Received more than ~D EOFs; Aborting.~%"
338     eofs-before-quit)
339     (quit))
340     (t
341     (format t "~&Received EOF.~%")))))))))))
342 ram 1.1
343    
344 ram 1.3
345 ram 1.1 ;;; %Halt -- Interface
346     ;;;
347     ;;; A convenient way to get into the assembly level debugger.
348     ;;;
349     (defun %halt ()
350     (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5