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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.41 - (hide annotations)
Thu Aug 19 21:13:58 1993 UTC (20 years, 8 months ago) by ram
Branch: MAIN
Changes since 1.40: +2 -1 lines
Set *break-on-signals* in %initial-function, since we've moved the defvar.
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.41 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/lispinit.lisp,v 1.41 1993/08/19 21:13:58 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.39 ;;;; Random stuff that needs to be in the cold load which would otherwise be
76     ;;;; byte-compiled.
77     ;;;;
78     (defvar hi::*in-the-editor* nil)
79    
80     ;;;; Called by defmacro expanders...
81    
82     ;;; VERIFY-KEYWORDS -- internal
83     ;;;
84     ;;; Determine if key-list is a valid list of keyword/value pairs. Do not
85     ;;; signal the error directly, 'cause we don't know how it should be signaled.
86     ;;;
87     (defun verify-keywords (key-list valid-keys allow-other-keys)
88     (do ((already-processed nil)
89     (unknown-keyword nil)
90     (remaining key-list (cddr remaining)))
91     ((null remaining)
92     (if (and unknown-keyword
93     (not allow-other-keys)
94     (not (lookup-keyword :allow-other-keys key-list)))
95     (values :unknown-keyword (list unknown-keyword valid-keys))
96     (values nil nil)))
97     (cond ((not (and (consp remaining) (listp (cdr remaining))))
98     (return (values :dotted-list key-list)))
99     ((null (cdr remaining))
100     (return (values :odd-length key-list)))
101     ((member (car remaining) already-processed)
102     (return (values :duplicate (car remaining))))
103     ((or (eq (car remaining) :allow-other-keys)
104     (member (car remaining) valid-keys))
105     (push (car remaining) already-processed))
106     (t
107     (setf unknown-keyword (car remaining))))))
108    
109     (defun lookup-keyword (keyword key-list)
110     (do ((remaining key-list (cddr remaining)))
111     ((endp remaining))
112     (when (eq keyword (car remaining))
113     (return (cadr remaining)))))
114     ;;;
115     (defun keyword-supplied-p (keyword key-list)
116     (do ((remaining key-list (cddr remaining)))
117     ((endp remaining))
118     (when (eq keyword (car remaining))
119     (return t))))
120    
121 ram 1.40 (in-package "CONDITIONS")
122 ram 1.39
123     (defvar *break-on-signals* nil
124     "When (typep condition *break-on-signals*) is true, then calls to SIGNAL will
125     enter the debugger prior to signalling that condition.")
126    
127     (defun signal (datum &rest arguments)
128     "Invokes the signal facility on a condition formed from datum and arguments.
129     If the condition is not handled, nil is returned. If
130     (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked before
131     any signalling is done."
132     (let ((condition (coerce-to-condition datum arguments
133     'simple-condition 'signal))
134     (*handler-clusters* *handler-clusters*))
135     (when (typep condition *break-on-signals*)
136     (let ((*break-on-signals* nil))
137     (break "~A~%Break entered because of *break-on-signals* (now NIL.)"
138     condition)))
139     (loop
140     (unless *handler-clusters* (return))
141     (let ((cluster (pop *handler-clusters*)))
142     (dolist (handler cluster)
143     (when (typep condition (car handler))
144     (funcall (cdr handler) condition)))))
145     nil))
146    
147     ;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and
148     ;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a single
149     ;;; argument that's directly usable by all the other routines.
150     ;;;
151     (defun coerce-to-condition (datum arguments default-type function-name)
152     (cond ((typep datum 'condition)
153     (if arguments
154     (cerror "Ignore the additional arguments."
155     'simple-type-error
156     :datum arguments
157     :expected-type 'null
158     :format-control "You may not supply additional arguments ~
159     when giving ~S to ~S."
160     :format-arguments (list datum function-name)))
161     datum)
162     ((symbolp datum) ;Roughly, (subtypep datum 'condition).
163     (apply #'make-condition datum arguments))
164     ((or (stringp datum) (functionp datum))
165     (make-condition default-type
166     :format-control datum
167     :format-arguments arguments))
168     (t
169     (error 'simple-type-error
170     :datum datum
171     :expected-type '(or symbol string)
172     :format-control "Bad argument to ~S: ~S"
173     :format-arguments (list function-name datum)))))
174    
175     (defun error (datum &rest arguments)
176     "Invokes the signal facility on a condition formed from datum and arguments.
177     If the condition is not handled, the debugger is invoked."
178     (kernel:infinite-error-protect
179     (let ((condition (coerce-to-condition datum arguments
180     'simple-error 'error))
181     (debug:*stack-top-hint* debug:*stack-top-hint*))
182     (unless (and (error-function-name condition) debug:*stack-top-hint*)
183     (multiple-value-bind
184     (name frame)
185     (kernel:find-caller-name)
186     (unless (error-function-name condition)
187     (setf (error-function-name condition) name))
188     (unless debug:*stack-top-hint*
189     (setf debug:*stack-top-hint* frame))))
190     (let ((debug:*stack-top-hint* nil))
191     (signal condition))
192     (invoke-debugger condition))))
193    
194     ;;; CERROR must take care to not use arguments when datum is already a
195     ;;; condition object.
196     ;;;
197     (defun cerror (continue-string datum &rest arguments)
198     (kernel:infinite-error-protect
199     (with-simple-restart
200     (continue "~A" (apply #'format nil continue-string arguments))
201     (let ((condition (if (typep datum 'condition)
202     datum
203     (coerce-to-condition datum arguments
204     'simple-error 'error)))
205     (debug:*stack-top-hint* debug:*stack-top-hint*))
206     (unless (and (error-function-name condition) debug:*stack-top-hint*)
207     (multiple-value-bind
208     (name frame)
209     (kernel:find-caller-name)
210     (unless (error-function-name condition)
211     (setf (error-function-name condition) name))
212     (unless debug:*stack-top-hint*
213     (setf debug:*stack-top-hint* frame))))
214     (with-condition-restarts condition (list (find-restart 'continue))
215     (let ((debug:*stack-top-hint* nil))
216     (signal condition))
217     (invoke-debugger condition)))))
218     nil)
219    
220     (defun break (&optional (datum "Break") &rest arguments)
221     "Prints a message and invokes the debugger without allowing any possibility
222     of condition handling occurring."
223     (kernel:infinite-error-protect
224     (with-simple-restart (continue "Return from BREAK.")
225     (let ((debug:*stack-top-hint*
226     (or debug:*stack-top-hint*
227     (nth-value 1 (kernel:find-caller-name)))))
228     (invoke-debugger
229     (coerce-to-condition datum arguments 'simple-condition 'break)))))
230     nil)
231    
232     (defun warn (datum &rest arguments)
233     "Warns about a situation by signalling a condition formed by datum and
234     arguments. While the condition is being signaled, a muffle-warning restart
235     exists that causes WARN to immediately return nil."
236     (kernel:infinite-error-protect
237     (let ((condition (coerce-to-condition datum arguments
238     'simple-warning 'warn)))
239     (check-type condition warning "a warning condition")
240     (restart-case (signal condition)
241     (muffle-warning ()
242     :report "Skip warning."
243     (return-from warn nil)))
244     (format *error-output* "~&~@<Warning: ~3i~:_~A~:>~%" condition)))
245     nil)
246    
247     (in-package "LISP")
248    
249    
250 ram 1.1 ;;; %Initial-Function is called when a cold system starts up. First we zoom
251     ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
252     ;;; at "load time." Then we initialize the various subsystems and call the
253     ;;; read-eval-print loop. The top-level Read-Eval-Print loop is executed until
254     ;;; someone (most likely the Quit function) throws to the tag
255     ;;; %End-Of-The-World. We quit this way so that all outstanding cleanup forms
256     ;;; in Unwind-Protects will get executed.
257    
258 wlott 1.26 (proclaim '(special *lisp-initialization-functions*
259     *load-time-values*))
260 ram 1.1
261     (eval-when (compile)
262     (defmacro print-and-call (name)
263     `(progn
264 wlott 1.10 (%primitive print ,(symbol-name name))
265 ram 1.1 (,name))))
266    
267     (defun %initial-function ()
268     "Gives the world a shove and hopes it spins."
269 wlott 1.36 (%primitive print "In initial-function, and running.")
270 wlott 1.35 #-gengc (setf *already-maybe-gcing* t)
271     #-gengc (setf *gc-inhibit* t)
272     #-gengc (setf *need-to-collect-garbage* nil)
273     (setf *gc-verbose* #-gengc t #+gengc nil)
274 wlott 1.12 (setf *before-gc-hooks* nil)
275     (setf *after-gc-hooks* nil)
276 wlott 1.35 #-gengc (setf unix::*interrupts-enabled* t)
277     #-gengc (setf unix::*interrupt-pending* nil)
278 ram 1.34 (setf *type-system-initialized* nil)
279 ram 1.41 (setf *break-on-signals* nil)
280 ram 1.1
281     ;; Many top-level forms call INFO, (SETF INFO).
282     (print-and-call c::globaldb-init)
283    
284 wlott 1.32 ;; Set up the fdefn database.
285     (print-and-call fdefn-init)
286    
287     ;; Some of the random top-level forms call Make-Array, which calls Subtypep
288 ram 1.34 (print-and-call typedef-init)
289     (print-and-call class-init)
290 wlott 1.10 (print-and-call type-init)
291 ram 1.1
292 wlott 1.26 (let ((funs (nreverse *lisp-initialization-functions*)))
293     (%primitive print "Calling top-level forms.")
294     (dolist (fun funs)
295     (typecase fun
296     (function
297     (funcall fun))
298     (cons
299     (case (car fun)
300     (:load-time-value
301     (setf (svref *load-time-values* (third fun))
302     (funcall (second fun))))
303     (:load-time-value-fixup
304 wlott 1.36 #-gengc
305 wlott 1.26 (setf (sap-ref-32 (second fun) 0)
306     (get-lisp-obj-address
307 wlott 1.36 (svref *load-time-values* (third fun))))
308     #+gengc
309     (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))
310 wlott 1.26 (t
311     (%primitive print
312     "Bogus fixup in *lisp-initialization-functions*")
313     (%halt))))
314     (t
315     (%primitive print
316     "Bogus function in *lisp-initialization-functions*")
317     (%halt)))))
318 ram 1.1 (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
319 wlott 1.26 (makunbound '*load-time-values*)
320 ram 1.1
321 wlott 1.10 ;; Only do this after top level forms have run, 'cause thats where
322     ;; deftypes are.
323 ram 1.34 (setf *type-system-initialized* t)
324 wlott 1.10
325 ram 1.1 (print-and-call os-init)
326     (print-and-call filesys-init)
327    
328     (print-and-call reader-init)
329 ram 1.38 ;; Note: sharpm and backq not yet loaded, so this is not the final RT.
330 wlott 1.12 (setf *readtable* (copy-readtable std-lisp-readtable))
331 ram 1.1
332     (print-and-call stream-init)
333 wlott 1.10 (print-and-call loader-init)
334 ram 1.1 (print-and-call package-init)
335 wlott 1.16 (print-and-call kernel::signal-init)
336 wlott 1.28 (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
337 ram 1.17 (set-floating-point-modes :traps '(:overflow :underflow :invalid
338     :divide-by-zero))
339 wlott 1.29 ;; This is necessary because some of the initial top level forms might
340     ;; have changed the compliation policy in strange ways.
341     (print-and-call c::proclaim-init)
342 ram 1.34
343     (print-and-call kernel::class-finalize)
344 ram 1.1
345 wlott 1.10 (%primitive print "Done initializing.")
346    
347 wlott 1.35 #-gengc (setf *already-maybe-gcing* nil)
348     #+gengc (setf *gc-verbose* t)
349 ram 1.1 (terpri)
350     (princ "CMU Common Lisp kernel core image ")
351     (princ (lisp-implementation-version))
352     (princ ".")
353     (terpri)
354     (princ "[You are in the LISP package.]")
355     (terpri)
356     (catch '%end-of-the-world
357     (loop
358     (%top-level)
359     (write-line "You're certainly a clever child.")))
360 wlott 1.28 (unix:unix-exit 0))
361 wlott 1.36
362     #+gengc
363     (defun do-load-time-value-fixup (object offset value)
364     (declare (type index offset))
365     (macrolet ((lose (msg)
366     `(progn
367     (%primitive print ,msg)
368     (%halt))))
369     (typecase object
370     (list
371     (case offset
372     (0 (setf (car object) value))
373     (1 (setf (cdr object) value))
374     (t (lose "Bogus offset in cons cell."))))
375     (instance
376     (setf (%instance-ref object (- offset vm:instance-slots-offset)) value))
377     (code-component
378     (setf (code-header-ref object offset) value))
379     (simple-vector
380     (setf (svref object (- offset vm:vector-data-offset)) value))
381     (t
382     (lose "Unknown kind of object for load-time-value fixup.")))))
383 ram 1.1
384    
385     ;;;; Initialization functions:
386    
387     (defun reinit ()
388     (without-interrupts
389 wlott 1.33 (without-gcing
390     (os-init)
391     (stream-reinit)
392     (kernel::signal-init)
393     (gc-init)
394     (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
395     (set-floating-point-modes :traps
396     '(:overflow :underflow :invalid
397     :divide-by-zero)))))
398 ram 1.1
399    
400    
401     ;;;; Miscellaneous external functions:
402    
403     ;;; Quit gets us out, one way or another.
404    
405     (defun quit (&optional recklessly-p)
406     "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
407     non-Nil."
408     (if recklessly-p
409 wlott 1.28 (unix:unix-exit 0)
410 ram 1.1 (throw '%end-of-the-world nil)))
411    
412    
413     (defun sleep (n)
414     "This function causes execution to be suspended for N seconds. N may
415     be any non-negative, non-complex number."
416 wlott 1.13 (when (or (not (realp n))
417     (minusp n))
418     (error "Invalid argument to SLEEP: ~S.~%~
419     Must be a non-negative, non-complex number."
420     n))
421     (multiple-value-bind (sec usec)
422     (if (integerp n)
423     (values n 0)
424     (values (truncate n)
425     (truncate (* n 1000000))))
426 wlott 1.28 (unix:unix-select 0 0 0 0 sec usec))
427 ram 1.1 nil)
428    
429    
430 wlott 1.25 ;;;; SCRUB-CONTROL-STACK
431    
432    
433 wlott 1.30 (defconstant bytes-per-scrub-unit 2048)
434 wlott 1.25
435     (defun scrub-control-stack ()
436     "Zero the unused portion of the control stack so that old objects are not
437     kept alive because of uninitialized stack variables."
438     (declare (optimize (speed 3) (safety 0))
439     (values (unsigned-byte 20)))
440     (labels
441     ((scrub (ptr offset count)
442     (declare (type system-area-pointer ptr)
443     (type (unsigned-byte 16) offset)
444     (type (unsigned-byte 20) count)
445     (values (unsigned-byte 20)))
446 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
447     (look (sap+ ptr bytes-per-scrub-unit) 0 count))
448 wlott 1.25 (t
449     (setf (sap-ref-32 ptr offset) 0)
450 wlott 1.30 (scrub ptr (+ offset vm:word-bytes) count))))
451 wlott 1.25 (look (ptr offset count)
452     (declare (type system-area-pointer ptr)
453     (type (unsigned-byte 16) offset)
454     (type (unsigned-byte 20) count)
455     (values (unsigned-byte 20)))
456 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
457 wlott 1.25 count)
458     ((zerop (sap-ref-32 ptr offset))
459 wlott 1.30 (look ptr (+ offset vm:word-bytes) count))
460 wlott 1.25 (t
461 wlott 1.30 (scrub ptr offset (+ count vm:word-bytes))))))
462 wlott 1.25 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
463 wlott 1.30 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
464 wlott 1.25 (declare (type (unsigned-byte 32) csp))
465     (scrub (int-sap (- csp initial-offset))
466 wlott 1.30 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
467 wlott 1.25 0))))
468    
469    
470    
471 ram 1.1 ;;;; TOP-LEVEL loop.
472    
473     (defvar / nil
474     "Holds a list of all the values returned by the most recent top-level EVAL.")
475     (defvar // nil "Gets the previous value of / when a new value is computed.")
476     (defvar /// nil "Gets the previous value of // when a new value is computed.")
477     (defvar * nil "Holds the value of the most recent top-level EVAL.")
478     (defvar ** nil "Gets the previous value of * when a new value is computed.")
479     (defvar *** nil "Gets the previous value of ** when a new value is computed.")
480     (defvar + nil "Holds the value of the most recent top-level READ.")
481     (defvar ++ nil "Gets the previous value of + when a new value is read.")
482     (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
483     (defvar - nil "Holds the form curently being evaluated.")
484 ram 1.3 (defvar *prompt* "* "
485     "The top-level prompt string. This also may be a function of no arguments
486     that returns a simple-string.")
487 ram 1.1 (defvar *in-top-level-catcher* nil
488     "True if we are within the Top-Level-Catcher. This is used by interrupt
489     handlers to see whether it is o.k. to throw.")
490    
491 ram 1.3 (defun interactive-eval (form)
492     "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
493     +, ///, //, /, and -."
494 ram 1.21 (setf - form)
495 ram 1.3 (let ((results (multiple-value-list (eval form))))
496     (setf /// //
497     // /
498     / results
499     *** **
500     ** *
501     * (car results)))
502 ram 1.21 (setf +++ ++
503     ++ +
504     + -)
505 ram 1.3 (unless (boundp '*)
506     ;; The bogon returned an unbound marker.
507     (setf * nil)
508     (cerror "Go on with * set to NIL."
509     "EVAL returned an unbound marker."))
510     (values-list /))
511 ram 1.21
512 ram 1.3
513     (defconstant eofs-before-quit 10)
514    
515 ram 1.1 (defun %top-level ()
516     "Top-level READ-EVAL-PRINT loop. Do not call this."
517 ram 1.3 (let ((* nil) (** nil) (*** nil)
518 ram 1.1 (- nil) (+ nil) (++ nil) (+++ nil)
519 ram 1.3 (/// nil) (// nil) (/ nil)
520     (magic-eof-cookie (cons :eof nil))
521     (number-of-eofs 0))
522 ram 1.1 (loop
523 wlott 1.25 (with-simple-restart (abort "Return to Top-Level.")
524     (catch 'top-level-catcher
525 wlott 1.28 (unix:unix-sigsetmask 0)
526 wlott 1.25 (let ((*in-top-level-catcher* t))
527     (loop
528     (scrub-control-stack)
529     (fresh-line)
530     (princ (if (functionp *prompt*)
531     (funcall *prompt*)
532     *prompt*))
533     (force-output)
534     (let ((form (read *standard-input* nil magic-eof-cookie)))
535     (cond ((not (eq form magic-eof-cookie))
536     (let ((results
537     (multiple-value-list (interactive-eval form))))
538     (dolist (result results)
539     (fresh-line)
540     (prin1 result)))
541     (setf number-of-eofs 0))
542     ((eql (incf number-of-eofs) 1)
543     (let ((stream (make-synonym-stream '*terminal-io*)))
544     (setf *standard-input* stream)
545     (setf *standard-output* stream)
546     (format t "~&Received EOF on *standard-input*, ~
547     switching to *terminal-io*.~%")))
548     ((> number-of-eofs eofs-before-quit)
549     (format t "~&Received more than ~D EOFs; Aborting.~%"
550     eofs-before-quit)
551     (quit))
552     (t
553     (format t "~&Received EOF.~%")))))))))))
554 ram 1.1
555    
556 ram 1.3
557 ram 1.1 ;;; %Halt -- Interface
558     ;;;
559     ;;; A convenient way to get into the assembly level debugger.
560     ;;;
561     (defun %halt ()
562     (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5