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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5