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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5