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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.43 - (hide annotations)
Mon Aug 30 21:20:02 1993 UTC (20 years, 7 months ago) by ram
Branch: MAIN
Changes since 1.42: +8 -7 lines
Update to new DEFINE-CONDITION syntax.
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.43 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/lispinit.lisp,v 1.43 1993/08/30 21:20:02 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 ram 1.43 (unless (and (condition-function-name condition) debug:*stack-top-hint*)
183 ram 1.39 (multiple-value-bind
184     (name frame)
185     (kernel:find-caller-name)
186 ram 1.43 (unless (condition-function-name condition)
187     (setf (condition-function-name condition) name))
188 ram 1.39 (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 ram 1.43 (unless (and (condition-function-name condition)
207     debug:*stack-top-hint*)
208 ram 1.39 (multiple-value-bind
209     (name frame)
210     (kernel:find-caller-name)
211 ram 1.43 (unless (condition-function-name condition)
212     (setf (condition-function-name condition) name))
213 ram 1.39 (unless debug:*stack-top-hint*
214     (setf debug:*stack-top-hint* frame))))
215     (with-condition-restarts condition (list (find-restart 'continue))
216     (let ((debug:*stack-top-hint* nil))
217     (signal condition))
218     (invoke-debugger condition)))))
219     nil)
220    
221     (defun break (&optional (datum "Break") &rest arguments)
222     "Prints a message and invokes the debugger without allowing any possibility
223     of condition handling occurring."
224     (kernel:infinite-error-protect
225     (with-simple-restart (continue "Return from BREAK.")
226     (let ((debug:*stack-top-hint*
227     (or debug:*stack-top-hint*
228     (nth-value 1 (kernel:find-caller-name)))))
229     (invoke-debugger
230     (coerce-to-condition datum arguments 'simple-condition 'break)))))
231     nil)
232    
233     (defun warn (datum &rest arguments)
234     "Warns about a situation by signalling a condition formed by datum and
235     arguments. While the condition is being signaled, a muffle-warning restart
236     exists that causes WARN to immediately return nil."
237     (kernel:infinite-error-protect
238     (let ((condition (coerce-to-condition datum arguments
239     'simple-warning 'warn)))
240     (check-type condition warning "a warning condition")
241     (restart-case (signal condition)
242     (muffle-warning ()
243     :report "Skip warning."
244     (return-from warn nil)))
245     (format *error-output* "~&~@<Warning: ~3i~:_~A~:>~%" condition)))
246     nil)
247    
248     (in-package "LISP")
249    
250    
251 ram 1.1 ;;; %Initial-Function is called when a cold system starts up. First we zoom
252     ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
253     ;;; at "load time." Then we initialize the various subsystems and call the
254     ;;; read-eval-print loop. The top-level Read-Eval-Print loop is executed until
255     ;;; someone (most likely the Quit function) throws to the tag
256     ;;; %End-Of-The-World. We quit this way so that all outstanding cleanup forms
257     ;;; in Unwind-Protects will get executed.
258    
259 wlott 1.26 (proclaim '(special *lisp-initialization-functions*
260     *load-time-values*))
261 ram 1.1
262     (eval-when (compile)
263     (defmacro print-and-call (name)
264     `(progn
265 wlott 1.10 (%primitive print ,(symbol-name name))
266 ram 1.1 (,name))))
267    
268     (defun %initial-function ()
269     "Gives the world a shove and hopes it spins."
270 wlott 1.36 (%primitive print "In initial-function, and running.")
271 wlott 1.35 #-gengc (setf *already-maybe-gcing* t)
272     #-gengc (setf *gc-inhibit* t)
273     #-gengc (setf *need-to-collect-garbage* nil)
274     (setf *gc-verbose* #-gengc t #+gengc nil)
275 wlott 1.12 (setf *before-gc-hooks* nil)
276     (setf *after-gc-hooks* nil)
277 wlott 1.35 #-gengc (setf unix::*interrupts-enabled* t)
278     #-gengc (setf unix::*interrupt-pending* nil)
279 ram 1.34 (setf *type-system-initialized* nil)
280 ram 1.41 (setf *break-on-signals* nil)
281 ram 1.1
282     ;; Many top-level forms call INFO, (SETF INFO).
283     (print-and-call c::globaldb-init)
284    
285 wlott 1.32 ;; Set up the fdefn database.
286     (print-and-call fdefn-init)
287    
288     ;; Some of the random top-level forms call Make-Array, which calls Subtypep
289 ram 1.34 (print-and-call typedef-init)
290     (print-and-call class-init)
291 wlott 1.10 (print-and-call type-init)
292 ram 1.1
293 wlott 1.26 (let ((funs (nreverse *lisp-initialization-functions*)))
294     (%primitive print "Calling top-level forms.")
295     (dolist (fun funs)
296     (typecase fun
297     (function
298     (funcall fun))
299     (cons
300     (case (car fun)
301     (:load-time-value
302     (setf (svref *load-time-values* (third fun))
303     (funcall (second fun))))
304     (:load-time-value-fixup
305 wlott 1.36 #-gengc
306 wlott 1.26 (setf (sap-ref-32 (second fun) 0)
307     (get-lisp-obj-address
308 wlott 1.36 (svref *load-time-values* (third fun))))
309     #+gengc
310     (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))
311 wlott 1.26 (t
312     (%primitive print
313     "Bogus fixup in *lisp-initialization-functions*")
314     (%halt))))
315     (t
316     (%primitive print
317     "Bogus function in *lisp-initialization-functions*")
318     (%halt)))))
319 ram 1.1 (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
320 wlott 1.26 (makunbound '*load-time-values*)
321 ram 1.1
322 wlott 1.10 ;; Only do this after top level forms have run, 'cause thats where
323     ;; deftypes are.
324 ram 1.34 (setf *type-system-initialized* t)
325 wlott 1.10
326 ram 1.1 (print-and-call os-init)
327     (print-and-call filesys-init)
328    
329     (print-and-call reader-init)
330 ram 1.38 ;; Note: sharpm and backq not yet loaded, so this is not the final RT.
331 wlott 1.12 (setf *readtable* (copy-readtable std-lisp-readtable))
332 ram 1.1
333     (print-and-call stream-init)
334 wlott 1.10 (print-and-call loader-init)
335 ram 1.1 (print-and-call package-init)
336 wlott 1.16 (print-and-call kernel::signal-init)
337 wlott 1.28 (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
338 ram 1.17 (set-floating-point-modes :traps '(:overflow :underflow :invalid
339     :divide-by-zero))
340 wlott 1.29 ;; This is necessary because some of the initial top level forms might
341     ;; have changed the compliation policy in strange ways.
342     (print-and-call c::proclaim-init)
343 ram 1.34
344     (print-and-call kernel::class-finalize)
345 ram 1.1
346 wlott 1.10 (%primitive print "Done initializing.")
347    
348 wlott 1.35 #-gengc (setf *already-maybe-gcing* nil)
349     #+gengc (setf *gc-verbose* t)
350 ram 1.1 (terpri)
351     (princ "CMU Common Lisp kernel core image ")
352     (princ (lisp-implementation-version))
353     (princ ".")
354     (terpri)
355     (princ "[You are in the LISP package.]")
356     (terpri)
357     (catch '%end-of-the-world
358     (loop
359     (%top-level)
360     (write-line "You're certainly a clever child.")))
361 wlott 1.28 (unix:unix-exit 0))
362 wlott 1.36
363     #+gengc
364 wlott 1.42 (defun do-load-time-value-fixup (object offset index)
365 wlott 1.36 (declare (type index offset))
366     (macrolet ((lose (msg)
367     `(progn
368     (%primitive print ,msg)
369     (%halt))))
370 wlott 1.42 (let ((value (svref *load-time-values* index)))
371     (typecase object
372     (list
373     (case offset
374     (0 (setf (car object) value))
375     (1 (setf (cdr object) value))
376     (t (lose "Bogus offset in cons cell."))))
377     (instance
378     (setf (%instance-ref object (- offset vm:instance-slots-offset))
379     value))
380     (code-component
381     (setf (code-header-ref object offset) value))
382     (simple-vector
383     (setf (svref object (- offset vm:vector-data-offset)) value))
384     (t
385     (lose "Unknown kind of object for load-time-value fixup."))))))
386 ram 1.1
387    
388     ;;;; Initialization functions:
389    
390     (defun reinit ()
391     (without-interrupts
392 wlott 1.33 (without-gcing
393     (os-init)
394     (stream-reinit)
395     (kernel::signal-init)
396     (gc-init)
397     (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
398     (set-floating-point-modes :traps
399     '(:overflow :underflow :invalid
400     :divide-by-zero)))))
401 ram 1.1
402    
403    
404     ;;;; Miscellaneous external functions:
405    
406     ;;; Quit gets us out, one way or another.
407    
408     (defun quit (&optional recklessly-p)
409     "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
410     non-Nil."
411     (if recklessly-p
412 wlott 1.28 (unix:unix-exit 0)
413 ram 1.1 (throw '%end-of-the-world nil)))
414    
415    
416     (defun sleep (n)
417     "This function causes execution to be suspended for N seconds. N may
418     be any non-negative, non-complex number."
419 wlott 1.13 (when (or (not (realp n))
420     (minusp n))
421     (error "Invalid argument to SLEEP: ~S.~%~
422     Must be a non-negative, non-complex number."
423     n))
424     (multiple-value-bind (sec usec)
425     (if (integerp n)
426     (values n 0)
427     (values (truncate n)
428     (truncate (* n 1000000))))
429 wlott 1.28 (unix:unix-select 0 0 0 0 sec usec))
430 ram 1.1 nil)
431    
432    
433 wlott 1.25 ;;;; SCRUB-CONTROL-STACK
434    
435    
436 wlott 1.30 (defconstant bytes-per-scrub-unit 2048)
437 wlott 1.25
438     (defun scrub-control-stack ()
439     "Zero the unused portion of the control stack so that old objects are not
440     kept alive because of uninitialized stack variables."
441     (declare (optimize (speed 3) (safety 0))
442     (values (unsigned-byte 20)))
443     (labels
444     ((scrub (ptr offset count)
445     (declare (type system-area-pointer ptr)
446     (type (unsigned-byte 16) offset)
447     (type (unsigned-byte 20) count)
448     (values (unsigned-byte 20)))
449 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
450     (look (sap+ ptr bytes-per-scrub-unit) 0 count))
451 wlott 1.25 (t
452     (setf (sap-ref-32 ptr offset) 0)
453 wlott 1.30 (scrub ptr (+ offset vm:word-bytes) count))))
454 wlott 1.25 (look (ptr offset count)
455     (declare (type system-area-pointer ptr)
456     (type (unsigned-byte 16) offset)
457     (type (unsigned-byte 20) count)
458     (values (unsigned-byte 20)))
459 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
460 wlott 1.25 count)
461     ((zerop (sap-ref-32 ptr offset))
462 wlott 1.30 (look ptr (+ offset vm:word-bytes) count))
463 wlott 1.25 (t
464 wlott 1.30 (scrub ptr offset (+ count vm:word-bytes))))))
465 wlott 1.25 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
466 wlott 1.30 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
467 wlott 1.25 (declare (type (unsigned-byte 32) csp))
468     (scrub (int-sap (- csp initial-offset))
469 wlott 1.30 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
470 wlott 1.25 0))))
471    
472    
473    
474 ram 1.1 ;;;; TOP-LEVEL loop.
475    
476     (defvar / nil
477     "Holds a list of all the values returned by 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 EVAL.")
481     (defvar ** nil "Gets the previous value of * when a new value is computed.")
482     (defvar *** nil "Gets the previous value of ** when a new value is computed.")
483     (defvar + nil "Holds the value of the most recent top-level READ.")
484     (defvar ++ nil "Gets the previous value of + when a new value is read.")
485     (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
486     (defvar - nil "Holds the form curently being evaluated.")
487 ram 1.3 (defvar *prompt* "* "
488     "The top-level prompt string. This also may be a function of no arguments
489     that returns a simple-string.")
490 ram 1.1 (defvar *in-top-level-catcher* nil
491     "True if we are within the Top-Level-Catcher. This is used by interrupt
492     handlers to see whether it is o.k. to throw.")
493    
494 ram 1.3 (defun interactive-eval (form)
495     "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
496     +, ///, //, /, and -."
497 ram 1.21 (setf - form)
498 ram 1.3 (let ((results (multiple-value-list (eval form))))
499     (setf /// //
500     // /
501     / results
502     *** **
503     ** *
504     * (car results)))
505 ram 1.21 (setf +++ ++
506     ++ +
507     + -)
508 ram 1.3 (unless (boundp '*)
509     ;; The bogon returned an unbound marker.
510     (setf * nil)
511     (cerror "Go on with * set to NIL."
512     "EVAL returned an unbound marker."))
513     (values-list /))
514 ram 1.21
515 ram 1.3
516     (defconstant eofs-before-quit 10)
517    
518 ram 1.1 (defun %top-level ()
519     "Top-level READ-EVAL-PRINT loop. Do not call this."
520 ram 1.3 (let ((* nil) (** nil) (*** nil)
521 ram 1.1 (- nil) (+ nil) (++ nil) (+++ nil)
522 ram 1.3 (/// nil) (// nil) (/ nil)
523     (magic-eof-cookie (cons :eof nil))
524     (number-of-eofs 0))
525 ram 1.1 (loop
526 wlott 1.25 (with-simple-restart (abort "Return to Top-Level.")
527     (catch 'top-level-catcher
528 wlott 1.28 (unix:unix-sigsetmask 0)
529 wlott 1.25 (let ((*in-top-level-catcher* t))
530     (loop
531     (scrub-control-stack)
532     (fresh-line)
533     (princ (if (functionp *prompt*)
534     (funcall *prompt*)
535     *prompt*))
536     (force-output)
537     (let ((form (read *standard-input* nil magic-eof-cookie)))
538     (cond ((not (eq form magic-eof-cookie))
539     (let ((results
540     (multiple-value-list (interactive-eval form))))
541     (dolist (result results)
542     (fresh-line)
543     (prin1 result)))
544     (setf number-of-eofs 0))
545     ((eql (incf number-of-eofs) 1)
546     (let ((stream (make-synonym-stream '*terminal-io*)))
547     (setf *standard-input* stream)
548     (setf *standard-output* stream)
549     (format t "~&Received EOF on *standard-input*, ~
550     switching to *terminal-io*.~%")))
551     ((> number-of-eofs eofs-before-quit)
552     (format t "~&Received more than ~D EOFs; Aborting.~%"
553     eofs-before-quit)
554     (quit))
555     (t
556     (format t "~&Received EOF.~%")))))))))))
557 ram 1.1
558    
559 ram 1.3
560 ram 1.1 ;;; %Halt -- Interface
561     ;;;
562     ;;; A convenient way to get into the assembly level debugger.
563     ;;;
564     (defun %halt ()
565     (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5