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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5