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

  ViewVC Help
Powered by ViewVC 1.1.5