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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5