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

Diff of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by ram, Tue Feb 6 17:24:46 1990 UTC revision 1.1.1.1 by wlott, Mon Mar 12 19:06:39 1990 UTC
# Line 20  Line 20 
20                                 ++ +++ ** *** // ///))                                 ++ +++ ** *** // ///))
21    
22    
23  (in-package "SYSTEM")  (in-package "SYSTEM" :nicknames '("SYS"))
24  (export '(add-port-death-handler remove-port-death-handler sap-int  (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            int-sap sap-ref-8 sap-ref-16 sap-ref-32 without-gcing
26            *in-the-compiler* compiler-version *pornography-of-death*            *in-the-compiler* compiler-version *pornography-of-death*
# Line 34  Line 34 
34            *nameserverport* *usertypescript* *userwindow* *typescriptport*            *nameserverport* *usertypescript* *userwindow* *typescriptport*
35            *task-self* *task-data* *task-notify* *file-input-handlers*            *task-self* *task-data* *task-notify* *file-input-handlers*
36            with-interrupts with-enabled-interrupts enable-interrupt            with-interrupts with-enabled-interrupts enable-interrupt
37            ignore-interrupt default-interrupt serve-all))            ignore-interrupt default-interrupt))
38    
39  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
40  (export '(quit *prompt* print-herald save-lisp gc-on gc-off  (export '(quit *prompt* print-herald save-lisp gc-on gc-off
41                 *before-save-initializations* *after-save-initializations*                 *before-save-initializations* *after-save-initializations*
42                 *editor-lisp-p* *clx-server-displays* *display-event-handlers*))                 *editor-lisp-p* *clx-server-displays*))
43    
44  (in-package "LISP")  (in-package "LISP")
45    
# Line 57  Line 57 
57    
58  ;;; Make the error system enable interrupts.  ;;; Make the error system enable interrupts.
59    
60  (defconstant most-positive-fixnum 134217727  (defconstant most-positive-fixnum (1- (ash 1 30))
61    "The fixnum closest in value to positive infinity.")    "The fixnum closest in value to positive infinity.")
62    
63  (defconstant most-negative-fixnum -134217728  (defconstant most-negative-fixnum (ash -1 30)
64    "The fixnum closest in value to negative infinity.")    "The fixnum closest in value to negative infinity.")
65    
66    
 (defvar *prompt* "* " "The string with which Lisp prompts you.")  
   
   
67  ;;; Random information:  ;;; Random information:
68    
69  (defvar compiler-version "???")  (defvar compiler-version "???")
70  (defvar *lisp-implementation-version* "2.7(?)")  (defvar *lisp-implementation-version* "3.0(?)")
71    
72  (defvar *in-the-compiler* ()  (defvar *in-the-compiler* nil
73    "Bound to T while running code inside the compiler.  Macros may test this to    "Bound to T while running code inside the compiler.  Macros may test this to
74    see where they are being expanded.")    see where they are being expanded.")
75    
76  (defparameter %fasl-code-format 6)  (defparameter %fasl-code-format vm:target-fasl-code-format)
77    
78    
79  ;;;; Global ports:  ;;;; Global ports:
# Line 90  Line 87 
87  (defvar *nameserverport* ()  (defvar *nameserverport* ()
88    "Port to the name server.")    "Port to the name server.")
89    
90    
91    
92  ;;; GC stuff.  ;;; GC stuff.
93    
94    #| Again, will be different.
95    
96  (defvar *gc-inhibit* nil)       ; Inhibits GC's.  (defvar *gc-inhibit* nil)       ; Inhibits GC's.
97    
98  (defvar *already-maybe-gcing* nil) ; Inhibits recursive GC's.  (defvar *already-maybe-gcing* nil) ; Inhibits recursive GC's.
# Line 101  Line 101 
101    "*Need-to-collect-garbage* is set to T when GC is disabled, but the system    "*Need-to-collect-garbage* is set to T when GC is disabled, but the system
102    needs to do a GC.  When GC is enabled again, the GC is done then.")    needs to do a GC.  When GC is enabled again, the GC is done then.")
103    
104    |#
 ;;; Software interrupt stuff.  
105    
 (defvar *in-server* NIL  
   "*In-server* is set to T when the SIGMSG interrupt has been enabled  
   in Server.")  
   
 (defvar server-unique-object (cons 1 2))  
   
 (defconstant lockout-interrupts (logior (mach:sigmask mach:sigint)  
                                         (mach:sigmask mach:sigquit)  
                                         (mach:sigmask mach:sigfpe)  
                                         (mach:sigmask mach:sigsys)  
                                         (mach:sigmask mach:sigpipe)  
                                         (mach:sigmask mach:sigalrm)  
                                         (mach:sigmask mach:sigurg)  
                                         (mach:sigmask mach:sigstop)  
                                         (mach:sigmask mach:sigtstp)  
                                         (mach:sigmask mach:sigcont)  
                                         (mach:sigmask mach:sigchld)  
                                         (mach:sigmask mach:sigttin)  
                                         (mach:sigmask mach:sigttou)  
                                         (mach:sigmask mach:sigio)  
                                         (mach:sigmask mach:sigxcpu)  
                                         (mach:sigmask mach:sigxfsz)  
                                         (mach:sigmask mach:sigvtalrm)  
                                         (mach:sigmask mach:sigprof)  
                                         (mach:sigmask mach:sigwinch)  
                                         (mach:sigmask mach:sigmsg)  
                                         (mach:sigmask mach:sigemsg)))  
   
 (defconstant interrupt-stack-size 4096  
   "Size of stack for Unix interrupts.")  
   
 (defvar software-interrupt-stack NIL  
   "Address of the stack used by Mach to send signals to Lisp.")  
   
 (defvar %sp-interrupts-inhibited nil  
   "True if emergency message interrupts should be inhibited, false otherwise.")  
   
 (defvar *software-interrupt-vector*  
   (make-array mach::maximum-interrupts)  
   "A vector that associates Lisp functions with Unix interrupts.")  
   
 (defun enable-interrupt (interrupt function &optional character)  
   "Enable one Unix interrupt and associate a Lisp function with it.  
   Interrupt should be the number of the interrupt to enable.  Function  
   should be a funcallable object that will be called with three  
   arguments: the signal code, a subcode, and the context of the  
   interrupt.  The optional character should be an ascii character or  
   an integer that causes the interrupt from the keyboard.  This argument  
   is only used for SIGINT, SIGQUIT, and SIGTSTP interrupts and is ignored  
   for any others.  Returns the old function associated with the interrupt  
   and the character that generates it if the interrupt is one of SIGINT,  
   SIGQUIT, SIGTSTP and character was specified."  
   (unless (< 0 interrupt mach::maximum-interrupts)  
     (error "Interrupt number ~D is not between 1 and ~D."  
            mach::maximum-interrupts))  
   (let ((old-fun (svref *software-interrupt-vector* interrupt))  
         (old-char ()))  
     (when (and character  
                (or (eq interrupt mach:sigint)  
                    (eq interrupt mach:sigquit)  
                    (eq interrupt mach:sigtstp)))  
       (when (characterp character)  
         (setq character (char-code character)))  
       (when (mach:unix-isatty 0)  
         (if (or (eq interrupt mach:sigint)  
                 (eq interrupt mach:sigquit))  
             (mach:with-trap-arg-block mach:tchars tc  
               (multiple-value-bind  
                   (val err)  
                   (mach:unix-ioctl 0 mach:TIOCGETC  
                                    (alien-value-sap mach:tchars))  
                 (if (null val)  
                     (error "Failed to get tchars information, unix error ~S."  
                            (mach:get-unix-error-msg err))))  
               (cond ((eq interrupt mach:sigint)  
                      (setq old-char  
                            (alien-access (mach::tchars-intrc (alien-value tc))))  
                      (setf (alien-access (mach::tchars-intrc (alien-value tc)))  
                            character))  
                     (T  
                      (setq old-char  
                            (alien-access (mach::tchars-quitc (alien-value tc))))  
                      (setf (alien-access (mach::tchars-quitc (alien-value tc)))  
                            character)))  
               (multiple-value-bind  
                   (val err)  
                   (mach:unix-ioctl 0 mach:tiocsetc  
                                    (alien-value-sap mach:tchars))  
                 (if (null val)  
                     (error "Failed to set tchars information, unix error ~S."  
                            (mach:get-unix-error-msg err)))))  
             (mach:with-trap-arg-block mach:ltchars tc  
               (multiple-value-bind  
                   (val err)  
                   (mach:unix-ioctl 0 mach:TIOCGLTC  
                                    (alien-value-sap mach:ltchars))  
                 (if (null val)  
                     (error "Failed to get ltchars information, unix error ~S."  
                            (mach:get-unix-error-msg err))))  
               (setq old-char  
                     (alien-access (mach::ltchars-suspc (alien-value tc))))  
               (setf (alien-access (mach::ltchars-suspc (alien-value tc)))  
                     character)  
               (multiple-value-bind  
                   (val err)  
                   (mach:unix-ioctl 0 mach:TIOCSLTC  
                                    (alien-value-sap mach:ltchars))  
                 (if (null val)  
                     (error "Failed to set ltchars information, unix error ~S."  
                            (mach:get-unix-error-msg err))))))))  
     (setf (svref *software-interrupt-vector* interrupt) function)  
     (if (null function)  
         (mach:unix-sigvec interrupt mach:sig_dfl 0 0)  
         (let ((diha (+ (ash clc::romp-data-base 16)  
                        clc::software-interrupt-offset)))  
           (mach:unix-sigvec interrupt diha lockout-interrupts 1)))  
     (if old-char  
         (values old-fun old-char)  
         old-fun)))  
   
 (defun ignore-interrupt (interrupt)  
   "The Unix interrupt handling mechanism is set up so that interrupt is  
   ignored."  
   (unless (< 0 interrupt mach::maximum-interrupts)  
     (error "Interrupt number ~D is not between 1 and 31."))  
   (let ((old-fun (svref *software-interrupt-vector* interrupt)))  
     (mach:unix-sigvec interrupt mach:sig_ign 0 0)  
     (setf (svref *software-interrupt-vector* interrupt) NIL)  
     old-fun))  
   
 (defun default-interrupt (interrupt)  
   "The Unix interrupt handling mechanism is set up to do the default action  
   under mach.  Lisp will not get control of the interrupt."  
   (unless (< 0 interrupt mach::maximum-interrupts)  
     (error "Interrupt number ~D is not between 1 and 31."))  
   (let ((old-fun (svref *software-interrupt-vector* interrupt)))  
     (mach:unix-sigvec interrupt mach:sig_dfl 0 0)  
     (setf (svref *software-interrupt-vector* interrupt) NIL)  
     old-fun))  
   
   
 ;;; %SP-Software-Interrupt-Handler is called by the miscops when a Unix  
 ;;; signal arrives.  The three arguments correspond to the information  
 ;;; passed to a normal Unix signal handler, i.e.:  
 ;;;     signal -- the Unix signal number.  
 ;;;     code -- a code for those signals which can be caused by more  
 ;;;             than one kind of event.  This code specifies the sub-event.  
 ;;;     scp -- a pointer to the context of the signal.  
   
 ;;; Because of the way %sp-software-interrupt-handler returns, it doesn't  
 ;;; unwind the binding stack properly.  The only variable affected by this  
 ;;; is software-interrupt-stack, so it must be handled specially.  
   
 (defun %sp-software-interrupt-handler (signal code scp stack)  
   (declare (optimize (speed 3) (safety 0)))  
   (if (and %sp-interrupts-inhibited  
            (not (memq signal '(#.mach:sigill #.mach:sigbus #.mach:sigsegv))))  
       (progn  
         (let ((iin %sp-interrupts-inhibited))  
           (setq %sp-interrupts-inhibited  
                 (nconc (if (consp iin) iin)  
                        (list `(,signal ,code ,scp))))  
           (mach:unix-sigsetmask 0)))  
       (let* ((old-stack software-interrupt-stack)  
              (new-stack ())  
              (%sp-interrupts-inhibited T))  
         (unwind-protect  
             (progn  
               (when *in-server*  
                 (mach:unix-sigvec mach:sigmsg mach::sig_dfl 0 0))  
               (multiple-value-bind (gr addr)  
                                    (mach:vm_allocate *task-self* 0  
                                                      interrupt-stack-size t)  
                 (gr-error 'mach:vm_allocate gr '%sp-software-interrupt-handler)  
                 (setq software-interrupt-stack  
                       (int-sap (+ addr interrupt-stack-size))))  
               (setq new-stack software-interrupt-stack)  
               (mach:unix-sigstack new-stack 0)  
               (mach:unix-sigsetmask 0)  
               (funcall (svref *software-interrupt-vector* signal)  
                        signal code scp)  
               (mach:unix-sigsetmask lockout-interrupts))  
           (mach:vm_deallocate *task-self*  
                               (- (sap-int new-stack)  
                                  interrupt-stack-size)  
                               interrupt-stack-size)  
           (setq software-interrupt-stack old-stack)  
           (mach:unix-sigstack old-stack 0)  
           (when *in-server*  
             (let ((diha (+ (ash clc::romp-data-base 16)  
                            clc::software-interrupt-offset)))  
               (mach:unix-sigvec mach:sigmsg diha lockout-interrupts 1)))  
           (mach:unix-sigsetmask 0))))  
   (%primitive break-return stack))  
   
   
 (defun ih-sigint (signal code scp)  
   (declare (ignore signal code scp))  
   (without-hemlock  
    (with-interrupts  
     (break "Software Interrupt" t))))  
   
 (defun ih-sigquit (signal code scp)  
   (declare (ignore signal code scp))  
   (throw 'top-level-catcher nil))  
   
 (defun ih-sigtstp (signal code scp)  
   (declare (ignore signal code scp))  
   (without-hemlock  
 ;   (reset-keyboard 0)  
    (mach:unix-kill (mach:unix-getpid) mach:sigstop)))  
   
 (defun ih-sigill (signal code scp)  
   (declare (ignore signal code))  
   (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)  
                                           'mach:sigcontext)  
                         mach:sigcontext T))  
     (error "Illegal instruction encountered at IAR ~X."  
            (alien-access (mach::sigcontext-iar (alien-value context))))))  
   
 (defun ih-sigbus (signal code scp)  
   (declare (ignore signal code))  
   (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)  
                                           'mach:sigcontext)  
                         mach:sigcontext T))  
     (with-interrupts  
      (error "Bus error encountered at IAR ~X."  
             (alien-access (mach::sigcontext-iar (alien-value context)))))))  
   
 (defun ih-sigsegv (signal code scp)  
   (declare (ignore signal code))  
   (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)  
                                           'mach:sigcontext)  
                         mach:sigcontext T))  
     (with-interrupts  
      (error "Segment violation encountered at IAR ~X."  
             (alien-access (mach::sigcontext-iar (alien-value context)))))))  
   
 (defun ih-sigfpe (signal code scp)  
   (declare (ignore signal code))  
   (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)  
                                           'mach:sigcontext)  
                         mach:sigcontext T))  
     (with-interrupts  
      (error "Floating point exception encountered at IAR ~X."  
             (alien-access (mach::sigcontext-iar (alien-value context)))))))  
   
 ;;; When we're in server then throw back to server.  If we're not  
 ;;; in server then just ignore the sigmsg interrupt.  We can't handle  
 ;;; it and we should never get it anyway.  But of course we do -- it's  
 ;;; dealing with interrupts and there funny at best.  
 (defun ih-sigmsg (signal code scp)  
   (declare (ignore signal code scp))  
   (mach:unix-sigsetmask (mach:sigmask mach:sigmsg))  
   (default-interrupt mach:sigmsg)  
   (when *in-server*  
     (setq *in-server* nil)  
     (throw 'server-catch server-unique-object)))  
   
 (defun ih-sigemsg (signal code scp)  
   (declare (ignore signal code scp))  
   (service-emergency-message-interrupt))  
   
 (defun init-mach-signals ()  
   (declare (optimize (speed 3) (safety 0)))  
   (multiple-value-bind (gr addr)  
                        (mach:vm_allocate *task-self* 0 interrupt-stack-size t)  
     (gr-error 'mach:vm_allocate gr 'enable-interrupt)  
     (setq software-interrupt-stack  
           (int-sap (+ addr interrupt-stack-size))))  
   (let ((iha (get 'clc::interrupt-handler '%loaded-address))  
         (diha (+ (ash clc::romp-data-base 16) clc::software-interrupt-offset)))  
     (%primitive pointer-system-set diha 0 iha))  
   (mach:unix-sigstack software-interrupt-stack 0)  
   (enable-interrupt mach:sigint #'ih-sigint)  
   (enable-interrupt mach:sigquit #'ih-sigquit)  
   (enable-interrupt mach:sigtstp #'ih-sigtstp)  
   (enable-interrupt mach:sigill #'ih-sigill)  
   (enable-interrupt mach:sigbus #'ih-sigbus)  
   (enable-interrupt mach:sigsegv #'ih-sigsegv)  
   (enable-interrupt mach:sigemsg #'ih-sigemsg)  
   (enable-interrupt mach:sigfpe #'ih-sigfpe)  
 ;  (reset-keyboard 0)  
   )  
106    
107    
108  ;;;; Reply port allocation.  ;;;; Reply port allocation.
# Line 395  Line 110 
110  ;;;    We maintain a global stack of reply ports which is shared among  ;;;    We maintain a global stack of reply ports which is shared among
111  ;;; all matchmaker interfaces, and could be used by other people as well.  ;;; all matchmaker interfaces, and could be used by other people as well.
112  ;;;  ;;;
113    
114    #| More stuff that will probably be drastically different.
115    
116  ;;;    The stack is represented by a vector, and a pointer to the first  ;;;    The stack is represented by a vector, and a pointer to the first
117  ;;; free port.  The stack grows upward.  There is always at least one  ;;; free port.  The stack grows upward.  There is always at least one
118  ;;; NIL entry in the stack after the last allocated port.  ;;; NIL entry in the stack after the last allocated port.
# Line 467  Line 185 
185          (gr-call mach:port_deallocate *task-self* port)          (gr-call mach:port_deallocate *task-self* port)
186          (setf (svref stack i)          (setf (svref stack i)
187                (gr-call* mach:port_allocate *task-self*))))))                (gr-call* mach:port_allocate *task-self*))))))
188    |#
189    
190    
191  ;;;; Server stuff:  ;;;; Server stuff:
# Line 592  Line 311 
311  ;;;  ;;;
312  (defsetf object-set-operation %set-object-set-operation  (defsetf object-set-operation %set-object-set-operation
313    "Sets the handler function for an object set operation.")    "Sets the handler function for an object set operation.")
   
 ;;;; Server function:  
 ;;;  
 ;;; SERVER makes use of a defined alien, server-event, that lives at address 0.  
 ;;; This is a bogus alien used just as a dynamic variable that is declared  
 ;;; appropriately for the compiler.  This alien variable is bound to stuff in  
 ;;; an alien stack by the same name, server-event, which contains elements much  
 ;;; bigger than necessary to accommodate whatever will come back in the future  
 ;;; from waiting across ports, sockets, file descriptors, etc.  The defined  
 ;;; alien operators allow easy access to server-event as different types of  
 ;;; event by declaring the necessary type for the compiler when the operator  
 ;;; is used.  
   
   
 ;;;    Currently the server message is 4k bytes, thus serving larger requests  
 ;;; is impossible.  If anyone is bothered by this, the size can be increased.  
 ;;; X events are only 24 bytes.  
 ;;;  
314    
 (defconstant server-message-size 4096)  
 (defalien server-message server-message (bytes server-message-size) 0)  
   
 (define-alien-stack server-message server-message (bytes server-message-size))  
   
 (defrecord server-message  
   (msg mach:msg #.(record-size 'mach:msg)))  
   
 (defvar *file-input-handlers* ()  
   "Is an association list of file descriptors and functions to call when  
   input is available on the particular file descriptor.")  
   
 (defvar *clx-server-displays* ()  
   "Is a list of CLX displays that may have some activity on them.")  
   
 (defvar *display-event-handlers* nil  
   "This is an alist mapping displays to user functions to be called when  
    SYSTEM:SERVER notices input on a display connection.  Do not modify this  
    directly; use EXT:ENABLE-CLX-EVENT-HANDLING.  A given display should be  
    represented here only once.")  
   
   
 ;;; Default-Default-Handler  --  Internal  
 ;;;  
 ;;;    If no such operation defined, signal an error.  
 ;;;  
 (defun default-default-handler (object)  
   (alien-bind ((msg (server-message-msg server-message)))  
     (error "No operation for ID ~D on ~S in ~S."  
            (alien-access (mach:msg-id (alien-value msg))) object  
            (car (gethash (alien-access (mach:msg-localport (alien-value msg)))  
                          *port-table*)))))  
   
   
 ;;; Server  --  Public  
 ;;;  
 (defun server (&optional (timeout 0 todef))  
   "Receive on all ports and Xevents and dispatch to the appropriate handler  
   function.  If timeout is specified, server will wait the specified time  
   and then return, otherwise it will wait until something happens.  Server  
   returns T if something happened and NIL otherwise."  
   (cond ((dolist (d/h ext::*display-event-handlers* nil)  
            (let ((d (car d/h)))  
              (when (xlib::event-listen d)  
                (handler-bind ((error #'(lambda (condx)  
                                          (declare (ignore condx))  
                                          (flush-display-events d))))  
                  (funcall (cdr d/h) d))  
                (return t))))  
          T)  
         (T  
          (let* ((to (if todef (round (* timeout 1000000))))  
                 (fd-mask 0)  
                 (omask 0)  
                 (value (catch 'server-catch  
                          (unwind-protect  
                              (progn  
                                (setq omask (mach:unix-sigsetmask  
                                             (mach:sigmask mach:sigmsg)))  
                                (unless (grab-message-loop)  
                                  (let ((*in-server* T))  
                                    (enable-interrupt mach:sigmsg #'ih-sigmsg)  
                                    (multiple-value-bind  
                                        (to1 to2)  
                                        (if todef (truncate to 1000000))  
                                      (multiple-value-bind  
                                          (nfd fdm)  
                                          (get-fd-info)  
                                        (mach:unix-sigsetmask 0)  
                                        (multiple-value-bind  
                                            (nfnd rfdm)  
                                            (mach:unix-select nfd fdm 0 0  
                                                              to1 to2)  
                                          (mach:unix-sigsetmask  
                                           (mach:sigmask mach:sigmsg))  
                                          (default-interrupt mach:sigmsg)  
                                          (setq fd-mask rfdm)  
                                          nfnd))))))  
                            (default-interrupt mach:sigmsg)  
                            (mach:unix-sigsetmask omask)))))  
            (cond ((or (null value) (and todef (eq value 0))) NIL)  
                  ((eq value server-unique-object)  
                   (grab-message-loop)  
                   T)  
                  ((file-descriptor-ready fd-mask) T))))))  
   
 ;;; Get-fd-info turns the association list in *file-input-handlers*  
 ;;; into information that unix-select can be called with.  
 (defun Get-fd-info ()  
   (do* ((fdl *file-input-handlers* (cdr fdl)) ;  
         (FD (caar fdl) (caar fdl))  
         (mfd 0)  
         (fdm 0))  
        ((null fdl)  
         (values (1+ mfd) fdm))  
     (setq mfd (max mfd fd))  
     (setq fdm (logior fdm (ash 1 fd)))))  
   
 ;;; File-descriptor-ready is called when server determines that a file  
 ;;; descriptor has input ready on one ore more of them.  It calls the  
 ;;; appropriate handler with the file-descriptor as its argument.  
 ;;; It checks for an xevent first, so they are handled as quickly as  
 ;;; possible.  
 (defun file-descriptor-ready (rfdm)  
   (do ((fd 0 (1+ fd))  
        (ms rfdm (ash ms -1)))  
       ((eq ms 0))  
     (when (/= (the fixnum (logand ms 1)) 0)  
       (let ((info (assoc fd *file-input-handlers* :test #'eq)))  
         (when info  
           (funcall (cdr info) fd)))))  
   T)  
   
 ;;; Grab-message-loop calls the appropiate handler for an IPC message.  
 (defun grab-message-loop ()  
   (do* ((gr (server-grab-message) (server-grab-message))  
         (flag (/= gr mach:rcv-timed-out)  
               (if (/= gr mach:rcv-timed-out) t flag)))  
        ((= gr mach:rcv-timed-out) flag)))  
   
 (defun server-grab-message ()  
   (with-stack-alien (sm server-message)  
     (alien-bind ((msg (server-message-msg (alien-value sm))))  
       (setf (alien-access (mach:msg-msgsize (alien-value msg)))  
             server-message-size)  
       (setf (alien-access (mach:msg-localport (alien-value msg)))  
             mach::port-enabled)  
       (let ((gr (mach:msg-receive (alien-value sm) mach::rcv-timeout 0)))  
         (when (eql gr mach:rcv-timed-out)  
           (return-from server-grab-message gr))  
         (unless (eql gr mach:rcv-success)  
           (gr-error 'mach:msg-receive gr))  
         (let* ((server-message (alien-value sm))  
                (port (alien-access (mach:msg-localport (alien-value msg))))  
                (id (alien-access (mach:msg-id (alien-value msg))))  
                (x (gethash port *port-table*))  
                (set (cdr x)))  
           (unless x  
             (error "~D is not known to server (operation: ~D)." port id))  
           (let ((gr (funcall (gethash id (object-set-table set)  
                                       (object-set-default-handler set))  
                              (car x))))  
             (unless (eql gr mach:kern-success)  
               (gr-error 'server gr)))))))  
   mach:kern-success)  
   
 (defun serve-all (&optional (timeout 0))  
   "Serve-all calls server with the specified timeout.  If server does  
   something (returns T) it loops over server with timeout 0 until all  
   events have been served.  Serve-all returns T if server did something  
   and other NIL."  
   (do ((res NIL)  
        (sval (server timeout) (server 0)))  
       ((null sval) res)  
     (setq res T)))  
315    
316    
317  ;;;; Emergency Message Handling:  ;;;; Emergency Message Handling:
# Line 777  Line 323 
323  ;;; Instead, we use MessagesWaiting to find the ports with emergency  ;;; Instead, we use MessagesWaiting to find the ports with emergency
324  ;;; messages.  ;;; messages.
325    
326    #| still more noise that will be different.
327    
328  (defalien waiting-ports nil (long-words 128))  (defalien waiting-ports nil (long-words 128))
329    
330  ;;; Service-Emergency-Message-Interrupt  --  Internal  ;;; Service-Emergency-Message-Interrupt  --  Internal
# Line 912  Line 460 
460    
461  (pushnew 'clear-port-tables *before-save-initializations*)  (pushnew 'clear-port-tables *before-save-initializations*)
462    
463    |#
464    
465    
466    
467  ;;; %Initial-Function is called when a cold system starts up.  First we zoom  ;;; %Initial-Function is called when a cold system starts up.  First we zoom
468  ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen  ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
# Line 932  Line 483 
483  (defun %initial-function ()  (defun %initial-function ()
484    "Gives the world a shove and hopes it spins."    "Gives the world a shove and hopes it spins."
485    (setq *already-maybe-gcing* t)    (setq *already-maybe-gcing* t)
486    (setf *gc-inhibit* nil)    (setf *gc-inhibit* t)
487    (setf *need-to-collect-garbage* nil)    (setf *need-to-collect-garbage* nil)
488    (%primitive print "In initial-function, and running.")    (%primitive print "In initial-function, and running.")
489    
# Line 1043  Line 594 
594  (defvar *editor-lisp-p* nil  (defvar *editor-lisp-p* nil
595    "This is true if and only if the lisp was started with the -edit switch.")    "This is true if and only if the lisp was started with the -edit switch.")
596    
597    #+nil ;; Can't save lisps yet
598  (defun save-lisp (core-file-name &key  (defun save-lisp (core-file-name &key
599                                   (purify t)                                   (purify t)
600                                   (root-structures ())                                   (root-structures ())
# Line 1127  Line 679 
679        (throw '%end-of-the-world nil)))        (throw '%end-of-the-world nil)))
680    
681    
682    #| might be something different.
683    
684  (defalien sleep-msg mach:msg (record-size 'mach:msg))  (defalien sleep-msg mach:msg (record-size 'mach:msg))
685  (setf (alien-access (mach:msg-simplemsg sleep-msg)) T)  (setf (alien-access (mach:msg-simplemsg sleep-msg)) T)
# Line 1152  Line 705 
705                   (gr-error 'mach:receive gr)))))))                   (gr-error 'mach:receive gr)))))))
706    nil)    nil)
707    
708    |#
709    
710    
711  ;;;; TOP-LEVEL loop.  ;;;; TOP-LEVEL loop.
712    
# Line 1166  Line 721 
721  (defvar ++ nil "Gets the previous value of + when a new value is read.")  (defvar ++ nil "Gets the previous value of + when a new value is read.")
722  (defvar +++ nil "Gets the previous value of ++ when a new value is read.")  (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
723  (defvar - nil "Holds the form curently being evaluated.")  (defvar - nil "Holds the form curently being evaluated.")
724  (defvar *prompt* nil "The top-level prompt string.")  (defvar *prompt* "* "
725  (defvar %temp% nil "Random temporary, clobbered by top level loop.")    "The top-level prompt string.  This also may be a function of no arguments
726       that returns a simple-string.")
727  (defvar *in-top-level-catcher* nil  (defvar *in-top-level-catcher* nil
728    "True if we are within the Top-Level-Catcher.  This is used by interrupt    "True if we are within the Top-Level-Catcher.  This is used by interrupt
729    handlers to see whether it is o.k. to throw.")    handlers to see whether it is o.k. to throw.")
730    
731    (defun interactive-eval (form)
732      "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
733      +, ///, //, /, and -."
734      (setf +++ ++
735            ++ +
736            + -
737            - form)
738      (let ((results (multiple-value-list (eval form))))
739        (setf /// //
740              // /
741              / results
742              *** **
743              ** *
744              * (car results)))
745      (unless (boundp '*)
746        ;; The bogon returned an unbound marker.
747        (setf * nil)
748        (cerror "Go on with * set to NIL."
749                "EVAL returned an unbound marker."))
750      (values-list /))
751    
752    (defconstant eofs-before-quit 10)
753    
754  (defun %top-level ()  (defun %top-level ()
755    "Top-level READ-EVAL-PRINT loop.  Do not call this."    "Top-level READ-EVAL-PRINT loop.  Do not call this."
756    (let  ((this-eval nil) (* nil) (** nil) (*** nil)    (let  ((* nil) (** nil) (*** nil)
757           (- nil) (+ nil) (++ nil) (+++ nil)           (- nil) (+ nil) (++ nil) (+++ nil)
758           (/// nil) (// nil) (/ nil) (%temp% nil))           (/// nil) (// nil) (/ nil)
759             (magic-eof-cookie (cons :eof nil))
760             (number-of-eofs 0))
761      (loop      (loop
762       (with-simple-restart (abort "Return to Top-Level.")       (with-simple-restart (abort "Return to Top-Level.")
763         (catch 'top-level-catcher         (catch 'top-level-catcher
          ;;  
          ;; Prevent the user from irrevocably wedging the hooks.  
          (setq *evalhook* nil)  
          (setq *applyhook* nil)  
764           (let ((*in-top-level-catcher* t))           (let ((*in-top-level-catcher* t))
765             (loop             (loop
766              (fresh-line)               (fresh-line)
767              (princ *prompt*)               (princ (if (functionp *prompt*)
768              (setq +++ ++ ++ + + - - (read))                          (funcall *prompt*)
769              (setq this-eval (multiple-value-list (eval -)))                          *prompt*))
770              (dolist (x this-eval)               (force-output)
771                (fresh-line)               (let ((form (read *standard-input* nil magic-eof-cookie)))
772                (prin1 x))                 (cond ((not (eq form magic-eof-cookie))
773              (setq /// // // / / this-eval)                        (let ((results
774              (setq %temp% (car this-eval))                               (multiple-value-list (interactive-eval form))))
775              ;;                          (dolist (result results)
776              ;; Make sure nobody passes back an unbound marker.                            (fresh-line)
777              (unless (boundp '%temp%)                            (prin1 result)))
778                (setq %temp% nil)                        (setf number-of-eofs 0))
779                (cerror "Go on, but set * to NIL."                       ((eql (incf number-of-eofs) 1)
780                        "Eval returned an unbound marker."))                        (let ((stream (make-synonym-stream '*terminal-io*)))
781              (setq *** ** ** * * %temp%))))))))                          (setf *standard-input* stream)
782                            (setf *standard-output* stream)
783                            (format t "~&Received EOF on *standard-input*, ~
784                                      switching to *terminal-io*.~%")))
785                         ((> number-of-eofs eofs-before-quit)
786                          (format t "~&Received more than ~D EOFs; Aborting.~%"
787                                  eofs-before-quit)
788                          (quit))
789                         (t
790                          (format t "~&Received EOF.~%")))))))))))
791    
792    
793    
794  ;;; %Halt  --  Interface  ;;; %Halt  --  Interface
795  ;;;  ;;;
796  ;;;    A convenient way to get into the assembly level debugger.  ;;;    A convenient way to get into the assembly level debugger.

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.1.1.1

  ViewVC Help
Powered by ViewVC 1.1.5