/[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.1 - (hide annotations) (vendor branch)
Mon Mar 12 19:06:39 1990 UTC (24 years, 1 month ago) by wlott
Changes since 1.1: +82 -495 lines
Initail MIPS version.  Mostly commented things out.
1 ram 1.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     ;;; Initialization and low-level interrupt support for the Spice Lisp system.
11     ;;; Written by Skef Wholey and Rob MacLachlan.
12     ;;;
13     (in-package "LISP" :use '("SYSTEM" "DEBUG"))
14    
15     (in-package "XLIB")
16    
17     (in-package "LISP")
18    
19     (export '(most-positive-fixnum most-negative-fixnum sleep
20     ++ +++ ** *** // ///))
21    
22    
23 wlott 1.1.1.1 (in-package "SYSTEM" :nicknames '("SYS"))
24 ram 1.1 (export '(add-port-death-handler remove-port-death-handler sap-int
25     int-sap sap-ref-8 sap-ref-16 sap-ref-32 without-gcing
26     *in-the-compiler* compiler-version *pornography-of-death*
27     *port-receive-rights-handlers* *port-ownership-rights-handlers*
28     without-interrupts with-reply-port map-port add-port-object
29     remove-port-object make-object-set object-set-operation
30     server-message *xwindow-table* map-xwindow add-xwindow-object
31     remove-xwindow-object server-event coerce-to-key-event
32     coerce-to-motion-event coerce-to-expose-event
33     coerece-to-exposecopy-event coerce-to-focuschange-event server
34     *nameserverport* *usertypescript* *userwindow* *typescriptport*
35     *task-self* *task-data* *task-notify* *file-input-handlers*
36     with-interrupts with-enabled-interrupts enable-interrupt
37 wlott 1.1.1.1 ignore-interrupt default-interrupt))
38 ram 1.1
39     (in-package "EXTENSIONS")
40     (export '(quit *prompt* print-herald save-lisp gc-on gc-off
41     *before-save-initializations* *after-save-initializations*
42 wlott 1.1.1.1 *editor-lisp-p* *clx-server-displays*))
43 ram 1.1
44     (in-package "LISP")
45    
46     ;;; These go here so that we can refer to them in top-level forms.
47    
48     (defvar *before-save-initializations* ()
49     "This is a list of functions which are called before creating a saved core
50     image. These functions are executed in the child process which has no ports,
51     so they cannot do anything that tries to talk to the outside world.")
52    
53     (defvar *after-save-initializations* ()
54     "This is a list of functions which are called when a saved core image starts
55     up. The system itself should be initialized at this point, but applications
56     might not be.")
57    
58     ;;; Make the error system enable interrupts.
59    
60 wlott 1.1.1.1 (defconstant most-positive-fixnum (1- (ash 1 30))
61 ram 1.1 "The fixnum closest in value to positive infinity.")
62    
63 wlott 1.1.1.1 (defconstant most-negative-fixnum (ash -1 30)
64 ram 1.1 "The fixnum closest in value to negative infinity.")
65    
66    
67     ;;; Random information:
68    
69     (defvar compiler-version "???")
70 wlott 1.1.1.1 (defvar *lisp-implementation-version* "3.0(?)")
71 ram 1.1
72 wlott 1.1.1.1 (defvar *in-the-compiler* nil
73 ram 1.1 "Bound to T while running code inside the compiler. Macros may test this to
74     see where they are being expanded.")
75    
76 wlott 1.1.1.1 (defparameter %fasl-code-format vm:target-fasl-code-format)
77 ram 1.1
78    
79     ;;;; Global ports:
80    
81     (defvar *task-self* 1
82     "Port that refers to the current task.")
83    
84     (defvar *task-data* 2
85     "Port used to receive data for the current task.")
86    
87     (defvar *nameserverport* ()
88     "Port to the name server.")
89    
90 wlott 1.1.1.1
91 ram 1.1
92     ;;; GC stuff.
93    
94 wlott 1.1.1.1 #| Again, will be different.
95    
96 ram 1.1 (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 wlott 1.1.1.1 |#
105 ram 1.1
106    
107    
108     ;;;; Reply port allocation.
109     ;;;
110     ;;; We maintain a global stack of reply ports which is shared among
111     ;;; all matchmaker interfaces, and could be used by other people as well.
112     ;;;
113 wlott 1.1.1.1
114     #| More stuff that will probably be drastically different.
115    
116 ram 1.1 ;;; The stack is represented by a vector, and a pointer to the first
117     ;;; free port. The stack grows upward. There is always at least one
118     ;;; NIL entry in the stack after the last allocated port.
119     ;;;
120     (defvar *reply-port-stack* (make-array 16)) ; Vector of reply ports.
121     (defvar *reply-port-pointer* 0) ; Index of first free port.
122     (defvar *reply-port-depth* 0) ; Dynamic depth in With-Reply-Port forms.
123    
124     ;;; We use this as the reply port when allocating or deallocating reply
125     ;;; ports to get around potentially nasty interactions. Interrupts
126     ;;; are always off when we are doing this, so we don't have to have
127     ;;; more than one of these, or worry about unwinding.
128     (defvar *allocate-reply-port* (mach:mach-task_data))
129    
130     ;;; Reset-Reply-Port-Stack -- Internal
131     ;;;
132     ;;; This is a before-save initialization which Nil's out the reply
133     ;;; port stack and sets *allocate-reply-port* back to DataPort so that
134     ;;; things initialize right at OS-Init time.
135     ;;;
136     (defun reset-reply-port-stack ()
137     (setq *reply-port-pointer* 0 *reply-port-depth* 0)
138     (fill (the simple-vector *reply-port-stack*) nil)
139     (setq *allocate-reply-port* (mach:mach-task_data)))
140     (pushnew 'reset-reply-port-stack *before-save-initializations*)
141    
142     ;;; Allocate-New-Reply-Ports -- Internal
143     ;;;
144     ;;; If we run out of reply ports, we allocate another one, possibly
145     ;;; growing the stack.
146     ;;;
147     (defun allocate-new-reply-ports ()
148     (let* ((stack *reply-port-stack*)
149     (pointer *reply-port-pointer*)
150     (len (length stack)))
151     (declare (simple-vector stack) (fixnum len))
152     (when (eql pointer (1- len))
153     (let ((new (make-array (* len 2))))
154     (replace new stack :end1 len :end2 len)
155     (setq stack new *reply-port-stack* new)))
156     (setf (svref stack pointer) *allocate-reply-port*)
157     (let ((port (gr-call* mach:port_allocate (mach:mach-task_self))))
158     (gr-call mach:port_disable (mach:mach-task_self) port)
159     ;;
160     ;; Nil out the allocate reply port so it isn't used for mundane purposes.
161     (setf (svref stack pointer) nil)
162     (setf (svref stack (1- pointer)) port)
163     port)))
164    
165     ;;; Reallocate-Reply-Ports -- Internal
166     ;;;
167     ;;; This function is called when With-Reply-Port finds the stack pointer
168     ;;; to be other than what it expected when it finishes. Reallocates all
169     ;;; of the ports on the stack from Start to *reply-port-pointer*. We
170     ;;; stick the *allocate-reply-port* out at *reply-port-pointer*, and
171     ;;; bind *reply-port-depth*, so that the allocation functions are happy.
172     ;;;
173     (defun reallocate-reply-ports (start)
174     (let* ((pointer *reply-port-pointer*)
175     (*reply-port-depth* pointer)
176     (stack *reply-port-stack*)
177     (save-port (svref stack pointer)))
178     (when (> start pointer)
179     (error "More ports in use than allocated???"))
180     (setf (svref stack pointer) *allocate-reply-port*)
181     (do ((i start (1+ i)))
182     ((= i pointer)
183     (setf (svref stack pointer) save-port))
184     (let ((port (svref stack i)))
185     (gr-call mach:port_deallocate *task-self* port)
186     (setf (svref stack i)
187     (gr-call* mach:port_allocate *task-self*))))))
188 wlott 1.1.1.1 |#
189 ram 1.1
190    
191     ;;;; Server stuff:
192     ;;;
193     ;;; There is a fair amount of stuff to support Matchmaker RPC servers
194     ;;; and asynchonous message service. RPC message service needs to be
195     ;;; centralized since a server must receive on all ports, and there is
196     ;;; no way for a particular server to know about all other servers
197     ;;; in the same lisp.
198     ;;;
199     ;;; The idea is that you receive the message, and then dispatch off
200     ;;; of the port received on and the message ID received. Ports correspond
201     ;;; to objects that the server manages. Message ID's correspond to the
202     ;;; operations on the objects. Objects are grouped into object sets, which
203     ;;; are sets of objects having the same operations defined.
204     ;;;
205     ;;; The same mechanism is used for handling asynchronous messages.
206     ;;;
207    
208     ;;; The current implementation uses standard eq[l] hashtables for both
209     ;;; levels of dispatching. Special purpose data structures would be more
210     ;;; efficient, but the ~1ms overhead will probably be lost in the noise.
211    
212     ;;;
213     ;;; Hashtable from ports to objects. Each entry is a cons (object . set).
214     ;;;
215     (defvar *port-table* (make-hash-table :test #'eql))
216    
217     ;;; Hashtable from windows to objects. Each entry is a cons (object . set).
218     ;;;
219     (defvar *xwindow-table* (make-hash-table :test #'eql))
220    
221    
222     (defstruct (object-set
223     (:constructor make-object-set
224     (name &optional
225     (default-handler #'default-default-handler)))
226     (:print-function
227     (lambda (s stream d)
228     (declare (ignore d))
229     (format stream "#<Object Set ~S>" (object-set-name s)))))
230     name ; Name, for descriptive purposes.
231     (table (make-hash-table :test #'eq)) ; Message-ID or xevent-type --> handler fun.
232     default-handler)
233    
234     (setf (documentation 'make-object-set 'function)
235     "Make an object set for use by a RPC/xevent server. Name is for
236     descriptive purposes only.")
237    
238    
239     ;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and
240     ;;; object set mapped to by a xwindow or port in *xwindow-table* or
241     ;;; *port-table*.
242     ;;;
243     (macrolet ((defmapper (name table)
244     `(defun ,(intern (concatenate 'simple-string
245     "MAP-" (symbol-name name)))
246     (,name)
247     ,(format nil "Return as multiple values the object and ~
248     object-set mapped to by ~A."
249     (string-downcase (symbol-name name)))
250     (let ((temp (gethash ,name ,table)))
251     (if temp
252     (values (car temp) (cdr temp))
253     (values nil nil))))))
254     (defmapper port *port-table*)
255     (defmapper xwindow *xwindow-table*))
256    
257    
258     ;;; ADD-PORT-OBJECT and ADD-XWINDOW-OBJECT store an object/object-set pair
259     ;;; mapped to by a port or xwindow in either *port-table* or *xwindow-table*.
260     ;;;
261     (macrolet ((def-add-object (name table)
262     `(defun ,(intern (concatenate 'simple-string
263     "ADD-" (symbol-name name)
264     "-OBJECT"))
265     (,name object object-set)
266     ,(format nil "Add a new ~A/object/object-set association."
267     (string-downcase (symbol-name name)))
268     (check-type object-set object-set)
269     (setf (gethash ,name ,table) (cons object object-set))
270     object)))
271     (def-add-object port *port-table*)
272     (def-add-object xwindow *xwindow-table*))
273    
274    
275     ;;; REMOVE-PORT-OBJECT and REMOVE-XWINDOW-OBJECT remove a port or xwindow and
276     ;;; its associated object/object-set pair from *port-table* or *xwindow-table*.
277     ;;;
278     (macrolet ((def-remove-object (name table)
279     `(defun ,(intern (concatenate 'simple-string
280     "REMOVE-" (symbol-name name)
281     "-OBJECT"))
282     (,name)
283     ,(format nil
284     "Remove ~A and its associated object/object-set pair."
285     (string-downcase (symbol-name name)))
286     (remhash ,name ,table))))
287     (def-remove-object port *port-table*)
288     (def-remove-object xwindow *xwindow-table*))
289    
290    
291     ;;; Object-Set-Operation -- Public
292     ;;;
293     ;;; Look up the handler function for a given message ID.
294     ;;;
295     (defun object-set-operation (object-set message-id)
296     "Return the handler function in Object-Set for the operation specified by
297     Message-ID, if none, NIL is returned. The handler function is passed
298     the object. The received message is in server-Message."
299     (check-type object-set object-set)
300     (check-type message-id fixnum)
301     (values (gethash message-id (object-set-table object-set))))
302    
303     ;;; %Set-Object-Set-Operation -- Internal
304     ;;;
305     ;;; The setf inverse for Object-Set-Operation.
306     ;;;
307     (defun %set-object-set-operation (object-set message-id new-value)
308     (check-type object-set object-set)
309     (check-type message-id fixnum)
310     (setf (gethash message-id (object-set-table object-set)) new-value))
311     ;;;
312     (defsetf object-set-operation %set-object-set-operation
313     "Sets the handler function for an object set operation.")
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 wlott 1.1.1.1 #| still more noise that will be different.
327    
328 ram 1.1 (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 wlott 1.1.1.1 |#
464    
465    
466 ram 1.1
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 ',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 wlott 1.1.1.1 (setf *gc-inhibit* t)
487 ram 1.1 (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 subtypep-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     (funcall fun))
501     (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
502    
503     (print-and-call os-init)
504     (print-and-call filesys-init)
505     (print-and-call conditions::error-init)
506    
507     (print-and-call reader-init)
508     (print-and-call backq-init)
509     (print-and-call sharp-init)
510     ;; After the various reader subsystems have done their thing to the standard
511     ;; readtable, copy it to *readtable*.
512     (setq *readtable* (copy-readtable std-lisp-readtable))
513    
514     (print-and-call stream-init)
515     (print-and-call random-init)
516     (print-and-call format-init)
517     (print-and-call package-init)
518     (print-and-call pprint-init)
519    
520     (setq *already-maybe-gcing* nil)
521     (terpri)
522     (princ "CMU Common Lisp kernel core image ")
523     (princ (lisp-implementation-version))
524     (princ ".")
525     (terpri)
526     (princ "[You are in the LISP package.]")
527     (terpri)
528     (catch '%end-of-the-world
529     (loop
530     (%top-level)
531     (write-line "You're certainly a clever child.")))
532     (mach:unix-exit 0))
533    
534    
535     ;;;; Initialization functions:
536    
537     ;;; Reinit is called to reinitialize the world when a saved core image
538     ;;; is resumed.
539     (defvar *task-notify* NIL)
540    
541     (defun reinit ()
542     (without-interrupts
543     (setq *already-maybe-gcing* t)
544     (os-init)
545     (stream-reinit)
546     (setq *already-maybe-gcing* nil))
547     (setq *task-notify* (mach:mach-task_notify))
548     (mach:port_enable (mach:mach-task_self) *task-notify*)
549     (add-port-object *task-notify* nil *kernel-messages*)
550     (init-mach-signals))
551    
552    
553     ;;; OS-Init initializes our operating-system interface. It sets the values
554     ;;; of the global port variables to what they should be and calls the functions
555     ;;; that set up the argument blocks for the server interfaces.
556    
557     (defun os-init ()
558     (setq *task-self* (mach:mach-task_self))
559     (setq *task-data* (mach:mach-task_data)))
560    
561    
562     ;;; Setup-path-search-list returns a list of the directories that are
563     ;;; in the unix path environment variable. This is so that run-program
564     ;;; can be smarter about where to find a program to run.
565     (defun setup-path-search-list ()
566     (let ((path (cdr (assoc :path ext::*environment-list*))))
567     (when path
568     (do* ((i 0 (1+ p))
569     (p (position #\: path :start i)
570     (position #\: path :start i))
571     (pl ()))
572     ((null p)
573     (let ((s (subseq path i)))
574     (if (string= s "")
575     (push "default:" pl)
576     (push (concatenate 'simple-string s "/") pl)))
577     (nreverse pl))
578     (let ((s (subseq path i p)))
579     (if (string= s "")
580     (push "default:" pl)
581     (push (concatenate 'simple-string s "/") pl)))))))
582    
583    
584     ;;;; Miscellaneous external functions:
585    
586     (defun print-herald ()
587     (write-string "CMU Common Lisp ")
588     (write-line (lisp-implementation-version))
589     (write-string "Hemlock ") (write-string *hemlock-version*)
590     (write-string ", Compiler ") (write-line compiler-version)
591     (write-line "Send bug reports and questions to Gripe.")
592     (values))
593    
594     (defvar *editor-lisp-p* nil
595     "This is true if and only if the lisp was started with the -edit switch.")
596    
597 wlott 1.1.1.1 #+nil ;; Can't save lisps yet
598 ram 1.1 (defun save-lisp (core-file-name &key
599     (purify t)
600     (root-structures ())
601     (init-function
602     #'(lambda ()
603     (throw 'top-level-catcher nil)))
604     (load-init-file t)
605     (print-herald t)
606     (process-command-line t))
607     "Saves a Spice Lisp core image in the file of the specified name. The
608     following keywords are defined:
609    
610     :purify
611     If true, do a purifying GC which moves all dynamically allocated
612     objects into static space so that they stay pure. This takes somewhat
613     longer than the normal GC which is otherwise done, but GC's will done
614     less often and take less time in the resulting core file.
615    
616     :root-structures
617     This should be a list of the main entry points in any newly loaded
618     systems. This need not be supplied, but locality will be better if it
619     is. This is meaningless if :purify is Nil.
620    
621     :init-function
622     This is a function which is called when the created core file is
623     resumed. The default function simply aborts to the top level
624     read-eval-print loop. If the function returns it will be the value
625     of Save-Lisp.
626    
627     :load-init-file
628     If true, then look for an init.lisp or init.fasl file when the core
629     file is resumed.
630    
631     :print-herald
632     If true, print out the lisp system herald when starting."
633    
634     (if purify
635     (purify :root-structures root-structures)
636     (gc))
637     (unless (save core-file-name)
638     (setf (search-list "default:") (list (default-directory)))
639     (setf (search-list "path:") (setup-path-search-list))
640     (when process-command-line (ext::process-command-strings))
641     (setf *editor-lisp-p* nil)
642     (macrolet ((find-switch (name)
643     `(find ,name *command-line-switches*
644     :key #'cmd-switch-name
645     :test #'(lambda (x y)
646     (declare (simple-string x y))
647     (string-equal x y)))))
648     (when (and process-command-line (find-switch "edit"))
649     (setf *editor-lisp-p* t))
650     (when (and load-init-file
651     (not (and process-command-line (find-switch "noinit"))))
652     (let* ((cl-switch (find-switch "init"))
653     (name (or (and cl-switch
654     (or (cmd-switch-value cl-switch)
655     (car (cmd-switch-words cl-switch))
656     "init"))
657     "init")))
658     (load (merge-pathnames name (user-homedir-pathname))
659     :if-does-not-exist nil))))
660     (when print-herald
661     (print-herald))
662     (when process-command-line
663     (ext::invoke-switch-demons *command-line-switches*
664     *command-switch-demons*))
665     (funcall init-function)))
666    
667    
668     ;;; Quit gets us out, one way or another.
669    
670     (defun quit (&optional recklessly-p)
671     "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
672     non-Nil."
673     ; (reset-keyboard 0)
674     (dolist (x (if (boundp 'extensions::temporary-foreign-files)
675     extensions::temporary-foreign-files))
676     (mach:unix-unlink x))
677     (if recklessly-p
678     (mach:unix-exit 0)
679     (throw '%end-of-the-world nil)))
680    
681    
682 wlott 1.1.1.1 #| might be something different.
683 ram 1.1
684     (defalien sleep-msg mach:msg (record-size 'mach:msg))
685     (setf (alien-access (mach:msg-simplemsg sleep-msg)) T)
686     (setf (alien-access (mach:msg-msgtype sleep-msg)) 0)
687     (setf (alien-access (mach:msg-msgsize sleep-msg))
688     (/ (record-size 'mach:msg) 8))
689    
690     ;;; Currently there is a bug in the Mach timeout code that if the timeout
691     ;;; period is too short the receive never returns.
692    
693     (defun sleep (n)
694     "This function causes execution to be suspended for N seconds. N may
695     be any non-negative, non-complex number."
696     (with-reply-port (sleep-port)
697     (let ((m (round (* 1000 n))))
698     (cond ((minusp m)
699     (error "Argument to Sleep, ~S, is a negative number." n))
700     ((zerop m))
701     (t
702     (setf (alien-access (mach:msg-localport sleep-msg)) sleep-port)
703     (let ((gr (mach:msg-receive sleep-msg mach:rcv-timeout m)))
704     (unless (eql gr mach:rcv-timed-out)
705     (gr-error 'mach:receive gr)))))))
706     nil)
707    
708 wlott 1.1.1.1 |#
709    
710 ram 1.1
711     ;;;; TOP-LEVEL loop.
712    
713     (defvar / nil
714     "Holds a list of all the values returned by the most recent top-level EVAL.")
715     (defvar // nil "Gets the previous value of / when a new value is computed.")
716     (defvar /// nil "Gets the previous value of // when a new value is computed.")
717     (defvar * nil "Holds the value of the most recent top-level EVAL.")
718     (defvar ** nil "Gets the previous value of * when a new value is computed.")
719     (defvar *** nil "Gets the previous value of ** when a new value is computed.")
720     (defvar + nil "Holds the value of the most recent top-level READ.")
721     (defvar ++ nil "Gets the previous value of + when a new value is read.")
722     (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
723     (defvar - nil "Holds the form curently being evaluated.")
724 wlott 1.1.1.1 (defvar *prompt* "* "
725     "The top-level prompt string. This also may be a function of no arguments
726     that returns a simple-string.")
727 ram 1.1 (defvar *in-top-level-catcher* nil
728     "True if we are within the Top-Level-Catcher. This is used by interrupt
729     handlers to see whether it is o.k. to throw.")
730    
731 wlott 1.1.1.1 (defun interactive-eval (form)
732     "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
733     +, ///, //, /, and -."
734     (setf +++ ++
735     ++ +
736     + -
737     - form)
738     (let ((results (multiple-value-list (eval form))))
739     (setf /// //
740     // /
741     / results
742     *** **
743     ** *
744     * (car results)))
745     (unless (boundp '*)
746     ;; The bogon returned an unbound marker.
747     (setf * nil)
748     (cerror "Go on with * set to NIL."
749     "EVAL returned an unbound marker."))
750     (values-list /))
751    
752     (defconstant eofs-before-quit 10)
753    
754 ram 1.1 (defun %top-level ()
755     "Top-level READ-EVAL-PRINT loop. Do not call this."
756 wlott 1.1.1.1 (let ((* nil) (** nil) (*** nil)
757 ram 1.1 (- nil) (+ nil) (++ nil) (+++ nil)
758 wlott 1.1.1.1 (/// nil) (// nil) (/ nil)
759     (magic-eof-cookie (cons :eof nil))
760     (number-of-eofs 0))
761 ram 1.1 (loop
762     (with-simple-restart (abort "Return to Top-Level.")
763     (catch 'top-level-catcher
764     (let ((*in-top-level-catcher* t))
765     (loop
766 wlott 1.1.1.1 (fresh-line)
767     (princ (if (functionp *prompt*)
768     (funcall *prompt*)
769     *prompt*))
770     (force-output)
771     (let ((form (read *standard-input* nil magic-eof-cookie)))
772     (cond ((not (eq form magic-eof-cookie))
773     (let ((results
774     (multiple-value-list (interactive-eval form))))
775     (dolist (result results)
776     (fresh-line)
777     (prin1 result)))
778     (setf number-of-eofs 0))
779     ((eql (incf number-of-eofs) 1)
780     (let ((stream (make-synonym-stream '*terminal-io*)))
781     (setf *standard-input* stream)
782     (setf *standard-output* stream)
783     (format t "~&Received EOF on *standard-input*, ~
784     switching to *terminal-io*.~%")))
785     ((> number-of-eofs eofs-before-quit)
786     (format t "~&Received more than ~D EOFs; Aborting.~%"
787     eofs-before-quit)
788     (quit))
789     (t
790     (format t "~&Received EOF.~%")))))))))))
791 ram 1.1
792    
793 wlott 1.1.1.1
794 ram 1.1 ;;; %Halt -- Interface
795     ;;;
796     ;;; A convenient way to get into the assembly level debugger.
797     ;;;
798     (defun %halt ()
799     (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5