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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.3 - (show annotations) (vendor branch)
Tue Apr 17 22:00:55 1990 UTC (24 years ago) by wlott
Changes since 1.1.1.2: +3 -2 lines
Print each top level function as we funcall it so we can tell where we are
loosing.
1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice 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 Spice Lisp, please contact
7 ;;; Scott Fahlman (FAHLMAN@CMUC).
8 ;;; **********************************************************************
9 ;;;
10 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/lispinit.lisp,v 1.1.1.3 1990/04/17 22:00:55 wlott Exp $
11 ;;;
12 ;;; Initialization and low-level interrupt support for the Spice Lisp system.
13 ;;; Written by Skef Wholey and Rob MacLachlan.
14 ;;;
15 (in-package "LISP" :use '("SYSTEM" "DEBUG"))
16
17 (in-package "XLIB")
18
19 (in-package "LISP")
20
21 (export '(most-positive-fixnum most-negative-fixnum sleep
22 ++ +++ ** *** // ///))
23
24
25 (in-package "SYSTEM" :nicknames '("SYS"))
26 (export '(add-port-death-handler remove-port-death-handler sap-int
27 int-sap sap-ref-8 sap-ref-16 sap-ref-32 without-gcing
28 *in-the-compiler* compiler-version *pornography-of-death*
29 *port-receive-rights-handlers* *port-ownership-rights-handlers*
30 without-interrupts with-reply-port map-port add-port-object
31 remove-port-object make-object-set object-set-operation
32 server-message *xwindow-table* map-xwindow add-xwindow-object
33 remove-xwindow-object server-event coerce-to-key-event
34 coerce-to-motion-event coerce-to-expose-event
35 coerece-to-exposecopy-event coerce-to-focuschange-event server
36 *nameserverport* *usertypescript* *userwindow* *typescriptport*
37 *task-self* *task-data* *task-notify*
38 with-interrupts with-enabled-interrupts enable-interrupt
39 ignore-interrupt default-interrupt))
40
41 (in-package "EXTENSIONS")
42 (export '(quit *prompt* print-herald save-lisp gc-on gc-off
43 *before-save-initializations* *after-save-initializations*
44 *editor-lisp-p* *clx-server-displays*))
45
46 (in-package "LISP")
47
48 ;;; These go here so that we can refer to them in top-level forms.
49
50 (defvar *before-save-initializations* ()
51 "This is a list of functions which are called before creating a saved core
52 image. These functions are executed in the child process which has no ports,
53 so they cannot do anything that tries to talk to the outside world.")
54
55 (defvar *after-save-initializations* ()
56 "This is a list of functions which are called when a saved core image starts
57 up. The system itself should be initialized at this point, but applications
58 might not be.")
59
60 ;;; Make the error system enable interrupts.
61
62 (defconstant most-positive-fixnum (1- (ash 1 30))
63 "The fixnum closest in value to positive infinity.")
64
65 (defconstant most-negative-fixnum (ash -1 30)
66 "The fixnum closest in value to negative infinity.")
67
68
69 ;;; Random information:
70
71 (defvar compiler-version "???")
72 (defvar *lisp-implementation-version* "4.0(?)")
73
74 (defvar *in-the-compiler* nil
75 "Bound to T while running code inside the compiler. Macros may test this to
76 see where they are being expanded.")
77
78 (defparameter %fasl-code-format #.vm:target-fasl-code-format)
79
80
81 ;;;; Global ports:
82
83 (defvar *task-self* 1
84 "Port that refers to the current task.")
85
86 (defvar *task-data* 2
87 "Port used to receive data for the current task.")
88
89 (defvar *nameserverport* ()
90 "Port to the name server.")
91
92
93
94 ;;; GC stuff.
95
96 (defvar *gc-inhibit* nil) ; Inhibits GC's.
97
98 (defvar *already-maybe-gcing* nil) ; Inhibits recursive GC's.
99
100 (defvar *need-to-collect-garbage* nil
101 "*Need-to-collect-garbage* is set to T when GC is disabled, but the system
102 needs to do a GC. When GC is enabled again, the GC is done then.")
103
104
105
106 ;;;; Reply port allocation.
107 ;;;
108 ;;; We maintain a global stack of reply ports which is shared among
109 ;;; all matchmaker interfaces, and could be used by other people as well.
110 ;;;
111
112 #| More stuff that will probably be drastically different.
113
114 ;;; The stack is represented by a vector, and a pointer to the first
115 ;;; free port. The stack grows upward. There is always at least one
116 ;;; NIL entry in the stack after the last allocated port.
117 ;;;
118 (defvar *reply-port-stack* (make-array 16)) ; Vector of reply ports.
119 (defvar *reply-port-pointer* 0) ; Index of first free port.
120 (defvar *reply-port-depth* 0) ; Dynamic depth in With-Reply-Port forms.
121
122 ;;; We use this as the reply port when allocating or deallocating reply
123 ;;; ports to get around potentially nasty interactions. Interrupts
124 ;;; are always off when we are doing this, so we don't have to have
125 ;;; more than one of these, or worry about unwinding.
126 (defvar *allocate-reply-port* (mach:mach-task_data))
127
128 ;;; Reset-Reply-Port-Stack -- Internal
129 ;;;
130 ;;; This is a before-save initialization which Nil's out the reply
131 ;;; port stack and sets *allocate-reply-port* back to DataPort so that
132 ;;; things initialize right at OS-Init time.
133 ;;;
134 (defun reset-reply-port-stack ()
135 (setq *reply-port-pointer* 0 *reply-port-depth* 0)
136 (fill (the simple-vector *reply-port-stack*) nil)
137 (setq *allocate-reply-port* (mach:mach-task_data)))
138 (pushnew 'reset-reply-port-stack *before-save-initializations*)
139
140 ;;; Allocate-New-Reply-Ports -- Internal
141 ;;;
142 ;;; If we run out of reply ports, we allocate another one, possibly
143 ;;; growing the stack.
144 ;;;
145 (defun allocate-new-reply-ports ()
146 (let* ((stack *reply-port-stack*)
147 (pointer *reply-port-pointer*)
148 (len (length stack)))
149 (declare (simple-vector stack) (fixnum len))
150 (when (eql pointer (1- len))
151 (let ((new (make-array (* len 2))))
152 (replace new stack :end1 len :end2 len)
153 (setq stack new *reply-port-stack* new)))
154 (setf (svref stack pointer) *allocate-reply-port*)
155 (let ((port (gr-call* mach:port_allocate (mach:mach-task_self))))
156 (gr-call mach:port_disable (mach:mach-task_self) port)
157 ;;
158 ;; Nil out the allocate reply port so it isn't used for mundane purposes.
159 (setf (svref stack pointer) nil)
160 (setf (svref stack (1- pointer)) port)
161 port)))
162
163 ;;; Reallocate-Reply-Ports -- Internal
164 ;;;
165 ;;; This function is called when With-Reply-Port finds the stack pointer
166 ;;; to be other than what it expected when it finishes. Reallocates all
167 ;;; of the ports on the stack from Start to *reply-port-pointer*. We
168 ;;; stick the *allocate-reply-port* out at *reply-port-pointer*, and
169 ;;; bind *reply-port-depth*, so that the allocation functions are happy.
170 ;;;
171 (defun reallocate-reply-ports (start)
172 (let* ((pointer *reply-port-pointer*)
173 (*reply-port-depth* pointer)
174 (stack *reply-port-stack*)
175 (save-port (svref stack pointer)))
176 (when (> start pointer)
177 (error "More ports in use than allocated???"))
178 (setf (svref stack pointer) *allocate-reply-port*)
179 (do ((i start (1+ i)))
180 ((= i pointer)
181 (setf (svref stack pointer) save-port))
182 (let ((port (svref stack i)))
183 (gr-call mach:port_deallocate *task-self* port)
184 (setf (svref stack i)
185 (gr-call* mach:port_allocate *task-self*))))))
186 |#
187
188
189 ;;;; Server stuff:
190 #|
191 ;;;
192 ;;; There is a fair amount of stuff to support Matchmaker RPC servers
193 ;;; and asynchonous message service. RPC message service needs to be
194 ;;; centralized since a server must receive on all ports, and there is
195 ;;; no way for a particular server to know about all other servers
196 ;;; in the same lisp.
197 ;;;
198 ;;; The idea is that you receive the message, and then dispatch off
199 ;;; of the port received on and the message ID received. Ports correspond
200 ;;; to objects that the server manages. Message ID's correspond to the
201 ;;; operations on the objects. Objects are grouped into object sets, which
202 ;;; are sets of objects having the same operations defined.
203 ;;;
204 ;;; The same mechanism is used for handling asynchronous messages.
205 ;;;
206
207 ;;; The current implementation uses standard eq[l] hashtables for both
208 ;;; levels of dispatching. Special purpose data structures would be more
209 ;;; efficient, but the ~1ms overhead will probably be lost in the noise.
210
211 ;;;
212 ;;; Hashtable from ports to objects. Each entry is a cons (object . set).
213 ;;;
214 (defvar *port-table* (make-hash-table :test #'eql))
215
216 ;;; Hashtable from windows to objects. Each entry is a cons (object . set).
217 ;;;
218 (defvar *xwindow-table* (make-hash-table :test #'eql))
219
220
221 (defstruct (object-set
222 (:constructor make-object-set
223 (name &optional
224 (default-handler #'default-default-handler)))
225 (:print-function
226 (lambda (s stream d)
227 (declare (ignore d))
228 (format stream "#<Object Set ~S>" (object-set-name s)))))
229 name ; Name, for descriptive purposes.
230 (table (make-hash-table :test #'eq)) ; Message-ID or xevent-type --> handler fun.
231 default-handler)
232
233 (setf (documentation 'make-object-set 'function)
234 "Make an object set for use by a RPC/xevent server. Name is for
235 descriptive purposes only.")
236
237
238 ;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and
239 ;;; object set mapped to by a xwindow or port in *xwindow-table* or
240 ;;; *port-table*.
241 ;;;
242 (macrolet ((defmapper (name table)
243 `(defun ,(intern (concatenate 'simple-string
244 "MAP-" (symbol-name name)))
245 (,name)
246 ,(format nil "Return as multiple values the object and ~
247 object-set mapped to by ~A."
248 (string-downcase (symbol-name name)))
249 (let ((temp (gethash ,name ,table)))
250 (if temp
251 (values (car temp) (cdr temp))
252 (values nil nil))))))
253 (defmapper port *port-table*)
254 (defmapper xwindow *xwindow-table*))
255
256
257 ;;; ADD-PORT-OBJECT and ADD-XWINDOW-OBJECT store an object/object-set pair
258 ;;; mapped to by a port or xwindow in either *port-table* or *xwindow-table*.
259 ;;;
260 (macrolet ((def-add-object (name table)
261 `(defun ,(intern (concatenate 'simple-string
262 "ADD-" (symbol-name name)
263 "-OBJECT"))
264 (,name object object-set)
265 ,(format nil "Add a new ~A/object/object-set association."
266 (string-downcase (symbol-name name)))
267 (check-type object-set object-set)
268 (setf (gethash ,name ,table) (cons object object-set))
269 object)))
270 (def-add-object port *port-table*)
271 (def-add-object xwindow *xwindow-table*))
272
273
274 ;;; REMOVE-PORT-OBJECT and REMOVE-XWINDOW-OBJECT remove a port or xwindow and
275 ;;; its associated object/object-set pair from *port-table* or *xwindow-table*.
276 ;;;
277 (macrolet ((def-remove-object (name table)
278 `(defun ,(intern (concatenate 'simple-string
279 "REMOVE-" (symbol-name name)
280 "-OBJECT"))
281 (,name)
282 ,(format nil
283 "Remove ~A and its associated object/object-set pair."
284 (string-downcase (symbol-name name)))
285 (remhash ,name ,table))))
286 (def-remove-object port *port-table*)
287 (def-remove-object xwindow *xwindow-table*))
288
289
290 ;;; Object-Set-Operation -- Public
291 ;;;
292 ;;; Look up the handler function for a given message ID.
293 ;;;
294 (defun object-set-operation (object-set message-id)
295 "Return the handler function in Object-Set for the operation specified by
296 Message-ID, if none, NIL is returned. The handler function is passed
297 the object. The received message is in server-Message."
298 (check-type object-set object-set)
299 (check-type message-id fixnum)
300 (values (gethash message-id (object-set-table object-set))))
301
302 ;;; %Set-Object-Set-Operation -- Internal
303 ;;;
304 ;;; The setf inverse for Object-Set-Operation.
305 ;;;
306 (defun %set-object-set-operation (object-set message-id new-value)
307 (check-type object-set object-set)
308 (check-type message-id fixnum)
309 (setf (gethash message-id (object-set-table object-set)) new-value))
310 ;;;
311 (defsetf object-set-operation %set-object-set-operation
312 "Sets the handler function for an object set operation.")
313 |#
314
315
316
317 ;;;; Emergency Message Handling:
318 ;;;
319 ;;; We use the same mechanism for asynchronous messages as is used for
320 ;;; normal server messages. The only tricky part is that we don't want
321 ;;; some random server function being called when we really want to
322 ;;; receive an emergency message, so we can't receive on all ports.
323 ;;; Instead, we use MessagesWaiting to find the ports with emergency
324 ;;; messages.
325
326 #| still more noise that will be different.
327
328 (defalien waiting-ports nil (long-words 128))
329
330 ;;; Service-Emergency-Message-Interrupt -- Internal
331 ;;;
332 ;;; This is a lot like the server function, but we only receive on
333 ;;; ports with one emergency message. We only receive one message because
334 ;;; the handler function might have caused any other messages to be received.
335 ;;; When we re-enable interrupts, if any emergency messages are left, we
336 ;;; should be interrupted again.
337 ;;;
338 (defun service-emergency-message-interrupt ()
339 (grab-message-loop))
340
341 ;;;
342 ;;; This object set is used for DataPort, which is the port various magical
343 ;;; message from the kernel are received on...
344 (defvar *kernel-messages* (make-object-set "Kernel Messages"))
345
346 (compiler-let ((*alien-eval-when* '(compile eval)))
347 (defrecord port-death-msg
348 (msg mach:msg #.(record-size 'mach:msg))
349 (ex-port-tt pad (long-words 1))
350 (ex-port (signed-byte 32) (long-words 1)))
351
352 (defoperator (server-message-port-death-msg port-death-msg)
353 ((msg server-message))
354 `(alien-index (alien-value ,msg) 0 (record-size 'port-death-msg)))
355 ); Compiler-Let
356
357
358 ;;; *Port-Death-Handlers* is an EQ hash table of lists of functions that are
359 ;;; called upon port death. If a port dies that is not in the table, we print
360 ;;; out a message on *Trace-Output* describing its death. If
361 ;;; *Pornography-Of-Death* is true, we don't even print that message.
362
363 (defvar *port-death-handlers* (make-hash-table :test #'eql)
364 "Don't use this --- use Add-Port-Death-Handler instead.")
365
366 ;;; Add-Port-Death-Handler, Remove-Port-Death-Handler -- Public
367 ;;;
368 (defun add-port-death-handler (port function)
369 "Make Function a handler for port death on Port. When the port dies,
370 Function is called with the port and an argument. See also
371 Remove-Port-Death-Handler."
372 (pushnew function (gethash port *port-death-handlers*))
373 nil)
374 ;;;
375 (defun remove-port-death-handler (port function)
376 "Undoes the effect of Add-Port-Death-Handler."
377 (setf (gethash port *port-death-handlers*)
378 (delete function (gethash port *port-death-handlers*)))
379 nil)
380
381 (setf (object-set-operation *kernel-messages* mach:notify-port-deleted)
382 #'(lambda (obj)
383 (declare (ignore obj))
384 (let* ((ex-port (alien-access
385 (port-death-msg-ex-port
386 (server-message-port-death-msg server-message))))
387 (handlers (gethash ex-port *port-death-handlers*)))
388 (remhash ex-port *port-table*)
389 (remhash ex-port *port-death-handlers*)
390 (if (null handlers)
391 (handle-unclaimed-port-death ex-port)
392 (dolist (fun handlers) (funcall fun ex-port))))
393 mach:kern-success))
394
395 (defvar *pornography-of-death* t
396 "If true, nothing is said about port deaths.")
397
398 (defun handle-unclaimed-port-death (port)
399 (unless *pornography-of-death*
400 (format *trace-output* "~&[Port ~S just bit the dust.]~%" port)))
401
402 ;;; Port receive and ownership rights messages are handled simlarly, but
403 ;;; by default we deallocate the port to make sure it's really dead. This
404 ;;; gets around problems with ports being exhausted because some servers
405 ;;; don't really nuke the port when the deallocate the object.
406 ;;;
407
408 (defvar *port-receive-rights-handlers* (make-hash-table :test #'eql)
409 "This is a hashtable from ports to functions. The function is called with
410 the port as its argument when a port receive rights message for that port
411 is received from the kernel.")
412
413 (defvar *port-ownership-rights-handlers* (make-hash-table :test #'eql)
414 "This is a hashtable from ports to functions. The function is called with
415 the port as its argument when a port ownership rights message for that port
416 is received from the kernel.")
417
418 (setf (object-set-operation *kernel-messages* mach:notify-receive-rights)
419 #'(lambda (obj)
420 (declare (ignore obj))
421 (let ((ex-port (alien-access
422 (port-death-msg-ex-port
423 (server-message-port-death-msg server-message)))))
424 (funcall (gethash ex-port *port-receive-rights-handlers*
425 #'handle-unclaimed-port-rights)
426 ex-port))
427 mach:kern-success))
428
429 (setf (object-set-operation *kernel-messages* mach:notify-ownership-rights)
430 #'(lambda (obj)
431 (declare (ignore obj))
432 (let ((ex-port (alien-access
433 (port-death-msg-ex-port
434 (server-message-port-death-msg server-message)))))
435 (funcall (gethash ex-port *port-ownership-rights-handlers*
436 #'handle-unclaimed-port-rights)
437 ex-port))
438 mach:kern-success))
439
440 (defun handle-unclaimed-port-rights (port)
441 (unless *pornography-of-death*
442 (format *trace-output* "~&[Rights received for port ~D, deallocating it.]~%"
443 port))
444 (mach:port_deallocate *task-self* port)
445 (remhash port *port-receive-rights-handlers*)
446 (remhash port *port-ownership-rights-handlers*)
447 (remhash port *port-table*))
448
449 (add-port-object *task-data* nil *kernel-messages*)
450
451 ;;; Clear-Port-Tables -- Internal
452 ;;;
453 ;;; A before-save initialization which clears all of the port hashtables.
454 ;;;
455 (defun clear-port-tables ()
456 (clrhash *port-table*)
457 (clrhash *port-death-handlers*)
458 (clrhash *port-receive-rights-handlers*)
459 (clrhash *port-ownership-rights-handlers*))
460
461 (pushnew 'clear-port-tables *before-save-initializations*)
462
463 |#
464
465
466
467 ;;; %Initial-Function is called when a cold system starts up. First we zoom
468 ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
469 ;;; at "load time." Then we initialize the various subsystems and call the
470 ;;; read-eval-print loop. The top-level Read-Eval-Print loop is executed until
471 ;;; someone (most likely the Quit function) throws to the tag
472 ;;; %End-Of-The-World. We quit this way so that all outstanding cleanup forms
473 ;;; in Unwind-Protects will get executed.
474
475 (proclaim '(special *lisp-initialization-functions*))
476
477 (eval-when (compile)
478 (defmacro print-and-call (name)
479 `(progn
480 (%primitive print ,(symbol-name name))
481 (,name))))
482
483 (defun %initial-function ()
484 "Gives the world a shove and hopes it spins."
485 (setq *already-maybe-gcing* t)
486 (setf *gc-inhibit* t)
487 (setf *need-to-collect-garbage* nil)
488 (%primitive print "In initial-function, and running.")
489
490 ;; Many top-level forms call INFO, (SETF INFO).
491 (print-and-call c::globaldb-init)
492
493 ;; Some of the random top-level forms call Make-Array, which calls Subtypep...
494 (print-and-call type-init)
495
496 (setq *lisp-initialization-functions*
497 (nreverse *lisp-initialization-functions*))
498 (%primitive print "Calling top-level forms.")
499 (dolist (fun *lisp-initialization-functions*)
500 (%primitive print fun)
501 (funcall fun))
502 (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
503
504 (print-and-call os-init)
505 #+nil
506 (print-and-call filesys-init)
507 #+nil
508 (print-and-call conditions::error-init)
509
510 #+nil
511 (print-and-call reader-init)
512 #+nil
513 (print-and-call backq-init)
514 #+nil
515 (print-and-call sharp-init)
516 ;; After the various reader subsystems have done their thing to the standard
517 ;; readtable, copy it to *readtable*.
518 #+nil
519 (setq *readtable* (copy-readtable std-lisp-readtable))
520
521 #+nil
522 (print-and-call stream-init)
523 #+nil
524 (print-and-call random-init)
525 #+nil
526 (print-and-call format-init)
527 #+nil
528 (print-and-call package-init)
529 #+nil
530 (print-and-call pprint-init)
531
532 (setq *already-maybe-gcing* nil)
533 (terpri)
534 (princ "CMU Common Lisp kernel core image ")
535 (princ (lisp-implementation-version))
536 (princ ".")
537 (terpri)
538 (princ "[You are in the LISP package.]")
539 (terpri)
540 (catch '%end-of-the-world
541 (loop
542 (%top-level)
543 (write-line "You're certainly a clever child.")))
544 #+nil
545 (mach:unix-exit 0))
546
547
548 ;;;; Initialization functions:
549
550 ;;; Reinit is called to reinitialize the world when a saved core image
551 ;;; is resumed.
552 (defvar *task-notify* NIL)
553
554 (defun reinit ()
555 (without-interrupts
556 (setq *already-maybe-gcing* t)
557 (os-init)
558 #+nil
559 (stream-reinit)
560 (setq *already-maybe-gcing* nil))
561 #+nil
562 (setq *task-notify* (mach:mach-task_notify))
563 #+nil
564 (mach:port_enable (mach:mach-task_self) *task-notify*)
565 #+nil
566 (add-port-object *task-notify* nil *kernel-messages*)
567 #+nil
568 (init-mach-signals))
569
570
571 ;;; OS-Init initializes our operating-system interface. It sets the values
572 ;;; of the global port variables to what they should be and calls the functions
573 ;;; that set up the argument blocks for the server interfaces.
574
575 (defun os-init ()
576 #+nil
577 (setq *task-self* (mach:mach-task_self))
578 #+nil
579 (setq *task-data* (mach:mach-task_data)))
580
581
582 ;;; Setup-path-search-list returns a list of the directories that are
583 ;;; in the unix path environment variable. This is so that run-program
584 ;;; can be smarter about where to find a program to run.
585 (defun setup-path-search-list ()
586 (let ((path (cdr (assoc :path ext::*environment-list*))))
587 (when path
588 (do* ((i 0 (1+ p))
589 (p (position #\: path :start i)
590 (position #\: path :start i))
591 (pl ()))
592 ((null p)
593 (let ((s (subseq path i)))
594 (if (string= s "")
595 (push "default:" pl)
596 (push (concatenate 'simple-string s "/") pl)))
597 (nreverse pl))
598 (let ((s (subseq path i p)))
599 (if (string= s "")
600 (push "default:" pl)
601 (push (concatenate 'simple-string s "/") pl)))))))
602
603
604 ;;;; Miscellaneous external functions:
605
606 (defun print-herald ()
607 (write-string "CMU Common Lisp ")
608 (write-line (lisp-implementation-version))
609 (write-string "Hemlock ") (write-string *hemlock-version*)
610 (write-string ", Compiler ") (write-line compiler-version)
611 (write-line "Send bug reports and questions to Gripe.")
612 (values))
613
614 (defvar *editor-lisp-p* nil
615 "This is true if and only if the lisp was started with the -edit switch.")
616
617 #+nil ;; Can't save lisps yet
618 (defun save-lisp (core-file-name &key
619 (purify t)
620 (root-structures ())
621 (init-function
622 #'(lambda ()
623 (throw 'top-level-catcher nil)))
624 (load-init-file t)
625 (print-herald t)
626 (process-command-line t))
627 "Saves a Spice Lisp core image in the file of the specified name. The
628 following keywords are defined:
629
630 :purify
631 If true, do a purifying GC which moves all dynamically allocated
632 objects into static space so that they stay pure. This takes somewhat
633 longer than the normal GC which is otherwise done, but GC's will done
634 less often and take less time in the resulting core file.
635
636 :root-structures
637 This should be a list of the main entry points in any newly loaded
638 systems. This need not be supplied, but locality will be better if it
639 is. This is meaningless if :purify is Nil.
640
641 :init-function
642 This is a function which is called when the created core file is
643 resumed. The default function simply aborts to the top level
644 read-eval-print loop. If the function returns it will be the value
645 of Save-Lisp.
646
647 :load-init-file
648 If true, then look for an init.lisp or init.fasl file when the core
649 file is resumed.
650
651 :print-herald
652 If true, print out the lisp system herald when starting."
653
654 (if purify
655 (purify :root-structures root-structures)
656 (gc))
657 (unless (save core-file-name)
658 (setf (search-list "default:") (list (default-directory)))
659 (setf (search-list "path:") (setup-path-search-list))
660 (when process-command-line (ext::process-command-strings))
661 (setf *editor-lisp-p* nil)
662 (macrolet ((find-switch (name)
663 `(find ,name *command-line-switches*
664 :key #'cmd-switch-name
665 :test #'(lambda (x y)
666 (declare (simple-string x y))
667 (string-equal x y)))))
668 (when (and process-command-line (find-switch "edit"))
669 (setf *editor-lisp-p* t))
670 (when (and load-init-file
671 (not (and process-command-line (find-switch "noinit"))))
672 (let* ((cl-switch (find-switch "init"))
673 (name (or (and cl-switch
674 (or (cmd-switch-value cl-switch)
675 (car (cmd-switch-words cl-switch))
676 "init"))
677 "init")))
678 (load (merge-pathnames name (user-homedir-pathname))
679 :if-does-not-exist nil))))
680 (when print-herald
681 (print-herald))
682 (when process-command-line
683 (ext::invoke-switch-demons *command-line-switches*
684 *command-switch-demons*))
685 (funcall init-function)))
686
687
688 ;;; Quit gets us out, one way or another.
689
690 (defun quit (&optional recklessly-p)
691 "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
692 non-Nil."
693 (if recklessly-p
694 (mach:unix-exit 0)
695 (throw '%end-of-the-world nil)))
696
697
698 #| might be something different.
699
700 (defalien sleep-msg mach:msg (record-size 'mach:msg))
701 (setf (alien-access (mach:msg-simplemsg sleep-msg)) T)
702 (setf (alien-access (mach:msg-msgtype sleep-msg)) 0)
703 (setf (alien-access (mach:msg-msgsize sleep-msg))
704 (/ (record-size 'mach:msg) 8))
705
706 ;;; Currently there is a bug in the Mach timeout code that if the timeout
707 ;;; period is too short the receive never returns.
708
709 (defun sleep (n)
710 "This function causes execution to be suspended for N seconds. N may
711 be any non-negative, non-complex number."
712 (with-reply-port (sleep-port)
713 (let ((m (round (* 1000 n))))
714 (cond ((minusp m)
715 (error "Argument to Sleep, ~S, is a negative number." n))
716 ((zerop m))
717 (t
718 (setf (alien-access (mach:msg-localport sleep-msg)) sleep-port)
719 (let ((gr (mach:msg-receive sleep-msg mach:rcv-timeout m)))
720 (unless (eql gr mach:rcv-timed-out)
721 (gr-error 'mach:receive gr)))))))
722 nil)
723
724 |#
725
726
727 ;;;; TOP-LEVEL loop.
728
729 (defvar / nil
730 "Holds a list of all the values returned by the most recent top-level EVAL.")
731 (defvar // nil "Gets the previous value of / when a new value is computed.")
732 (defvar /// nil "Gets the previous value of // when a new value is computed.")
733 (defvar * nil "Holds the value of the most recent top-level EVAL.")
734 (defvar ** nil "Gets the previous value of * when a new value is computed.")
735 (defvar *** nil "Gets the previous value of ** when a new value is computed.")
736 (defvar + nil "Holds the value of the most recent top-level READ.")
737 (defvar ++ nil "Gets the previous value of + when a new value is read.")
738 (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
739 (defvar - nil "Holds the form curently being evaluated.")
740 (defvar *prompt* "* "
741 "The top-level prompt string. This also may be a function of no arguments
742 that returns a simple-string.")
743 (defvar *in-top-level-catcher* nil
744 "True if we are within the Top-Level-Catcher. This is used by interrupt
745 handlers to see whether it is o.k. to throw.")
746
747 (defun interactive-eval (form)
748 "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
749 +, ///, //, /, and -."
750 (setf +++ ++
751 ++ +
752 + -
753 - form)
754 (let ((results (multiple-value-list (eval form))))
755 (setf /// //
756 // /
757 / results
758 *** **
759 ** *
760 * (car results)))
761 (unless (boundp '*)
762 ;; The bogon returned an unbound marker.
763 (setf * nil)
764 (cerror "Go on with * set to NIL."
765 "EVAL returned an unbound marker."))
766 (values-list /))
767
768 (defconstant eofs-before-quit 10)
769
770 (defun %top-level ()
771 "Top-level READ-EVAL-PRINT loop. Do not call this."
772 (let ((* nil) (** nil) (*** nil)
773 (- nil) (+ nil) (++ nil) (+++ nil)
774 (/// nil) (// nil) (/ nil)
775 (magic-eof-cookie (cons :eof nil))
776 (number-of-eofs 0))
777 (loop
778 (with-simple-restart (abort "Return to Top-Level.")
779 (catch 'top-level-catcher
780 (let ((*in-top-level-catcher* t))
781 (loop
782 (fresh-line)
783 (princ (if (functionp *prompt*)
784 (funcall *prompt*)
785 *prompt*))
786 (force-output)
787 (let ((form (read *standard-input* nil magic-eof-cookie)))
788 (cond ((not (eq form magic-eof-cookie))
789 (let ((results
790 (multiple-value-list (interactive-eval form))))
791 (dolist (result results)
792 (fresh-line)
793 (prin1 result)))
794 (setf number-of-eofs 0))
795 ((eql (incf number-of-eofs) 1)
796 (let ((stream (make-synonym-stream '*terminal-io*)))
797 (setf *standard-input* stream)
798 (setf *standard-output* stream)
799 (format t "~&Received EOF on *standard-input*, ~
800 switching to *terminal-io*.~%")))
801 ((> number-of-eofs eofs-before-quit)
802 (format t "~&Received more than ~D EOFs; Aborting.~%"
803 eofs-before-quit)
804 (quit))
805 (t
806 (format t "~&Received EOF.~%")))))))))))
807
808
809
810 ;;; %Halt -- Interface
811 ;;;
812 ;;; A convenient way to get into the assembly level debugger.
813 ;;;
814 (defun %halt ()
815 (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5