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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Thu Feb 22 12:08:26 1990 UTC (24 years, 1 month ago) by ram
Branch: MAIN
Changes since 1.2: +57 -28 lines
Merged in new %TOP-LEVEL from working code sources.
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     ;;; Initialization and low-level interrupt support for the Spice Lisp system.
11     ;;; Written by Skef Wholey and Rob MacLachlan.
12     ;;;
13     (in-package "LISP" :use '("SYSTEM" "DEBUG"))
14    
15     (in-package "XLIB")
16    
17     (in-package "LISP")
18    
19     (export '(most-positive-fixnum most-negative-fixnum sleep
20     ++ +++ ** *** // ///))
21    
22    
23     (in-package "SYSTEM")
24     (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     *nameserverport* *usertypescript* *userwindow* *typescriptport*
35     *task-self* *task-data* *task-notify* *file-input-handlers*
36     with-interrupts with-enabled-interrupts enable-interrupt
37     ignore-interrupt default-interrupt serve-all))
38    
39     (in-package "EXTENSIONS")
40     (export '(quit *prompt* print-herald save-lisp gc-on gc-off
41     *before-save-initializations* *after-save-initializations*
42     *editor-lisp-p* *clx-server-displays* *display-event-handlers*))
43    
44     (in-package "LISP")
45    
46     ;;; These go here so that we can refer to them in top-level forms.
47    
48     (defvar *before-save-initializations* ()
49     "This is a list of functions which are called before creating a saved core
50     image. These functions are executed in the child process which has no ports,
51     so they cannot do anything that tries to talk to the outside world.")
52    
53     (defvar *after-save-initializations* ()
54     "This is a list of functions which are called when a saved core image starts
55     up. The system itself should be initialized at this point, but applications
56     might not be.")
57    
58     ;;; Make the error system enable interrupts.
59    
60     (defconstant most-positive-fixnum 134217727
61     "The fixnum closest in value to positive infinity.")
62    
63     (defconstant most-negative-fixnum -134217728
64     "The fixnum closest in value to negative infinity.")
65    
66    
67     ;;; Random information:
68    
69     (defvar compiler-version "???")
70 ram 1.3 (defvar *lisp-implementation-version* "3.0(?)")
71 ram 1.1
72     (defvar *in-the-compiler* ()
73     "Bound to T while running code inside the compiler. Macros may test this to
74     see where they are being expanded.")
75    
76     (defparameter %fasl-code-format 6)
77    
78    
79     ;;;; Global ports:
80    
81     (defvar *task-self* 1
82     "Port that refers to the current task.")
83    
84     (defvar *task-data* 2
85     "Port used to receive data for the current task.")
86    
87     (defvar *nameserverport* ()
88     "Port to the name server.")
89    
90    
91     ;;; GC stuff.
92    
93     (defvar *gc-inhibit* nil) ; Inhibits GC's.
94    
95     (defvar *already-maybe-gcing* nil) ; Inhibits recursive GC's.
96    
97     (defvar *need-to-collect-garbage* nil
98     "*Need-to-collect-garbage* is set to T when GC is disabled, but the system
99     needs to do a GC. When GC is enabled again, the GC is done then.")
100    
101    
102     ;;; Software interrupt stuff.
103    
104     (defvar *in-server* NIL
105     "*In-server* is set to T when the SIGMSG interrupt has been enabled
106     in Server.")
107    
108     (defvar server-unique-object (cons 1 2))
109    
110     (defconstant lockout-interrupts (logior (mach:sigmask mach:sigint)
111     (mach:sigmask mach:sigquit)
112     (mach:sigmask mach:sigfpe)
113     (mach:sigmask mach:sigsys)
114     (mach:sigmask mach:sigpipe)
115     (mach:sigmask mach:sigalrm)
116     (mach:sigmask mach:sigurg)
117     (mach:sigmask mach:sigstop)
118     (mach:sigmask mach:sigtstp)
119     (mach:sigmask mach:sigcont)
120     (mach:sigmask mach:sigchld)
121     (mach:sigmask mach:sigttin)
122     (mach:sigmask mach:sigttou)
123     (mach:sigmask mach:sigio)
124     (mach:sigmask mach:sigxcpu)
125     (mach:sigmask mach:sigxfsz)
126     (mach:sigmask mach:sigvtalrm)
127     (mach:sigmask mach:sigprof)
128     (mach:sigmask mach:sigwinch)
129     (mach:sigmask mach:sigmsg)
130     (mach:sigmask mach:sigemsg)))
131    
132     (defconstant interrupt-stack-size 4096
133     "Size of stack for Unix interrupts.")
134    
135     (defvar software-interrupt-stack NIL
136     "Address of the stack used by Mach to send signals to Lisp.")
137    
138     (defvar %sp-interrupts-inhibited nil
139     "True if emergency message interrupts should be inhibited, false otherwise.")
140    
141     (defvar *software-interrupt-vector*
142     (make-array mach::maximum-interrupts)
143     "A vector that associates Lisp functions with Unix interrupts.")
144    
145     (defun enable-interrupt (interrupt function &optional character)
146     "Enable one Unix interrupt and associate a Lisp function with it.
147     Interrupt should be the number of the interrupt to enable. Function
148     should be a funcallable object that will be called with three
149     arguments: the signal code, a subcode, and the context of the
150     interrupt. The optional character should be an ascii character or
151     an integer that causes the interrupt from the keyboard. This argument
152     is only used for SIGINT, SIGQUIT, and SIGTSTP interrupts and is ignored
153     for any others. Returns the old function associated with the interrupt
154     and the character that generates it if the interrupt is one of SIGINT,
155     SIGQUIT, SIGTSTP and character was specified."
156     (unless (< 0 interrupt mach::maximum-interrupts)
157     (error "Interrupt number ~D is not between 1 and ~D."
158     mach::maximum-interrupts))
159     (let ((old-fun (svref *software-interrupt-vector* interrupt))
160     (old-char ()))
161     (when (and character
162     (or (eq interrupt mach:sigint)
163     (eq interrupt mach:sigquit)
164     (eq interrupt mach:sigtstp)))
165     (when (characterp character)
166     (setq character (char-code character)))
167     (when (mach:unix-isatty 0)
168     (if (or (eq interrupt mach:sigint)
169     (eq interrupt mach:sigquit))
170     (mach:with-trap-arg-block mach:tchars tc
171     (multiple-value-bind
172     (val err)
173     (mach:unix-ioctl 0 mach:TIOCGETC
174     (alien-value-sap mach:tchars))
175     (if (null val)
176     (error "Failed to get tchars information, unix error ~S."
177     (mach:get-unix-error-msg err))))
178     (cond ((eq interrupt mach:sigint)
179     (setq old-char
180     (alien-access (mach::tchars-intrc (alien-value tc))))
181     (setf (alien-access (mach::tchars-intrc (alien-value tc)))
182     character))
183     (T
184     (setq old-char
185     (alien-access (mach::tchars-quitc (alien-value tc))))
186     (setf (alien-access (mach::tchars-quitc (alien-value tc)))
187     character)))
188     (multiple-value-bind
189     (val err)
190     (mach:unix-ioctl 0 mach:tiocsetc
191     (alien-value-sap mach:tchars))
192     (if (null val)
193     (error "Failed to set tchars information, unix error ~S."
194     (mach:get-unix-error-msg err)))))
195     (mach:with-trap-arg-block mach:ltchars tc
196     (multiple-value-bind
197     (val err)
198     (mach:unix-ioctl 0 mach:TIOCGLTC
199     (alien-value-sap mach:ltchars))
200     (if (null val)
201     (error "Failed to get ltchars information, unix error ~S."
202     (mach:get-unix-error-msg err))))
203     (setq old-char
204     (alien-access (mach::ltchars-suspc (alien-value tc))))
205     (setf (alien-access (mach::ltchars-suspc (alien-value tc)))
206     character)
207     (multiple-value-bind
208     (val err)
209     (mach:unix-ioctl 0 mach:TIOCSLTC
210     (alien-value-sap mach:ltchars))
211     (if (null val)
212     (error "Failed to set ltchars information, unix error ~S."
213     (mach:get-unix-error-msg err))))))))
214     (setf (svref *software-interrupt-vector* interrupt) function)
215     (if (null function)
216     (mach:unix-sigvec interrupt mach:sig_dfl 0 0)
217     (let ((diha (+ (ash clc::romp-data-base 16)
218     clc::software-interrupt-offset)))
219     (mach:unix-sigvec interrupt diha lockout-interrupts 1)))
220     (if old-char
221     (values old-fun old-char)
222     old-fun)))
223    
224     (defun ignore-interrupt (interrupt)
225     "The Unix interrupt handling mechanism is set up so that interrupt is
226     ignored."
227     (unless (< 0 interrupt mach::maximum-interrupts)
228     (error "Interrupt number ~D is not between 1 and 31."))
229     (let ((old-fun (svref *software-interrupt-vector* interrupt)))
230     (mach:unix-sigvec interrupt mach:sig_ign 0 0)
231     (setf (svref *software-interrupt-vector* interrupt) NIL)
232     old-fun))
233    
234     (defun default-interrupt (interrupt)
235     "The Unix interrupt handling mechanism is set up to do the default action
236     under mach. Lisp will not get control of the interrupt."
237     (unless (< 0 interrupt mach::maximum-interrupts)
238     (error "Interrupt number ~D is not between 1 and 31."))
239     (let ((old-fun (svref *software-interrupt-vector* interrupt)))
240     (mach:unix-sigvec interrupt mach:sig_dfl 0 0)
241     (setf (svref *software-interrupt-vector* interrupt) NIL)
242     old-fun))
243    
244    
245     ;;; %SP-Software-Interrupt-Handler is called by the miscops when a Unix
246     ;;; signal arrives. The three arguments correspond to the information
247     ;;; passed to a normal Unix signal handler, i.e.:
248     ;;; signal -- the Unix signal number.
249     ;;; code -- a code for those signals which can be caused by more
250     ;;; than one kind of event. This code specifies the sub-event.
251     ;;; scp -- a pointer to the context of the signal.
252    
253     ;;; Because of the way %sp-software-interrupt-handler returns, it doesn't
254     ;;; unwind the binding stack properly. The only variable affected by this
255     ;;; is software-interrupt-stack, so it must be handled specially.
256    
257     (defun %sp-software-interrupt-handler (signal code scp stack)
258     (declare (optimize (speed 3) (safety 0)))
259     (if (and %sp-interrupts-inhibited
260     (not (memq signal '(#.mach:sigill #.mach:sigbus #.mach:sigsegv))))
261     (progn
262     (let ((iin %sp-interrupts-inhibited))
263     (setq %sp-interrupts-inhibited
264     (nconc (if (consp iin) iin)
265     (list `(,signal ,code ,scp))))
266     (mach:unix-sigsetmask 0)))
267     (let* ((old-stack software-interrupt-stack)
268     (new-stack ())
269     (%sp-interrupts-inhibited T))
270     (unwind-protect
271     (progn
272     (when *in-server*
273     (mach:unix-sigvec mach:sigmsg mach::sig_dfl 0 0))
274     (multiple-value-bind (gr addr)
275     (mach:vm_allocate *task-self* 0
276     interrupt-stack-size t)
277     (gr-error 'mach:vm_allocate gr '%sp-software-interrupt-handler)
278     (setq software-interrupt-stack
279     (int-sap (+ addr interrupt-stack-size))))
280     (setq new-stack software-interrupt-stack)
281     (mach:unix-sigstack new-stack 0)
282     (mach:unix-sigsetmask 0)
283     (funcall (svref *software-interrupt-vector* signal)
284     signal code scp)
285     (mach:unix-sigsetmask lockout-interrupts))
286     (mach:vm_deallocate *task-self*
287     (- (sap-int new-stack)
288     interrupt-stack-size)
289     interrupt-stack-size)
290     (setq software-interrupt-stack old-stack)
291     (mach:unix-sigstack old-stack 0)
292     (when *in-server*
293     (let ((diha (+ (ash clc::romp-data-base 16)
294     clc::software-interrupt-offset)))
295     (mach:unix-sigvec mach:sigmsg diha lockout-interrupts 1)))
296     (mach:unix-sigsetmask 0))))
297     (%primitive break-return stack))
298    
299    
300     (defun ih-sigint (signal code scp)
301     (declare (ignore signal code scp))
302     (without-hemlock
303     (with-interrupts
304     (break "Software Interrupt" t))))
305    
306     (defun ih-sigquit (signal code scp)
307     (declare (ignore signal code scp))
308     (throw 'top-level-catcher nil))
309    
310     (defun ih-sigtstp (signal code scp)
311     (declare (ignore signal code scp))
312     (without-hemlock
313     ; (reset-keyboard 0)
314     (mach:unix-kill (mach:unix-getpid) mach:sigstop)))
315    
316     (defun ih-sigill (signal code scp)
317     (declare (ignore signal code))
318     (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
319     'mach:sigcontext)
320     mach:sigcontext T))
321     (error "Illegal instruction encountered at IAR ~X."
322     (alien-access (mach::sigcontext-iar (alien-value context))))))
323    
324     (defun ih-sigbus (signal code scp)
325     (declare (ignore signal code))
326     (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
327     'mach:sigcontext)
328     mach:sigcontext T))
329     (with-interrupts
330     (error "Bus error encountered at IAR ~X."
331     (alien-access (mach::sigcontext-iar (alien-value context)))))))
332    
333     (defun ih-sigsegv (signal code scp)
334     (declare (ignore signal code))
335     (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
336     'mach:sigcontext)
337     mach:sigcontext T))
338     (with-interrupts
339     (error "Segment violation encountered at IAR ~X."
340     (alien-access (mach::sigcontext-iar (alien-value context)))))))
341    
342     (defun ih-sigfpe (signal code scp)
343     (declare (ignore signal code))
344     (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
345     'mach:sigcontext)
346     mach:sigcontext T))
347     (with-interrupts
348     (error "Floating point exception encountered at IAR ~X."
349     (alien-access (mach::sigcontext-iar (alien-value context)))))))
350    
351     ;;; When we're in server then throw back to server. If we're not
352     ;;; in server then just ignore the sigmsg interrupt. We can't handle
353     ;;; it and we should never get it anyway. But of course we do -- it's
354     ;;; dealing with interrupts and there funny at best.
355     (defun ih-sigmsg (signal code scp)
356     (declare (ignore signal code scp))
357     (mach:unix-sigsetmask (mach:sigmask mach:sigmsg))
358     (default-interrupt mach:sigmsg)
359     (when *in-server*
360     (setq *in-server* nil)
361     (throw 'server-catch server-unique-object)))
362    
363     (defun ih-sigemsg (signal code scp)
364     (declare (ignore signal code scp))
365     (service-emergency-message-interrupt))
366    
367     (defun init-mach-signals ()
368     (declare (optimize (speed 3) (safety 0)))
369     (multiple-value-bind (gr addr)
370     (mach:vm_allocate *task-self* 0 interrupt-stack-size t)
371     (gr-error 'mach:vm_allocate gr 'enable-interrupt)
372     (setq software-interrupt-stack
373     (int-sap (+ addr interrupt-stack-size))))
374     (let ((iha (get 'clc::interrupt-handler '%loaded-address))
375     (diha (+ (ash clc::romp-data-base 16) clc::software-interrupt-offset)))
376     (%primitive pointer-system-set diha 0 iha))
377     (mach:unix-sigstack software-interrupt-stack 0)
378     (enable-interrupt mach:sigint #'ih-sigint)
379     (enable-interrupt mach:sigquit #'ih-sigquit)
380     (enable-interrupt mach:sigtstp #'ih-sigtstp)
381     (enable-interrupt mach:sigill #'ih-sigill)
382     (enable-interrupt mach:sigbus #'ih-sigbus)
383     (enable-interrupt mach:sigsegv #'ih-sigsegv)
384     (enable-interrupt mach:sigemsg #'ih-sigemsg)
385     (enable-interrupt mach:sigfpe #'ih-sigfpe)
386     ; (reset-keyboard 0)
387     )
388    
389    
390     ;;;; Reply port allocation.
391     ;;;
392     ;;; We maintain a global stack of reply ports which is shared among
393     ;;; all matchmaker interfaces, and could be used by other people as well.
394     ;;;
395     ;;; The stack is represented by a vector, and a pointer to the first
396     ;;; free port. The stack grows upward. There is always at least one
397     ;;; NIL entry in the stack after the last allocated port.
398     ;;;
399     (defvar *reply-port-stack* (make-array 16)) ; Vector of reply ports.
400     (defvar *reply-port-pointer* 0) ; Index of first free port.
401     (defvar *reply-port-depth* 0) ; Dynamic depth in With-Reply-Port forms.
402    
403     ;;; We use this as the reply port when allocating or deallocating reply
404     ;;; ports to get around potentially nasty interactions. Interrupts
405     ;;; are always off when we are doing this, so we don't have to have
406     ;;; more than one of these, or worry about unwinding.
407     (defvar *allocate-reply-port* (mach:mach-task_data))
408    
409     ;;; Reset-Reply-Port-Stack -- Internal
410     ;;;
411     ;;; This is a before-save initialization which Nil's out the reply
412     ;;; port stack and sets *allocate-reply-port* back to DataPort so that
413     ;;; things initialize right at OS-Init time.
414     ;;;
415     (defun reset-reply-port-stack ()
416     (setq *reply-port-pointer* 0 *reply-port-depth* 0)
417     (fill (the simple-vector *reply-port-stack*) nil)
418     (setq *allocate-reply-port* (mach:mach-task_data)))
419     (pushnew 'reset-reply-port-stack *before-save-initializations*)
420    
421     ;;; Allocate-New-Reply-Ports -- Internal
422     ;;;
423     ;;; If we run out of reply ports, we allocate another one, possibly
424     ;;; growing the stack.
425     ;;;
426     (defun allocate-new-reply-ports ()
427     (let* ((stack *reply-port-stack*)
428     (pointer *reply-port-pointer*)
429     (len (length stack)))
430     (declare (simple-vector stack) (fixnum len))
431     (when (eql pointer (1- len))
432     (let ((new (make-array (* len 2))))
433     (replace new stack :end1 len :end2 len)
434     (setq stack new *reply-port-stack* new)))
435     (setf (svref stack pointer) *allocate-reply-port*)
436     (let ((port (gr-call* mach:port_allocate (mach:mach-task_self))))
437     (gr-call mach:port_disable (mach:mach-task_self) port)
438     ;;
439     ;; Nil out the allocate reply port so it isn't used for mundane purposes.
440     (setf (svref stack pointer) nil)
441     (setf (svref stack (1- pointer)) port)
442     port)))
443    
444     ;;; Reallocate-Reply-Ports -- Internal
445     ;;;
446     ;;; This function is called when With-Reply-Port finds the stack pointer
447     ;;; to be other than what it expected when it finishes. Reallocates all
448     ;;; of the ports on the stack from Start to *reply-port-pointer*. We
449     ;;; stick the *allocate-reply-port* out at *reply-port-pointer*, and
450     ;;; bind *reply-port-depth*, so that the allocation functions are happy.
451     ;;;
452     (defun reallocate-reply-ports (start)
453     (let* ((pointer *reply-port-pointer*)
454     (*reply-port-depth* pointer)
455     (stack *reply-port-stack*)
456     (save-port (svref stack pointer)))
457     (when (> start pointer)
458     (error "More ports in use than allocated???"))
459     (setf (svref stack pointer) *allocate-reply-port*)
460     (do ((i start (1+ i)))
461     ((= i pointer)
462     (setf (svref stack pointer) save-port))
463     (let ((port (svref stack i)))
464     (gr-call mach:port_deallocate *task-self* port)
465     (setf (svref stack i)
466     (gr-call* mach:port_allocate *task-self*))))))
467    
468    
469     ;;;; Server stuff:
470     ;;;
471     ;;; There is a fair amount of stuff to support Matchmaker RPC servers
472     ;;; and asynchonous message service. RPC message service needs to be
473     ;;; centralized since a server must receive on all ports, and there is
474     ;;; no way for a particular server to know about all other servers
475     ;;; in the same lisp.
476     ;;;
477     ;;; The idea is that you receive the message, and then dispatch off
478     ;;; of the port received on and the message ID received. Ports correspond
479     ;;; to objects that the server manages. Message ID's correspond to the
480     ;;; operations on the objects. Objects are grouped into object sets, which
481     ;;; are sets of objects having the same operations defined.
482     ;;;
483     ;;; The same mechanism is used for handling asynchronous messages.
484     ;;;
485    
486     ;;; The current implementation uses standard eq[l] hashtables for both
487     ;;; levels of dispatching. Special purpose data structures would be more
488     ;;; efficient, but the ~1ms overhead will probably be lost in the noise.
489    
490     ;;;
491     ;;; Hashtable from ports to objects. Each entry is a cons (object . set).
492     ;;;
493     (defvar *port-table* (make-hash-table :test #'eql))
494    
495     ;;; Hashtable from windows to objects. Each entry is a cons (object . set).
496     ;;;
497     (defvar *xwindow-table* (make-hash-table :test #'eql))
498    
499    
500     (defstruct (object-set
501     (:constructor make-object-set
502     (name &optional
503     (default-handler #'default-default-handler)))
504     (:print-function
505     (lambda (s stream d)
506     (declare (ignore d))
507     (format stream "#<Object Set ~S>" (object-set-name s)))))
508     name ; Name, for descriptive purposes.
509     (table (make-hash-table :test #'eq)) ; Message-ID or xevent-type --> handler fun.
510     default-handler)
511    
512     (setf (documentation 'make-object-set 'function)
513     "Make an object set for use by a RPC/xevent server. Name is for
514     descriptive purposes only.")
515    
516    
517     ;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and
518     ;;; object set mapped to by a xwindow or port in *xwindow-table* or
519     ;;; *port-table*.
520     ;;;
521     (macrolet ((defmapper (name table)
522     `(defun ,(intern (concatenate 'simple-string
523     "MAP-" (symbol-name name)))
524     (,name)
525     ,(format nil "Return as multiple values the object and ~
526     object-set mapped to by ~A."
527     (string-downcase (symbol-name name)))
528     (let ((temp (gethash ,name ,table)))
529     (if temp
530     (values (car temp) (cdr temp))
531     (values nil nil))))))
532     (defmapper port *port-table*)
533     (defmapper xwindow *xwindow-table*))
534    
535    
536     ;;; ADD-PORT-OBJECT and ADD-XWINDOW-OBJECT store an object/object-set pair
537     ;;; mapped to by a port or xwindow in either *port-table* or *xwindow-table*.
538     ;;;
539     (macrolet ((def-add-object (name table)
540     `(defun ,(intern (concatenate 'simple-string
541     "ADD-" (symbol-name name)
542     "-OBJECT"))
543     (,name object object-set)
544     ,(format nil "Add a new ~A/object/object-set association."
545     (string-downcase (symbol-name name)))
546     (check-type object-set object-set)
547     (setf (gethash ,name ,table) (cons object object-set))
548     object)))
549     (def-add-object port *port-table*)
550     (def-add-object xwindow *xwindow-table*))
551    
552    
553     ;;; REMOVE-PORT-OBJECT and REMOVE-XWINDOW-OBJECT remove a port or xwindow and
554     ;;; its associated object/object-set pair from *port-table* or *xwindow-table*.
555     ;;;
556     (macrolet ((def-remove-object (name table)
557     `(defun ,(intern (concatenate 'simple-string
558     "REMOVE-" (symbol-name name)
559     "-OBJECT"))
560     (,name)
561     ,(format nil
562     "Remove ~A and its associated object/object-set pair."
563     (string-downcase (symbol-name name)))
564     (remhash ,name ,table))))
565     (def-remove-object port *port-table*)
566     (def-remove-object xwindow *xwindow-table*))
567    
568    
569     ;;; Object-Set-Operation -- Public
570     ;;;
571     ;;; Look up the handler function for a given message ID.
572     ;;;
573     (defun object-set-operation (object-set message-id)
574     "Return the handler function in Object-Set for the operation specified by
575     Message-ID, if none, NIL is returned. The handler function is passed
576     the object. The received message is in server-Message."
577     (check-type object-set object-set)
578     (check-type message-id fixnum)
579     (values (gethash message-id (object-set-table object-set))))
580    
581     ;;; %Set-Object-Set-Operation -- Internal
582     ;;;
583     ;;; The setf inverse for Object-Set-Operation.
584     ;;;
585     (defun %set-object-set-operation (object-set message-id new-value)
586     (check-type object-set object-set)
587     (check-type message-id fixnum)
588     (setf (gethash message-id (object-set-table object-set)) new-value))
589     ;;;
590     (defsetf object-set-operation %set-object-set-operation
591     "Sets the handler function for an object set operation.")
592    
593     ;;;; Server function:
594     ;;;
595     ;;; SERVER makes use of a defined alien, server-event, that lives at address 0.
596     ;;; This is a bogus alien used just as a dynamic variable that is declared
597     ;;; appropriately for the compiler. This alien variable is bound to stuff in
598     ;;; an alien stack by the same name, server-event, which contains elements much
599     ;;; bigger than necessary to accommodate whatever will come back in the future
600     ;;; from waiting across ports, sockets, file descriptors, etc. The defined
601     ;;; alien operators allow easy access to server-event as different types of
602     ;;; event by declaring the necessary type for the compiler when the operator
603     ;;; is used.
604    
605    
606     ;;; Currently the server message is 4k bytes, thus serving larger requests
607     ;;; is impossible. If anyone is bothered by this, the size can be increased.
608     ;;; X events are only 24 bytes.
609     ;;;
610    
611     (defconstant server-message-size 4096)
612     (defalien server-message server-message (bytes server-message-size) 0)
613    
614     (define-alien-stack server-message server-message (bytes server-message-size))
615    
616     (defrecord server-message
617     (msg mach:msg #.(record-size 'mach:msg)))
618    
619     (defvar *file-input-handlers* ()
620     "Is an association list of file descriptors and functions to call when
621     input is available on the particular file descriptor.")
622    
623     (defvar *clx-server-displays* ()
624     "Is a list of CLX displays that may have some activity on them.")
625    
626     (defvar *display-event-handlers* nil
627     "This is an alist mapping displays to user functions to be called when
628     SYSTEM:SERVER notices input on a display connection. Do not modify this
629     directly; use EXT:ENABLE-CLX-EVENT-HANDLING. A given display should be
630     represented here only once.")
631    
632    
633     ;;; Default-Default-Handler -- Internal
634     ;;;
635     ;;; If no such operation defined, signal an error.
636     ;;;
637     (defun default-default-handler (object)
638     (alien-bind ((msg (server-message-msg server-message)))
639     (error "No operation for ID ~D on ~S in ~S."
640     (alien-access (mach:msg-id (alien-value msg))) object
641     (car (gethash (alien-access (mach:msg-localport (alien-value msg)))
642     *port-table*)))))
643    
644    
645     ;;; Server -- Public
646     ;;;
647     (defun server (&optional (timeout 0 todef))
648     "Receive on all ports and Xevents and dispatch to the appropriate handler
649     function. If timeout is specified, server will wait the specified time
650     and then return, otherwise it will wait until something happens. Server
651     returns T if something happened and NIL otherwise."
652     (cond ((dolist (d/h ext::*display-event-handlers* nil)
653     (let ((d (car d/h)))
654     (when (xlib::event-listen d)
655     (handler-bind ((error #'(lambda (condx)
656     (declare (ignore condx))
657     (flush-display-events d))))
658     (funcall (cdr d/h) d))
659     (return t))))
660     T)
661     (T
662     (let* ((to (if todef (round (* timeout 1000000))))
663     (fd-mask 0)
664     (omask 0)
665     (value (catch 'server-catch
666     (unwind-protect
667     (progn
668     (setq omask (mach:unix-sigsetmask
669     (mach:sigmask mach:sigmsg)))
670     (unless (grab-message-loop)
671     (let ((*in-server* T))
672     (enable-interrupt mach:sigmsg #'ih-sigmsg)
673     (multiple-value-bind
674     (to1 to2)
675     (if todef (truncate to 1000000))
676     (multiple-value-bind
677     (nfd fdm)
678     (get-fd-info)
679     (mach:unix-sigsetmask 0)
680     (multiple-value-bind
681     (nfnd rfdm)
682     (mach:unix-select nfd fdm 0 0
683     to1 to2)
684     (mach:unix-sigsetmask
685     (mach:sigmask mach:sigmsg))
686     (default-interrupt mach:sigmsg)
687     (setq fd-mask rfdm)
688     nfnd))))))
689     (default-interrupt mach:sigmsg)
690     (mach:unix-sigsetmask omask)))))
691     (cond ((or (null value) (and todef (eq value 0))) NIL)
692     ((eq value server-unique-object)
693     (grab-message-loop)
694     T)
695     ((file-descriptor-ready fd-mask) T))))))
696    
697     ;;; Get-fd-info turns the association list in *file-input-handlers*
698     ;;; into information that unix-select can be called with.
699     (defun Get-fd-info ()
700     (do* ((fdl *file-input-handlers* (cdr fdl)) ;
701     (FD (caar fdl) (caar fdl))
702     (mfd 0)
703     (fdm 0))
704     ((null fdl)
705     (values (1+ mfd) fdm))
706     (setq mfd (max mfd fd))
707     (setq fdm (logior fdm (ash 1 fd)))))
708    
709     ;;; File-descriptor-ready is called when server determines that a file
710     ;;; descriptor has input ready on one ore more of them. It calls the
711     ;;; appropriate handler with the file-descriptor as its argument.
712     ;;; It checks for an xevent first, so they are handled as quickly as
713     ;;; possible.
714     (defun file-descriptor-ready (rfdm)
715     (do ((fd 0 (1+ fd))
716     (ms rfdm (ash ms -1)))
717     ((eq ms 0))
718     (when (/= (the fixnum (logand ms 1)) 0)
719     (let ((info (assoc fd *file-input-handlers* :test #'eq)))
720     (when info
721     (funcall (cdr info) fd)))))
722     T)
723    
724     ;;; Grab-message-loop calls the appropiate handler for an IPC message.
725     (defun grab-message-loop ()
726     (do* ((gr (server-grab-message) (server-grab-message))
727     (flag (/= gr mach:rcv-timed-out)
728     (if (/= gr mach:rcv-timed-out) t flag)))
729     ((= gr mach:rcv-timed-out) flag)))
730    
731     (defun server-grab-message ()
732     (with-stack-alien (sm server-message)
733     (alien-bind ((msg (server-message-msg (alien-value sm))))
734     (setf (alien-access (mach:msg-msgsize (alien-value msg)))
735     server-message-size)
736     (setf (alien-access (mach:msg-localport (alien-value msg)))
737     mach::port-enabled)
738     (let ((gr (mach:msg-receive (alien-value sm) mach::rcv-timeout 0)))
739     (when (eql gr mach:rcv-timed-out)
740     (return-from server-grab-message gr))
741     (unless (eql gr mach:rcv-success)
742     (gr-error 'mach:msg-receive gr))
743     (let* ((server-message (alien-value sm))
744     (port (alien-access (mach:msg-localport (alien-value msg))))
745     (id (alien-access (mach:msg-id (alien-value msg))))
746     (x (gethash port *port-table*))
747     (set (cdr x)))
748     (unless x
749     (error "~D is not known to server (operation: ~D)." port id))
750     (let ((gr (funcall (gethash id (object-set-table set)
751     (object-set-default-handler set))
752     (car x))))
753     (unless (eql gr mach:kern-success)
754     (gr-error 'server gr)))))))
755     mach:kern-success)
756    
757     (defun serve-all (&optional (timeout 0))
758     "Serve-all calls server with the specified timeout. If server does
759     something (returns T) it loops over server with timeout 0 until all
760     events have been served. Serve-all returns T if server did something
761     and other NIL."
762     (do ((res NIL)
763     (sval (server timeout) (server 0)))
764     ((null sval) res)
765     (setq res T)))
766    
767    
768     ;;;; Emergency Message Handling:
769     ;;;
770     ;;; We use the same mechanism for asynchronous messages as is used for
771     ;;; normal server messages. The only tricky part is that we don't want
772     ;;; some random server function being called when we really want to
773     ;;; receive an emergency message, so we can't receive on all ports.
774     ;;; Instead, we use MessagesWaiting to find the ports with emergency
775     ;;; messages.
776    
777     (defalien waiting-ports nil (long-words 128))
778    
779     ;;; Service-Emergency-Message-Interrupt -- Internal
780     ;;;
781     ;;; This is a lot like the server function, but we only receive on
782     ;;; ports with one emergency message. We only receive one message because
783     ;;; the handler function might have caused any other messages to be received.
784     ;;; When we re-enable interrupts, if any emergency messages are left, we
785     ;;; should be interrupted again.
786     ;;;
787     (defun service-emergency-message-interrupt ()
788     (grab-message-loop))
789    
790     ;;;
791     ;;; This object set is used for DataPort, which is the port various magical
792     ;;; message from the kernel are received on...
793     (defvar *kernel-messages* (make-object-set "Kernel Messages"))
794    
795     (compiler-let ((*alien-eval-when* '(compile eval)))
796     (defrecord port-death-msg
797     (msg mach:msg #.(record-size 'mach:msg))
798     (ex-port-tt pad (long-words 1))
799     (ex-port (signed-byte 32) (long-words 1)))
800    
801     (defoperator (server-message-port-death-msg port-death-msg)
802     ((msg server-message))
803     `(alien-index (alien-value ,msg) 0 (record-size 'port-death-msg)))
804     ); Compiler-Let
805    
806    
807     ;;; *Port-Death-Handlers* is an EQ hash table of lists of functions that are
808     ;;; called upon port death. If a port dies that is not in the table, we print
809     ;;; out a message on *Trace-Output* describing its death. If
810     ;;; *Pornography-Of-Death* is true, we don't even print that message.
811    
812     (defvar *port-death-handlers* (make-hash-table :test #'eql)
813     "Don't use this --- use Add-Port-Death-Handler instead.")
814    
815     ;;; Add-Port-Death-Handler, Remove-Port-Death-Handler -- Public
816     ;;;
817     (defun add-port-death-handler (port function)
818     "Make Function a handler for port death on Port. When the port dies,
819     Function is called with the port and an argument. See also
820     Remove-Port-Death-Handler."
821     (pushnew function (gethash port *port-death-handlers*))
822     nil)
823     ;;;
824     (defun remove-port-death-handler (port function)
825     "Undoes the effect of Add-Port-Death-Handler."
826     (setf (gethash port *port-death-handlers*)
827     (delete function (gethash port *port-death-handlers*)))
828     nil)
829    
830     (setf (object-set-operation *kernel-messages* mach:notify-port-deleted)
831     #'(lambda (obj)
832     (declare (ignore obj))
833     (let* ((ex-port (alien-access
834     (port-death-msg-ex-port
835     (server-message-port-death-msg server-message))))
836     (handlers (gethash ex-port *port-death-handlers*)))
837     (remhash ex-port *port-table*)
838     (remhash ex-port *port-death-handlers*)
839     (if (null handlers)
840     (handle-unclaimed-port-death ex-port)
841     (dolist (fun handlers) (funcall fun ex-port))))
842     mach:kern-success))
843    
844     (defvar *pornography-of-death* t
845     "If true, nothing is said about port deaths.")
846    
847     (defun handle-unclaimed-port-death (port)
848     (unless *pornography-of-death*
849     (format *trace-output* "~&[Port ~S just bit the dust.]~%" port)))
850    
851     ;;; Port receive and ownership rights messages are handled simlarly, but
852     ;;; by default we deallocate the port to make sure it's really dead. This
853     ;;; gets around problems with ports being exhausted because some servers
854     ;;; don't really nuke the port when the deallocate the object.
855     ;;;
856    
857     (defvar *port-receive-rights-handlers* (make-hash-table :test #'eql)
858     "This is a hashtable from ports to functions. The function is called with
859     the port as its argument when a port receive rights message for that port
860     is received from the kernel.")
861    
862     (defvar *port-ownership-rights-handlers* (make-hash-table :test #'eql)
863     "This is a hashtable from ports to functions. The function is called with
864     the port as its argument when a port ownership rights message for that port
865     is received from the kernel.")
866    
867     (setf (object-set-operation *kernel-messages* mach:notify-receive-rights)
868     #'(lambda (obj)
869     (declare (ignore obj))
870     (let ((ex-port (alien-access
871     (port-death-msg-ex-port
872     (server-message-port-death-msg server-message)))))
873     (funcall (gethash ex-port *port-receive-rights-handlers*
874     #'handle-unclaimed-port-rights)
875     ex-port))
876     mach:kern-success))
877    
878     (setf (object-set-operation *kernel-messages* mach:notify-ownership-rights)
879     #'(lambda (obj)
880     (declare (ignore obj))
881     (let ((ex-port (alien-access
882     (port-death-msg-ex-port
883     (server-message-port-death-msg server-message)))))
884     (funcall (gethash ex-port *port-ownership-rights-handlers*
885     #'handle-unclaimed-port-rights)
886     ex-port))
887     mach:kern-success))
888    
889     (defun handle-unclaimed-port-rights (port)
890     (unless *pornography-of-death*
891     (format *trace-output* "~&[Rights received for port ~D, deallocating it.]~%"
892     port))
893     (mach:port_deallocate *task-self* port)
894     (remhash port *port-receive-rights-handlers*)
895     (remhash port *port-ownership-rights-handlers*)
896     (remhash port *port-table*))
897    
898     (add-port-object *task-data* nil *kernel-messages*)
899    
900     ;;; Clear-Port-Tables -- Internal
901     ;;;
902     ;;; A before-save initialization which clears all of the port hashtables.
903     ;;;
904     (defun clear-port-tables ()
905     (clrhash *port-table*)
906     (clrhash *port-death-handlers*)
907     (clrhash *port-receive-rights-handlers*)
908     (clrhash *port-ownership-rights-handlers*))
909    
910     (pushnew 'clear-port-tables *before-save-initializations*)
911    
912    
913     ;;; %Initial-Function is called when a cold system starts up. First we zoom
914     ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
915     ;;; at "load time." Then we initialize the various subsystems and call the
916     ;;; read-eval-print loop. The top-level Read-Eval-Print loop is executed until
917     ;;; someone (most likely the Quit function) throws to the tag
918     ;;; %End-Of-The-World. We quit this way so that all outstanding cleanup forms
919     ;;; in Unwind-Protects will get executed.
920    
921     (proclaim '(special *lisp-initialization-functions*))
922    
923     (eval-when (compile)
924     (defmacro print-and-call (name)
925     `(progn
926     (%primitive print ',name)
927     (,name))))
928    
929     (defun %initial-function ()
930     "Gives the world a shove and hopes it spins."
931     (setq *already-maybe-gcing* t)
932 ram 1.2 (setf *gc-inhibit* t)
933 ram 1.1 (setf *need-to-collect-garbage* nil)
934     (%primitive print "In initial-function, and running.")
935    
936     ;; Many top-level forms call INFO, (SETF INFO).
937     (print-and-call c::globaldb-init)
938    
939     ;; Some of the random top-level forms call Make-Array, which calls Subtypep...
940     (print-and-call subtypep-init)
941    
942     (setq *lisp-initialization-functions*
943     (nreverse *lisp-initialization-functions*))
944     (%primitive print "Calling top-level forms.")
945     (dolist (fun *lisp-initialization-functions*)
946     (funcall fun))
947     (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
948    
949     (print-and-call os-init)
950     (print-and-call filesys-init)
951     (print-and-call conditions::error-init)
952    
953     (print-and-call reader-init)
954     (print-and-call backq-init)
955     (print-and-call sharp-init)
956     ;; After the various reader subsystems have done their thing to the standard
957     ;; readtable, copy it to *readtable*.
958     (setq *readtable* (copy-readtable std-lisp-readtable))
959    
960     (print-and-call stream-init)
961     (print-and-call random-init)
962     (print-and-call format-init)
963     (print-and-call package-init)
964     (print-and-call pprint-init)
965    
966     (setq *already-maybe-gcing* nil)
967     (terpri)
968     (princ "CMU Common Lisp kernel core image ")
969     (princ (lisp-implementation-version))
970     (princ ".")
971     (terpri)
972     (princ "[You are in the LISP package.]")
973     (terpri)
974     (catch '%end-of-the-world
975     (loop
976     (%top-level)
977     (write-line "You're certainly a clever child.")))
978     (mach:unix-exit 0))
979    
980    
981     ;;;; Initialization functions:
982    
983     ;;; Reinit is called to reinitialize the world when a saved core image
984     ;;; is resumed.
985     (defvar *task-notify* NIL)
986    
987     (defun reinit ()
988     (without-interrupts
989     (setq *already-maybe-gcing* t)
990     (os-init)
991     (stream-reinit)
992     (setq *already-maybe-gcing* nil))
993     (setq *task-notify* (mach:mach-task_notify))
994     (mach:port_enable (mach:mach-task_self) *task-notify*)
995     (add-port-object *task-notify* nil *kernel-messages*)
996     (init-mach-signals))
997    
998    
999     ;;; OS-Init initializes our operating-system interface. It sets the values
1000     ;;; of the global port variables to what they should be and calls the functions
1001     ;;; that set up the argument blocks for the server interfaces.
1002    
1003     (defun os-init ()
1004     (setq *task-self* (mach:mach-task_self))
1005     (setq *task-data* (mach:mach-task_data)))
1006    
1007    
1008     ;;; Setup-path-search-list returns a list of the directories that are
1009     ;;; in the unix path environment variable. This is so that run-program
1010     ;;; can be smarter about where to find a program to run.
1011     (defun setup-path-search-list ()
1012     (let ((path (cdr (assoc :path ext::*environment-list*))))
1013     (when path
1014     (do* ((i 0 (1+ p))
1015     (p (position #\: path :start i)
1016     (position #\: path :start i))
1017     (pl ()))
1018     ((null p)
1019     (let ((s (subseq path i)))
1020     (if (string= s "")
1021     (push "default:" pl)
1022     (push (concatenate 'simple-string s "/") pl)))
1023     (nreverse pl))
1024     (let ((s (subseq path i p)))
1025     (if (string= s "")
1026     (push "default:" pl)
1027     (push (concatenate 'simple-string s "/") pl)))))))
1028    
1029    
1030     ;;;; Miscellaneous external functions:
1031    
1032     (defun print-herald ()
1033     (write-string "CMU Common Lisp ")
1034     (write-line (lisp-implementation-version))
1035     (write-string "Hemlock ") (write-string *hemlock-version*)
1036     (write-string ", Compiler ") (write-line compiler-version)
1037     (write-line "Send bug reports and questions to Gripe.")
1038     (values))
1039    
1040     (defvar *editor-lisp-p* nil
1041     "This is true if and only if the lisp was started with the -edit switch.")
1042    
1043     (defun save-lisp (core-file-name &key
1044     (purify t)
1045     (root-structures ())
1046     (init-function
1047     #'(lambda ()
1048     (throw 'top-level-catcher nil)))
1049     (load-init-file t)
1050     (print-herald t)
1051     (process-command-line t))
1052     "Saves a Spice Lisp core image in the file of the specified name. The
1053     following keywords are defined:
1054    
1055     :purify
1056     If true, do a purifying GC which moves all dynamically allocated
1057     objects into static space so that they stay pure. This takes somewhat
1058     longer than the normal GC which is otherwise done, but GC's will done
1059     less often and take less time in the resulting core file.
1060    
1061     :root-structures
1062     This should be a list of the main entry points in any newly loaded
1063     systems. This need not be supplied, but locality will be better if it
1064     is. This is meaningless if :purify is Nil.
1065    
1066     :init-function
1067     This is a function which is called when the created core file is
1068     resumed. The default function simply aborts to the top level
1069     read-eval-print loop. If the function returns it will be the value
1070     of Save-Lisp.
1071    
1072     :load-init-file
1073     If true, then look for an init.lisp or init.fasl file when the core
1074     file is resumed.
1075    
1076     :print-herald
1077     If true, print out the lisp system herald when starting."
1078    
1079     (if purify
1080     (purify :root-structures root-structures)
1081     (gc))
1082     (unless (save core-file-name)
1083     (setf (search-list "default:") (list (default-directory)))
1084     (setf (search-list "path:") (setup-path-search-list))
1085     (when process-command-line (ext::process-command-strings))
1086     (setf *editor-lisp-p* nil)
1087     (macrolet ((find-switch (name)
1088     `(find ,name *command-line-switches*
1089     :key #'cmd-switch-name
1090     :test #'(lambda (x y)
1091     (declare (simple-string x y))
1092     (string-equal x y)))))
1093     (when (and process-command-line (find-switch "edit"))
1094     (setf *editor-lisp-p* t))
1095     (when (and load-init-file
1096     (not (and process-command-line (find-switch "noinit"))))
1097     (let* ((cl-switch (find-switch "init"))
1098     (name (or (and cl-switch
1099     (or (cmd-switch-value cl-switch)
1100     (car (cmd-switch-words cl-switch))
1101     "init"))
1102     "init")))
1103     (load (merge-pathnames name (user-homedir-pathname))
1104     :if-does-not-exist nil))))
1105     (when print-herald
1106     (print-herald))
1107     (when process-command-line
1108     (ext::invoke-switch-demons *command-line-switches*
1109     *command-switch-demons*))
1110     (funcall init-function)))
1111    
1112    
1113     ;;; Quit gets us out, one way or another.
1114    
1115     (defun quit (&optional recklessly-p)
1116     "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
1117     non-Nil."
1118     ; (reset-keyboard 0)
1119     (dolist (x (if (boundp 'extensions::temporary-foreign-files)
1120     extensions::temporary-foreign-files))
1121     (mach:unix-unlink x))
1122     (if recklessly-p
1123     (mach:unix-exit 0)
1124     (throw '%end-of-the-world nil)))
1125    
1126    
1127    
1128     (defalien sleep-msg mach:msg (record-size 'mach:msg))
1129     (setf (alien-access (mach:msg-simplemsg sleep-msg)) T)
1130     (setf (alien-access (mach:msg-msgtype sleep-msg)) 0)
1131     (setf (alien-access (mach:msg-msgsize sleep-msg))
1132     (/ (record-size 'mach:msg) 8))
1133    
1134     ;;; Currently there is a bug in the Mach timeout code that if the timeout
1135     ;;; period is too short the receive never returns.
1136    
1137     (defun sleep (n)
1138     "This function causes execution to be suspended for N seconds. N may
1139     be any non-negative, non-complex number."
1140     (with-reply-port (sleep-port)
1141     (let ((m (round (* 1000 n))))
1142     (cond ((minusp m)
1143     (error "Argument to Sleep, ~S, is a negative number." n))
1144     ((zerop m))
1145     (t
1146     (setf (alien-access (mach:msg-localport sleep-msg)) sleep-port)
1147     (let ((gr (mach:msg-receive sleep-msg mach:rcv-timeout m)))
1148     (unless (eql gr mach:rcv-timed-out)
1149     (gr-error 'mach:receive gr)))))))
1150     nil)
1151    
1152    
1153     ;;;; TOP-LEVEL loop.
1154    
1155     (defvar / nil
1156     "Holds a list of all the values returned by the most recent top-level EVAL.")
1157     (defvar // nil "Gets the previous value of / when a new value is computed.")
1158     (defvar /// nil "Gets the previous value of // when a new value is computed.")
1159     (defvar * nil "Holds the value of the most recent top-level EVAL.")
1160     (defvar ** nil "Gets the previous value of * when a new value is computed.")
1161     (defvar *** nil "Gets the previous value of ** when a new value is computed.")
1162     (defvar + nil "Holds the value of the most recent top-level READ.")
1163     (defvar ++ nil "Gets the previous value of + when a new value is read.")
1164     (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
1165     (defvar - nil "Holds the form curently being evaluated.")
1166 ram 1.3 (defvar *prompt* "* "
1167     "The top-level prompt string. This also may be a function of no arguments
1168     that returns a simple-string.")
1169 ram 1.1 (defvar *in-top-level-catcher* nil
1170     "True if we are within the Top-Level-Catcher. This is used by interrupt
1171     handlers to see whether it is o.k. to throw.")
1172    
1173 ram 1.3 (defun interactive-eval (form)
1174     "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
1175     +, ///, //, /, and -."
1176     (setf +++ ++
1177     ++ +
1178     + -
1179     - form)
1180     (let ((results (multiple-value-list (eval form))))
1181     (setf /// //
1182     // /
1183     / results
1184     *** **
1185     ** *
1186     * (car results)))
1187     (unless (boundp '*)
1188     ;; The bogon returned an unbound marker.
1189     (setf * nil)
1190     (cerror "Go on with * set to NIL."
1191     "EVAL returned an unbound marker."))
1192     (values-list /))
1193    
1194     (defconstant eofs-before-quit 10)
1195    
1196 ram 1.1 (defun %top-level ()
1197     "Top-level READ-EVAL-PRINT loop. Do not call this."
1198 ram 1.3 (let ((* nil) (** nil) (*** nil)
1199 ram 1.1 (- nil) (+ nil) (++ nil) (+++ nil)
1200 ram 1.3 (/// nil) (// nil) (/ nil)
1201     (magic-eof-cookie (cons :eof nil))
1202     (number-of-eofs 0))
1203 ram 1.1 (loop
1204     (with-simple-restart (abort "Return to Top-Level.")
1205     (catch 'top-level-catcher
1206     (let ((*in-top-level-catcher* t))
1207     (loop
1208 ram 1.3 (fresh-line)
1209     (princ (if (functionp *prompt*)
1210     (funcall *prompt*)
1211     *prompt*))
1212     (force-output)
1213     (let ((form (read *standard-input* nil magic-eof-cookie)))
1214     (cond ((not (eq form magic-eof-cookie))
1215     (let ((results
1216     (multiple-value-list (interactive-eval form))))
1217     (dolist (result results)
1218     (fresh-line)
1219     (prin1 result)))
1220     (setf number-of-eofs 0))
1221     ((eql (incf number-of-eofs) 1)
1222     (let ((stream (make-synonym-stream '*terminal-io*)))
1223     (setf *standard-input* stream)
1224     (setf *standard-output* stream)
1225     (format t "~&Received EOF on *standard-input*, ~
1226     switching to *terminal-io*.~%")))
1227     ((> number-of-eofs eofs-before-quit)
1228     (format t "~&Received more than ~D EOFs; Aborting.~%"
1229     eofs-before-quit)
1230     (quit))
1231     (t
1232     (format t "~&Received EOF.~%")))))))))))
1233 ram 1.1
1234    
1235 ram 1.3
1236 ram 1.1 ;;; %Halt -- Interface
1237     ;;;
1238     ;;; A convenient way to get into the assembly level debugger.
1239     ;;;
1240     (defun %halt ()
1241     (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5