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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.42 - (show annotations)
Thu Aug 26 15:27:56 1993 UTC (20 years, 7 months ago) by wlott
Branch: MAIN
Changes since 1.41: +18 -16 lines
Fixed do-load-time-value-fixup to get the load-time-value from *load-time-
values* and deposit it, instead of depositing the index.
1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/lispinit.lisp,v 1.42 1993/08/26 15:27:56 wlott Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Initialization stuff for CMU Common Lisp, plus some other random functions
15 ;;; that we don't have any better place for.
16 ;;;
17 ;;; Written by Skef Wholey and Rob MacLachlan.
18 ;;;
19 (in-package :lisp)
20
21 (export '(most-positive-fixnum most-negative-fixnum sleep
22 ++ +++ ** *** // ///))
23
24 (in-package :system)
25 (export '(compiler-version scrub-control-stack))
26
27 (in-package :extensions)
28 (export '(quit *prompt*))
29
30 (in-package :lisp)
31
32 ;;; Make the error system enable interrupts.
33
34 (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum
35 "The fixnum closest in value to positive infinity.")
36
37 (defconstant most-negative-fixnum #.vm:target-most-negative-fixnum
38 "The fixnum closest in value to negative infinity.")
39
40
41 ;;; Random information:
42
43 (defvar *lisp-implementation-version* "4.0(?)")
44
45
46 ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs...
47 (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
59
60 ;;;; Random magic specials.
61
62
63 ;;; These are filled in by Genesis.
64
65 #-gengc
66 (progn
67
68 (defvar *current-catch-block*)
69 (defvar *current-unwind-block*)
70 (defvar *free-interrupt-context-index*)
71
72 ); #-gengc progn
73
74
75 ;;;; 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 (in-package "CONDITIONS")
122
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 ;;; %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 (proclaim '(special *lisp-initialization-functions*
259 *load-time-values*))
260
261 (eval-when (compile)
262 (defmacro print-and-call (name)
263 `(progn
264 (%primitive print ,(symbol-name name))
265 (,name))))
266
267 (defun %initial-function ()
268 "Gives the world a shove and hopes it spins."
269 (%primitive print "In initial-function, and running.")
270 #-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 (setf *before-gc-hooks* nil)
275 (setf *after-gc-hooks* nil)
276 #-gengc (setf unix::*interrupts-enabled* t)
277 #-gengc (setf unix::*interrupt-pending* nil)
278 (setf *type-system-initialized* nil)
279 (setf *break-on-signals* nil)
280
281 ;; Many top-level forms call INFO, (SETF INFO).
282 (print-and-call c::globaldb-init)
283
284 ;; 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 (print-and-call typedef-init)
289 (print-and-call class-init)
290 (print-and-call type-init)
291
292 (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 #-gengc
305 (setf (sap-ref-32 (second fun) 0)
306 (get-lisp-obj-address
307 (svref *load-time-values* (third fun))))
308 #+gengc
309 (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))
310 (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 (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
319 (makunbound '*load-time-values*)
320
321 ;; Only do this after top level forms have run, 'cause thats where
322 ;; deftypes are.
323 (setf *type-system-initialized* t)
324
325 (print-and-call os-init)
326 (print-and-call filesys-init)
327
328 (print-and-call reader-init)
329 ;; Note: sharpm and backq not yet loaded, so this is not the final RT.
330 (setf *readtable* (copy-readtable std-lisp-readtable))
331
332 (print-and-call stream-init)
333 (print-and-call loader-init)
334 (print-and-call package-init)
335 (print-and-call kernel::signal-init)
336 (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
337 (set-floating-point-modes :traps '(:overflow :underflow :invalid
338 :divide-by-zero))
339 ;; 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
343 (print-and-call kernel::class-finalize)
344
345 (%primitive print "Done initializing.")
346
347 #-gengc (setf *already-maybe-gcing* nil)
348 #+gengc (setf *gc-verbose* t)
349 (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 (unix:unix-exit 0))
361
362 #+gengc
363 (defun do-load-time-value-fixup (object offset index)
364 (declare (type index offset))
365 (macrolet ((lose (msg)
366 `(progn
367 (%primitive print ,msg)
368 (%halt))))
369 (let ((value (svref *load-time-values* index)))
370 (typecase object
371 (list
372 (case offset
373 (0 (setf (car object) value))
374 (1 (setf (cdr object) value))
375 (t (lose "Bogus offset in cons cell."))))
376 (instance
377 (setf (%instance-ref object (- offset vm:instance-slots-offset))
378 value))
379 (code-component
380 (setf (code-header-ref object offset) value))
381 (simple-vector
382 (setf (svref object (- offset vm:vector-data-offset)) value))
383 (t
384 (lose "Unknown kind of object for load-time-value fixup."))))))
385
386
387 ;;;; Initialization functions:
388
389 (defun reinit ()
390 (without-interrupts
391 (without-gcing
392 (os-init)
393 (stream-reinit)
394 (kernel::signal-init)
395 (gc-init)
396 (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
397 (set-floating-point-modes :traps
398 '(:overflow :underflow :invalid
399 :divide-by-zero)))))
400
401
402
403 ;;;; Miscellaneous external functions:
404
405 ;;; Quit gets us out, one way or another.
406
407 (defun quit (&optional recklessly-p)
408 "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
409 non-Nil."
410 (if recklessly-p
411 (unix:unix-exit 0)
412 (throw '%end-of-the-world nil)))
413
414
415 (defun sleep (n)
416 "This function causes execution to be suspended for N seconds. N may
417 be any non-negative, non-complex number."
418 (when (or (not (realp n))
419 (minusp n))
420 (error "Invalid argument to SLEEP: ~S.~%~
421 Must be a non-negative, non-complex number."
422 n))
423 (multiple-value-bind (sec usec)
424 (if (integerp n)
425 (values n 0)
426 (values (truncate n)
427 (truncate (* n 1000000))))
428 (unix:unix-select 0 0 0 0 sec usec))
429 nil)
430
431
432 ;;;; SCRUB-CONTROL-STACK
433
434
435 (defconstant bytes-per-scrub-unit 2048)
436
437 (defun scrub-control-stack ()
438 "Zero the unused portion of the control stack so that old objects are not
439 kept alive because of uninitialized stack variables."
440 (declare (optimize (speed 3) (safety 0))
441 (values (unsigned-byte 20)))
442 (labels
443 ((scrub (ptr offset count)
444 (declare (type system-area-pointer ptr)
445 (type (unsigned-byte 16) offset)
446 (type (unsigned-byte 20) count)
447 (values (unsigned-byte 20)))
448 (cond ((= offset bytes-per-scrub-unit)
449 (look (sap+ ptr bytes-per-scrub-unit) 0 count))
450 (t
451 (setf (sap-ref-32 ptr offset) 0)
452 (scrub ptr (+ offset vm:word-bytes) count))))
453 (look (ptr offset count)
454 (declare (type system-area-pointer ptr)
455 (type (unsigned-byte 16) offset)
456 (type (unsigned-byte 20) count)
457 (values (unsigned-byte 20)))
458 (cond ((= offset bytes-per-scrub-unit)
459 count)
460 ((zerop (sap-ref-32 ptr offset))
461 (look ptr (+ offset vm:word-bytes) count))
462 (t
463 (scrub ptr offset (+ count vm:word-bytes))))))
464 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
465 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
466 (declare (type (unsigned-byte 32) csp))
467 (scrub (int-sap (- csp initial-offset))
468 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
469 0))))
470
471
472
473 ;;;; TOP-LEVEL loop.
474
475 (defvar / nil
476 "Holds a list of all the values returned by the most recent top-level EVAL.")
477 (defvar // nil "Gets the previous value of / when a new value is computed.")
478 (defvar /// nil "Gets the previous value of // when a new value is computed.")
479 (defvar * nil "Holds the value of the most recent top-level EVAL.")
480 (defvar ** nil "Gets the previous value of * when a new value is computed.")
481 (defvar *** nil "Gets the previous value of ** when a new value is computed.")
482 (defvar + nil "Holds the value of the most recent top-level READ.")
483 (defvar ++ nil "Gets the previous value of + when a new value is read.")
484 (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
485 (defvar - nil "Holds the form curently being evaluated.")
486 (defvar *prompt* "* "
487 "The top-level prompt string. This also may be a function of no arguments
488 that returns a simple-string.")
489 (defvar *in-top-level-catcher* nil
490 "True if we are within the Top-Level-Catcher. This is used by interrupt
491 handlers to see whether it is o.k. to throw.")
492
493 (defun interactive-eval (form)
494 "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
495 +, ///, //, /, and -."
496 (setf - form)
497 (let ((results (multiple-value-list (eval form))))
498 (setf /// //
499 // /
500 / results
501 *** **
502 ** *
503 * (car results)))
504 (setf +++ ++
505 ++ +
506 + -)
507 (unless (boundp '*)
508 ;; The bogon returned an unbound marker.
509 (setf * nil)
510 (cerror "Go on with * set to NIL."
511 "EVAL returned an unbound marker."))
512 (values-list /))
513
514
515 (defconstant eofs-before-quit 10)
516
517 (defun %top-level ()
518 "Top-level READ-EVAL-PRINT loop. Do not call this."
519 (let ((* nil) (** nil) (*** nil)
520 (- nil) (+ nil) (++ nil) (+++ nil)
521 (/// nil) (// nil) (/ nil)
522 (magic-eof-cookie (cons :eof nil))
523 (number-of-eofs 0))
524 (loop
525 (with-simple-restart (abort "Return to Top-Level.")
526 (catch 'top-level-catcher
527 (unix:unix-sigsetmask 0)
528 (let ((*in-top-level-catcher* t))
529 (loop
530 (scrub-control-stack)
531 (fresh-line)
532 (princ (if (functionp *prompt*)
533 (funcall *prompt*)
534 *prompt*))
535 (force-output)
536 (let ((form (read *standard-input* nil magic-eof-cookie)))
537 (cond ((not (eq form magic-eof-cookie))
538 (let ((results
539 (multiple-value-list (interactive-eval form))))
540 (dolist (result results)
541 (fresh-line)
542 (prin1 result)))
543 (setf number-of-eofs 0))
544 ((eql (incf number-of-eofs) 1)
545 (let ((stream (make-synonym-stream '*terminal-io*)))
546 (setf *standard-input* stream)
547 (setf *standard-output* stream)
548 (format t "~&Received EOF on *standard-input*, ~
549 switching to *terminal-io*.~%")))
550 ((> number-of-eofs eofs-before-quit)
551 (format t "~&Received more than ~D EOFs; Aborting.~%"
552 eofs-before-quit)
553 (quit))
554 (t
555 (format t "~&Received EOF.~%")))))))))))
556
557
558
559 ;;; %Halt -- Interface
560 ;;;
561 ;;; A convenient way to get into the assembly level debugger.
562 ;;;
563 (defun %halt ()
564 (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5