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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5