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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5