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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.39 - (show annotations)
Thu Aug 19 17:15:40 1993 UTC (20 years, 8 months ago) by ram
Branch: MAIN
Changes since 1.38: +176 -3 lines
Moved some functions here that want to be native compiled (and in the cold
load.)
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.39 1993/08/19 17:15:40 ram 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 "CONDTIIONS")
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
280 ;; Many top-level forms call INFO, (SETF INFO).
281 (print-and-call c::globaldb-init)
282
283 ;; Set up the fdefn database.
284 (print-and-call fdefn-init)
285
286 ;; Some of the random top-level forms call Make-Array, which calls Subtypep
287 (print-and-call typedef-init)
288 (print-and-call class-init)
289 (print-and-call type-init)
290
291 (let ((funs (nreverse *lisp-initialization-functions*)))
292 (%primitive print "Calling top-level forms.")
293 (dolist (fun funs)
294 (typecase fun
295 (function
296 (funcall fun))
297 (cons
298 (case (car fun)
299 (:load-time-value
300 (setf (svref *load-time-values* (third fun))
301 (funcall (second fun))))
302 (:load-time-value-fixup
303 #-gengc
304 (setf (sap-ref-32 (second fun) 0)
305 (get-lisp-obj-address
306 (svref *load-time-values* (third fun))))
307 #+gengc
308 (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))
309 (t
310 (%primitive print
311 "Bogus fixup in *lisp-initialization-functions*")
312 (%halt))))
313 (t
314 (%primitive print
315 "Bogus function in *lisp-initialization-functions*")
316 (%halt)))))
317 (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
318 (makunbound '*load-time-values*)
319
320 ;; Only do this after top level forms have run, 'cause thats where
321 ;; deftypes are.
322 (setf *type-system-initialized* t)
323
324 (print-and-call os-init)
325 (print-and-call filesys-init)
326
327 (print-and-call reader-init)
328 ;; Note: sharpm and backq not yet loaded, so this is not the final RT.
329 (setf *readtable* (copy-readtable std-lisp-readtable))
330
331 (print-and-call stream-init)
332 (print-and-call loader-init)
333 (print-and-call package-init)
334 (print-and-call kernel::signal-init)
335 (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
336 (set-floating-point-modes :traps '(:overflow :underflow :invalid
337 :divide-by-zero))
338 ;; This is necessary because some of the initial top level forms might
339 ;; have changed the compliation policy in strange ways.
340 (print-and-call c::proclaim-init)
341
342 (print-and-call kernel::class-finalize)
343
344 (%primitive print "Done initializing.")
345
346 #-gengc (setf *already-maybe-gcing* nil)
347 #+gengc (setf *gc-verbose* t)
348 (terpri)
349 (princ "CMU Common Lisp kernel core image ")
350 (princ (lisp-implementation-version))
351 (princ ".")
352 (terpri)
353 (princ "[You are in the LISP package.]")
354 (terpri)
355 (catch '%end-of-the-world
356 (loop
357 (%top-level)
358 (write-line "You're certainly a clever child.")))
359 (unix:unix-exit 0))
360
361 #+gengc
362 (defun do-load-time-value-fixup (object offset value)
363 (declare (type index offset))
364 (macrolet ((lose (msg)
365 `(progn
366 (%primitive print ,msg)
367 (%halt))))
368 (typecase object
369 (list
370 (case offset
371 (0 (setf (car object) value))
372 (1 (setf (cdr object) value))
373 (t (lose "Bogus offset in cons cell."))))
374 (instance
375 (setf (%instance-ref object (- offset vm:instance-slots-offset)) value))
376 (code-component
377 (setf (code-header-ref object offset) value))
378 (simple-vector
379 (setf (svref object (- offset vm:vector-data-offset)) value))
380 (t
381 (lose "Unknown kind of object for load-time-value fixup.")))))
382
383
384 ;;;; Initialization functions:
385
386 (defun reinit ()
387 (without-interrupts
388 (without-gcing
389 (os-init)
390 (stream-reinit)
391 (kernel::signal-init)
392 (gc-init)
393 (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
394 (set-floating-point-modes :traps
395 '(:overflow :underflow :invalid
396 :divide-by-zero)))))
397
398
399
400 ;;;; Miscellaneous external functions:
401
402 ;;; Quit gets us out, one way or another.
403
404 (defun quit (&optional recklessly-p)
405 "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
406 non-Nil."
407 (if recklessly-p
408 (unix:unix-exit 0)
409 (throw '%end-of-the-world nil)))
410
411
412 (defun sleep (n)
413 "This function causes execution to be suspended for N seconds. N may
414 be any non-negative, non-complex number."
415 (when (or (not (realp n))
416 (minusp n))
417 (error "Invalid argument to SLEEP: ~S.~%~
418 Must be a non-negative, non-complex number."
419 n))
420 (multiple-value-bind (sec usec)
421 (if (integerp n)
422 (values n 0)
423 (values (truncate n)
424 (truncate (* n 1000000))))
425 (unix:unix-select 0 0 0 0 sec usec))
426 nil)
427
428
429 ;;;; SCRUB-CONTROL-STACK
430
431
432 (defconstant bytes-per-scrub-unit 2048)
433
434 (defun scrub-control-stack ()
435 "Zero the unused portion of the control stack so that old objects are not
436 kept alive because of uninitialized stack variables."
437 (declare (optimize (speed 3) (safety 0))
438 (values (unsigned-byte 20)))
439 (labels
440 ((scrub (ptr offset count)
441 (declare (type system-area-pointer ptr)
442 (type (unsigned-byte 16) offset)
443 (type (unsigned-byte 20) count)
444 (values (unsigned-byte 20)))
445 (cond ((= offset bytes-per-scrub-unit)
446 (look (sap+ ptr bytes-per-scrub-unit) 0 count))
447 (t
448 (setf (sap-ref-32 ptr offset) 0)
449 (scrub ptr (+ offset vm:word-bytes) count))))
450 (look (ptr offset count)
451 (declare (type system-area-pointer ptr)
452 (type (unsigned-byte 16) offset)
453 (type (unsigned-byte 20) count)
454 (values (unsigned-byte 20)))
455 (cond ((= offset bytes-per-scrub-unit)
456 count)
457 ((zerop (sap-ref-32 ptr offset))
458 (look ptr (+ offset vm:word-bytes) count))
459 (t
460 (scrub ptr offset (+ count vm:word-bytes))))))
461 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
462 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
463 (declare (type (unsigned-byte 32) csp))
464 (scrub (int-sap (- csp initial-offset))
465 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
466 0))))
467
468
469
470 ;;;; TOP-LEVEL loop.
471
472 (defvar / nil
473 "Holds a list of all the values returned by the most recent top-level EVAL.")
474 (defvar // nil "Gets the previous value of / when a new value is computed.")
475 (defvar /// nil "Gets the previous value of // when a new value is computed.")
476 (defvar * nil "Holds the value of 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 READ.")
480 (defvar ++ nil "Gets the previous value of + when a new value is read.")
481 (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
482 (defvar - nil "Holds the form curently being evaluated.")
483 (defvar *prompt* "* "
484 "The top-level prompt string. This also may be a function of no arguments
485 that returns a simple-string.")
486 (defvar *in-top-level-catcher* nil
487 "True if we are within the Top-Level-Catcher. This is used by interrupt
488 handlers to see whether it is o.k. to throw.")
489
490 (defun interactive-eval (form)
491 "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
492 +, ///, //, /, and -."
493 (setf - form)
494 (let ((results (multiple-value-list (eval form))))
495 (setf /// //
496 // /
497 / results
498 *** **
499 ** *
500 * (car results)))
501 (setf +++ ++
502 ++ +
503 + -)
504 (unless (boundp '*)
505 ;; The bogon returned an unbound marker.
506 (setf * nil)
507 (cerror "Go on with * set to NIL."
508 "EVAL returned an unbound marker."))
509 (values-list /))
510
511
512 (defconstant eofs-before-quit 10)
513
514 (defun %top-level ()
515 "Top-level READ-EVAL-PRINT loop. Do not call this."
516 (let ((* nil) (** nil) (*** nil)
517 (- nil) (+ nil) (++ nil) (+++ nil)
518 (/// nil) (// nil) (/ nil)
519 (magic-eof-cookie (cons :eof nil))
520 (number-of-eofs 0))
521 (loop
522 (with-simple-restart (abort "Return to Top-Level.")
523 (catch 'top-level-catcher
524 (unix:unix-sigsetmask 0)
525 (let ((*in-top-level-catcher* t))
526 (loop
527 (scrub-control-stack)
528 (fresh-line)
529 (princ (if (functionp *prompt*)
530 (funcall *prompt*)
531 *prompt*))
532 (force-output)
533 (let ((form (read *standard-input* nil magic-eof-cookie)))
534 (cond ((not (eq form magic-eof-cookie))
535 (let ((results
536 (multiple-value-list (interactive-eval form))))
537 (dolist (result results)
538 (fresh-line)
539 (prin1 result)))
540 (setf number-of-eofs 0))
541 ((eql (incf number-of-eofs) 1)
542 (let ((stream (make-synonym-stream '*terminal-io*)))
543 (setf *standard-input* stream)
544 (setf *standard-output* stream)
545 (format t "~&Received EOF on *standard-input*, ~
546 switching to *terminal-io*.~%")))
547 ((> number-of-eofs eofs-before-quit)
548 (format t "~&Received more than ~D EOFs; Aborting.~%"
549 eofs-before-quit)
550 (quit))
551 (t
552 (format t "~&Received EOF.~%")))))))))))
553
554
555
556 ;;; %Halt -- Interface
557 ;;;
558 ;;; A convenient way to get into the assembly level debugger.
559 ;;;
560 (defun %halt ()
561 (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5