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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5