/[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.1.3 by wlott, Tue Apr 17 22:00:55 1990 UTC revision 1.82 by rtoy, Tue Apr 20 17:57:44 2010 UTC
# Line 1  Line 1 
1  ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-  ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2  ;;;  ;;;
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the Spice Lisp project at  ;;; 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.  ;;; 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).  (ext:file-comment
8  ;;; **********************************************************************    "$Header$")
9  ;;;  ;;;
10  ;;; $Header$  ;;; **********************************************************************
11  ;;;  ;;;
12  ;;; Initialization and low-level interrupt support for the Spice Lisp system.  ;;; Initialization stuff for CMU Common Lisp, plus some other random functions
13    ;;; that we don't have any better place for.
14    ;;;
15  ;;; Written by Skef Wholey and Rob MacLachlan.  ;;; Written by Skef Wholey and Rob MacLachlan.
16  ;;;  ;;;
17  (in-package "LISP" :use '("SYSTEM" "DEBUG"))  (in-package :lisp)
18    (intl:textdomain "cmucl")
19    
20    (export '(most-positive-fixnum most-negative-fixnum sleep
21              ++ +++ ** *** // ///))
22    
23  (in-package "XLIB")  (defvar *features* '(:common :common-lisp :ansi-cl :ieee-floating-point :cmu)
24      "Holds a list of symbols that describe features provided by the
25       implementation.")
26    
 (in-package "LISP")  
27    
28  (export '(most-positive-fixnum most-negative-fixnum sleep  (in-package :system)
29                                 ++ +++ ** *** // ///))  (export '(compiler-version scrub-control-stack *runtime-features*))
30    
31    (defvar *runtime-features* nil
32      "Features affecting the runtime")
33    
34  (in-package "SYSTEM" :nicknames '("SYS"))  (in-package :extensions)
35  (export '(add-port-death-handler remove-port-death-handler sap-int  (export '(quit *prompt*))
           int-sap sap-ref-8 sap-ref-16 sap-ref-32 without-gcing  
           *in-the-compiler* compiler-version *pornography-of-death*  
           *port-receive-rights-handlers* *port-ownership-rights-handlers*  
           without-interrupts with-reply-port map-port add-port-object  
           remove-port-object make-object-set object-set-operation  
           server-message *xwindow-table* map-xwindow add-xwindow-object  
           remove-xwindow-object server-event coerce-to-key-event  
           coerce-to-motion-event coerce-to-expose-event  
           coerece-to-exposecopy-event coerce-to-focuschange-event server  
           *nameserverport* *usertypescript* *userwindow* *typescriptport*  
           *task-self* *task-data* *task-notify*  
           with-interrupts with-enabled-interrupts enable-interrupt  
           ignore-interrupt default-interrupt))  
   
 (in-package "EXTENSIONS")  
 (export '(quit *prompt* print-herald save-lisp gc-on gc-off  
                *before-save-initializations* *after-save-initializations*  
                *editor-lisp-p* *clx-server-displays*))  
36    
37  (in-package "LISP")  (in-package :lisp)
38    
39    #+stack-checking
40    (sys:register-lisp-runtime-feature :stack-checking)
41    
42  ;;; These go here so that we can refer to them in top-level forms.  #+heap-overflow-check
43    (sys:register-lisp-runtime-feature :heap-overflow-check)
44    
45  (defvar *before-save-initializations* ()  #+double-double
46    "This is a list of functions which are called before creating a saved core  (sys:register-lisp-feature :double-double)
   image.  These functions are executed in the child process which has no ports,  
   so they cannot do anything that tries to talk to the outside world.")  
   
 (defvar *after-save-initializations* ()  
   "This is a list of functions which are called when a saved core image starts  
   up.  The system itself should be initialized at this point, but applications  
   might not be.")  
47    
48  ;;; Make the error system enable interrupts.  ;;; Make the error system enable interrupts.
49    
50  (defconstant most-positive-fixnum (1- (ash 1 30))  (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum
51    "The fixnum closest in value to positive infinity.")    "The fixnum closest in value to positive infinity.")
52    
53  (defconstant most-negative-fixnum (ash -1 30)  (defconstant most-negative-fixnum #.vm:target-most-negative-fixnum
54    "The fixnum closest in value to negative infinity.")    "The fixnum closest in value to negative infinity.")
55    
56    
57  ;;; Random information:  ;;; Random information:
58    
 (defvar compiler-version "???")  
59  (defvar *lisp-implementation-version* "4.0(?)")  (defvar *lisp-implementation-version* "4.0(?)")
60    
 (defvar *in-the-compiler* nil  
   "Bound to T while running code inside the compiler.  Macros may test this to  
   see where they are being expanded.")  
61    
62  (defparameter %fasl-code-format #.vm:target-fasl-code-format)  ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs...
63    (declaim
64      #-gengc
65      (special *gc-inhibit* *already-maybe-gcing*
66               *need-to-collect-garbage* *gc-verbose*
67               *before-gc-hooks* *after-gc-hooks*
68               #+x86 *pseudo-atomic-atomic*
69               #+x86 *pseudo-atomic-interrupted*
70               unix::*interrupts-enabled*
71               unix::*interrupt-pending*
72               *type-system-initialized*
73               unix::*filename-encoding*)
74      #+gengc
75      (special *gc-verbose* *before-gc-hooks* *after-gc-hooks*
76               *type-system-initialized* unix::*filename-encoding*))
77    
78    
79  ;;;; Global ports:  ;;;; Random magic specials.
   
 (defvar *task-self* 1  
   "Port that refers to the current task.")  
80    
 (defvar *task-data* 2  
   "Port used to receive data for the current task.")  
81    
82  (defvar *nameserverport* ()  ;;; These are filled in by Genesis.
   "Port to the name server.")  
83    
84    #-gengc
85    (progn
86    
87    (defvar *current-catch-block*)
88  ;;; GC stuff.  (defvar *current-unwind-protect-block*)
89    (defvar *free-interrupt-context-index*)
 (defvar *gc-inhibit* nil)       ; Inhibits GC's.  
   
 (defvar *already-maybe-gcing* nil) ; Inhibits recursive GC's.  
   
 (defvar *need-to-collect-garbage* nil  
   "*Need-to-collect-garbage* is set to T when GC is disabled, but the system  
   needs to do a GC.  When GC is enabled again, the GC is done then.")  
   
   
   
 ;;;; Reply port allocation.  
 ;;;  
 ;;;    We maintain a global stack of reply ports which is shared among  
 ;;; all matchmaker interfaces, and could be used by other people as well.  
 ;;;  
   
 #| More stuff that will probably be drastically different.  
90    
91  ;;;    The stack is represented by a vector, and a pointer to the first  ); #-gengc progn
 ;;; free port.  The stack grows upward.  There is always at least one  
 ;;; NIL entry in the stack after the last allocated port.  
 ;;;  
 (defvar *reply-port-stack* (make-array 16)) ; Vector of reply ports.  
 (defvar *reply-port-pointer* 0) ; Index of first free port.  
 (defvar *reply-port-depth* 0)   ; Dynamic depth in With-Reply-Port forms.  
   
 ;;; We use this as the reply port when allocating or deallocating reply  
 ;;; ports to get around potentially nasty interactions.  Interrupts  
 ;;; are always off when we are doing this, so we don't have to have  
 ;;; more than one of these, or worry about unwinding.  
 (defvar *allocate-reply-port* (mach:mach-task_data))  
   
 ;;; Reset-Reply-Port-Stack  --  Internal  
 ;;;  
 ;;;    This is a before-save initialization which Nil's out the reply  
 ;;; port stack and sets *allocate-reply-port* back to DataPort so that  
 ;;; things initialize right at OS-Init time.  
 ;;;  
 (defun reset-reply-port-stack ()  
   (setq *reply-port-pointer* 0  *reply-port-depth* 0)  
   (fill (the simple-vector *reply-port-stack*) nil)  
   (setq *allocate-reply-port* (mach:mach-task_data)))  
 (pushnew 'reset-reply-port-stack *before-save-initializations*)  
   
 ;;; Allocate-New-Reply-Ports  --  Internal  
 ;;;  
 ;;;    If we run out of reply ports, we allocate another one, possibly  
 ;;; growing the stack.  
 ;;;  
 (defun allocate-new-reply-ports ()  
   (let* ((stack *reply-port-stack*)  
          (pointer *reply-port-pointer*)  
          (len (length stack)))  
     (declare (simple-vector stack) (fixnum len))  
     (when (eql pointer (1- len))  
       (let ((new (make-array (* len 2))))  
         (replace new stack :end1 len :end2 len)  
         (setq stack new  *reply-port-stack* new)))  
     (setf (svref stack pointer) *allocate-reply-port*)  
     (let ((port (gr-call* mach:port_allocate (mach:mach-task_self))))  
       (gr-call mach:port_disable (mach:mach-task_self) port)  
       ;;  
       ;; Nil out the allocate reply port so it isn't used for mundane purposes.  
       (setf (svref stack pointer) nil)  
       (setf (svref stack (1- pointer)) port)  
       port)))  
   
 ;;; Reallocate-Reply-Ports  --  Internal  
 ;;;  
 ;;;    This function is called when With-Reply-Port finds the stack pointer  
 ;;; to be other than what it expected when it finishes.  Reallocates all  
 ;;; of the ports on the stack from Start to *reply-port-pointer*.  We  
 ;;; stick the *allocate-reply-port* out at *reply-port-pointer*, and  
 ;;; bind *reply-port-depth*, so that the allocation functions are happy.  
 ;;;  
 (defun reallocate-reply-ports (start)  
   (let* ((pointer *reply-port-pointer*)  
          (*reply-port-depth* pointer)  
          (stack *reply-port-stack*)  
          (save-port (svref stack pointer)))  
     (when (> start pointer)  
       (error "More ports in use than allocated???"))  
     (setf (svref stack pointer) *allocate-reply-port*)  
     (do ((i start (1+ i)))  
         ((= i pointer)  
          (setf (svref stack pointer) save-port))  
       (let ((port (svref stack i)))  
         (gr-call mach:port_deallocate *task-self* port)  
         (setf (svref stack i)  
               (gr-call* mach:port_allocate *task-self*))))))  
 |#  
92    
93    
94  ;;;; Server stuff:  ;;;; Random stuff that needs to be in the cold load which would otherwise be
95  #|  ;;;; byte-compiled.
96  ;;;  ;;;;
97  ;;;    There is a fair amount of stuff to support Matchmaker RPC servers  (defvar hi::*in-the-editor* nil)
 ;;; and asynchonous message service.  RPC message service needs to be  
 ;;; centralized since a server must receive on all ports, and there is  
 ;;; no way for a particular server to know about all other servers  
 ;;; in the same lisp.  
 ;;;  
 ;;;    The idea is that you receive the message, and then dispatch off  
 ;;; of the port received on and the message ID received.  Ports correspond  
 ;;; to objects that the server manages.  Message ID's correspond to the  
 ;;; operations on the objects.  Objects are grouped into object sets, which  
 ;;; are sets of objects having the same operations defined.  
 ;;;  
 ;;;    The same mechanism is used for handling asynchronous messages.  
 ;;;  
98    
99  ;;;    The current implementation uses standard eq[l] hashtables for both  ;;;; Called by defmacro expanders...
 ;;; levels of dispatching.  Special purpose data structures would be more  
 ;;; efficient, but the ~1ms overhead will probably be lost in the noise.  
   
 ;;;  
 ;;;    Hashtable from ports to objects.  Each entry is a cons (object . set).  
 ;;;  
 (defvar *port-table* (make-hash-table :test #'eql))  
100    
101  ;;; Hashtable from windows to objects.  Each entry is a cons (object . set).  ;;; VERIFY-KEYWORDS -- internal
102  ;;;  ;;;
103  (defvar *xwindow-table* (make-hash-table :test #'eql))  ;;; Determine if key-list is a valid list of keyword/value pairs.  Do not
104    ;;; signal the error directly, 'cause we don't know how it should be signaled.
   
 (defstruct (object-set  
             (:constructor make-object-set  
                           (name &optional  
                                 (default-handler #'default-default-handler)))  
             (:print-function  
              (lambda (s stream d)  
                (declare (ignore d))  
                (format stream "#<Object Set ~S>" (object-set-name s)))))  
   name                                  ; Name, for descriptive purposes.  
   (table (make-hash-table :test #'eq))  ; Message-ID or xevent-type --> handler fun.  
   default-handler)  
   
 (setf (documentation 'make-object-set 'function)  
       "Make an object set for use by a RPC/xevent server.  Name is for  
       descriptive purposes only.")  
   
   
 ;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and  
 ;;; object set mapped to by a xwindow or port in *xwindow-table* or  
 ;;; *port-table*.  
 ;;;  
 (macrolet ((defmapper (name table)  
               `(defun ,(intern (concatenate 'simple-string  
                                             "MAP-" (symbol-name name)))  
                       (,name)  
                  ,(format nil "Return as multiple values the object and ~  
                                object-set mapped to by ~A."  
                           (string-downcase (symbol-name name)))  
                  (let ((temp (gethash ,name ,table)))  
                    (if temp  
                        (values (car temp) (cdr temp))  
                        (values nil nil))))))  
   (defmapper port *port-table*)  
   (defmapper xwindow *xwindow-table*))  
   
   
 ;;; ADD-PORT-OBJECT and ADD-XWINDOW-OBJECT store an object/object-set pair  
 ;;; mapped to by a port or xwindow in either *port-table* or *xwindow-table*.  
 ;;;  
 (macrolet ((def-add-object (name table)  
               `(defun ,(intern (concatenate 'simple-string  
                                             "ADD-" (symbol-name name)  
                                             "-OBJECT"))  
                       (,name object object-set)  
                  ,(format nil "Add a new ~A/object/object-set association."  
                           (string-downcase (symbol-name name)))  
                  (check-type object-set object-set)  
                  (setf (gethash ,name ,table) (cons object object-set))  
                  object)))  
   (def-add-object port *port-table*)  
   (def-add-object xwindow *xwindow-table*))  
   
   
 ;;; REMOVE-PORT-OBJECT and REMOVE-XWINDOW-OBJECT remove a port or xwindow and  
 ;;; its associated object/object-set pair from *port-table* or *xwindow-table*.  
105  ;;;  ;;;
 (macrolet ((def-remove-object (name table)  
               `(defun ,(intern (concatenate 'simple-string  
                                             "REMOVE-" (symbol-name name)  
                                             "-OBJECT"))  
                       (,name)  
                  ,(format nil  
                           "Remove ~A and its associated object/object-set pair."  
                           (string-downcase (symbol-name name)))  
                  (remhash ,name ,table))))  
   (def-remove-object port *port-table*)  
   (def-remove-object xwindow *xwindow-table*))  
   
   
 ;;; Object-Set-Operation  --  Public  
 ;;;  
 ;;;    Look up the handler function for a given message ID.  
 ;;;  
 (defun object-set-operation (object-set message-id)  
   "Return the handler function in Object-Set for the operation specified by  
   Message-ID, if none, NIL is returned.  The handler function is passed  
   the object.  The received message is in server-Message."  
   (check-type object-set object-set)  
   (check-type message-id fixnum)  
   (values (gethash message-id (object-set-table object-set))))  
   
 ;;; %Set-Object-Set-Operation  --  Internal  
 ;;;  
 ;;;    The setf inverse for Object-Set-Operation.  
 ;;;  
 (defun %set-object-set-operation (object-set message-id new-value)  
   (check-type object-set object-set)  
   (check-type message-id fixnum)  
   (setf (gethash message-id (object-set-table object-set)) new-value))  
 ;;;  
 (defsetf object-set-operation %set-object-set-operation  
   "Sets the handler function for an object set operation.")  
 |#  
   
   
   
 ;;;; Emergency Message Handling:  
 ;;;  
 ;;; We use the same mechanism for asynchronous messages as is used for  
 ;;; normal server messages.   The only tricky part is that we don't want  
 ;;; some random server function being called when we really want to  
 ;;; receive an emergency message, so we can't receive on all ports.  
 ;;; Instead, we use MessagesWaiting to find the ports with emergency  
 ;;; messages.  
   
 #| still more noise that will be different.  
   
 (defalien waiting-ports nil (long-words 128))  
   
 ;;; Service-Emergency-Message-Interrupt  --  Internal  
 ;;;  
 ;;;    This is a lot like the server function, but we only receive on  
 ;;; ports with one emergency message.  We only receive one message because  
 ;;; the handler function might have caused any other messages to be received.  
 ;;; When we re-enable interrupts, if any emergency messages are left, we  
 ;;; should be interrupted again.  
 ;;;  
 (defun service-emergency-message-interrupt ()  
   (grab-message-loop))  
   
 ;;;  
 ;;; This object set is used for DataPort, which is the port various magical  
 ;;; message from the kernel are received on...  
 (defvar *kernel-messages* (make-object-set "Kernel Messages"))  
   
 (compiler-let ((*alien-eval-when* '(compile eval)))  
 (defrecord port-death-msg  
   (msg mach:msg #.(record-size 'mach:msg))  
   (ex-port-tt pad (long-words 1))  
   (ex-port (signed-byte 32) (long-words 1)))  
   
 (defoperator (server-message-port-death-msg port-death-msg)  
              ((msg server-message))  
   `(alien-index (alien-value ,msg) 0 (record-size 'port-death-msg)))  
 ); Compiler-Let  
106    
107    (defun verify-keywords (key-list valid-keys allow-other-keys)
108  ;;; *Port-Death-Handlers* is an EQ hash table of lists of functions that are    (do ((already-processed nil)
109  ;;; called upon port death.  If a port dies that is not in the table, we print         (unknown-keyword nil)
110  ;;; out a message on *Trace-Output* describing its death.  If         (remaining key-list (cddr remaining)))
111  ;;; *Pornography-Of-Death* is true, we don't even print that message.        ((null remaining)
112           (if (and unknown-keyword
113  (defvar *port-death-handlers* (make-hash-table :test #'eql)                  (not allow-other-keys)
114    "Don't use this --- use Add-Port-Death-Handler instead.")                  (not (lookup-keyword :allow-other-keys key-list)))
115               (values :unknown-keyword (list unknown-keyword valid-keys))
116  ;;; Add-Port-Death-Handler, Remove-Port-Death-Handler  --  Public             (values nil nil)))
117  ;;;      (cond ((not (and (consp remaining) (listp (cdr remaining))))
118  (defun add-port-death-handler (port function)             (return (values :dotted-list key-list)))
119    "Make Function a handler for port death on Port.  When the port dies,            ((null (cdr remaining))
120    Function is called with the port and an argument.  See also             (return (values :odd-length key-list)))
121    Remove-Port-Death-Handler."            #+nil ;; Not ANSI compliant to disallow duplicate keywords.
122    (pushnew function (gethash port *port-death-handlers*))            ((member (car remaining) already-processed)
123               (return (values :duplicate (car remaining))))
124              ((or (eq (car remaining) :allow-other-keys)
125                   (member (car remaining) valid-keys))
126               (push (car remaining) already-processed))
127              (t
128               (setf unknown-keyword (car remaining))))))
129    
130    (defun lookup-keyword (keyword key-list)
131      (do ((remaining key-list (cddr remaining)))
132          ((endp remaining))
133        (when (eq keyword (car remaining))
134          (return (cadr remaining)))))
135    ;;;
136    (defun keyword-supplied-p (keyword key-list)
137      (do ((remaining key-list (cddr remaining)))
138          ((endp remaining))
139        (when (eq keyword (car remaining))
140          (return t))))
141    
142    (in-package "CONDITIONS")
143    
144    (defvar *break-on-signals* nil
145      "When (typep condition *break-on-signals*) is true, then calls to SIGNAL will
146       enter the debugger prior to signalling that condition.")
147    
148    (defun signal (datum &rest arguments)
149      "Invokes the signal facility on a condition formed from datum and arguments.
150       If the condition is not handled, nil is returned.  If
151       (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked before
152       any signalling is done."
153      (let ((condition (coerce-to-condition datum arguments
154                                            'simple-condition 'signal))
155            (*handler-clusters* *handler-clusters*))
156        (let ((obos *break-on-signals*)
157              (*break-on-signals* nil))
158          (when (typep condition obos)
159            (break (intl:gettext "~A~%Break entered because of *break-on-signals* (now NIL.)")
160                   condition)))
161        (loop
162          (unless *handler-clusters* (return))
163          (let ((cluster (pop *handler-clusters*)))
164            (dolist (handler cluster)
165              (when (typep condition (car handler))
166                (funcall (cdr handler) condition)))))
167        nil))
168    
169    ;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and
170    ;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a single
171    ;;; argument that's directly usable by all the other routines.
172    ;;;
173    (defun coerce-to-condition (datum arguments default-type function-name)
174      (cond ((typep datum 'condition)
175             (if arguments
176                 (cerror (intl:gettext "Ignore the additional arguments.")
177                         'simple-type-error
178                         :datum arguments
179                         :expected-type 'null
180                         :format-control (intl:gettext "You may not supply additional arguments ~
181                                         when giving ~S to ~S.")
182                         :format-arguments (list datum function-name)))
183             datum)
184            ((symbolp datum) ;Roughly, (subtypep datum 'condition).
185             (apply #'make-condition datum arguments))
186            ((or (stringp datum) (functionp datum))
187             (make-condition default-type
188                             :format-control datum
189                             :format-arguments arguments))
190            (t
191             (error 'simple-type-error
192                    :datum datum
193                    :expected-type '(or symbol string)
194                    :format-control (intl:gettext "Bad argument to ~S: ~S")
195                    :format-arguments (list function-name datum)))))
196    
197    (defun error (datum &rest arguments)
198      "Invokes the signal facility on a condition formed from datum and arguments.
199       If the condition is not handled, the debugger is invoked."
200      (kernel:infinite-error-protect
201        (let ((condition (coerce-to-condition datum arguments
202                                              'simple-error 'error))
203              (debug:*stack-top-hint* debug:*stack-top-hint*))
204          (unless (and (condition-function-name condition) debug:*stack-top-hint*)
205            (multiple-value-bind
206                (name frame)
207                (kernel:find-caller-name)
208              (unless (condition-function-name condition)
209                (setf (condition-function-name condition) name))
210              (unless debug:*stack-top-hint*
211                (setf debug:*stack-top-hint* frame))))
212          (let ((debug:*stack-top-hint* nil))
213            (signal condition))
214          (invoke-debugger condition))))
215    
216    ;;; CERROR must take care to not use arguments when datum is already a
217    ;;; condition object.
218    ;;;
219    (defun cerror (continue-string datum &rest arguments)
220      (kernel:infinite-error-protect
221        (with-simple-restart
222            (continue "~A" (apply #'format nil continue-string arguments))
223          (let ((condition (if (typep datum 'condition)
224                               datum
225                               (coerce-to-condition datum arguments
226                                                    'simple-error 'error)))
227                (debug:*stack-top-hint* debug:*stack-top-hint*))
228            (unless (and (condition-function-name condition)
229                         debug:*stack-top-hint*)
230              (multiple-value-bind
231                  (name frame)
232                  (kernel:find-caller-name)
233                (unless (condition-function-name condition)
234                  (setf (condition-function-name condition) name))
235                (unless debug:*stack-top-hint*
236                  (setf debug:*stack-top-hint* frame))))
237            (with-condition-restarts condition (list (find-restart 'continue))
238              (let ((debug:*stack-top-hint* nil))
239                (signal condition))
240              (invoke-debugger condition)))))
241    nil)    nil)
242  ;;;  
243  (defun remove-port-death-handler (port function)  (defun break (&optional (datum "Break") &rest arguments)
244    "Undoes the effect of Add-Port-Death-Handler."    "Prints a message and invokes the debugger without allowing any possibility
245    (setf (gethash port *port-death-handlers*)     of condition handling occurring."
246          (delete function (gethash port *port-death-handlers*)))    (kernel:infinite-error-protect
247        (with-simple-restart (continue (intl:gettext "Return from BREAK."))
248          (let ((debug:*stack-top-hint*
249                 (or debug:*stack-top-hint*
250                     (nth-value 1 (kernel:find-caller-name)))))
251            (invoke-debugger
252             (coerce-to-condition datum arguments 'simple-condition 'break)))))
253    nil)    nil)
254    
255  (setf (object-set-operation *kernel-messages* mach:notify-port-deleted)  (defun warn (datum &rest arguments)
256        #'(lambda (obj)    "Warns about a situation by signalling a condition formed by datum and
257            (declare (ignore obj))     arguments.  While the condition is being signaled, a muffle-warning restart
258            (let* ((ex-port (alien-access     exists that causes WARN to immediately return nil."
259                             (port-death-msg-ex-port    (kernel:infinite-error-protect
260                              (server-message-port-death-msg server-message))))      (let ((condition (coerce-to-condition datum arguments
261                   (handlers (gethash ex-port *port-death-handlers*)))                                            'simple-warning 'warn)))
262              (remhash ex-port *port-table*)        (check-type condition warning (intl:gettext "a warning condition"))
263              (remhash ex-port *port-death-handlers*)        (restart-case (signal condition)
264              (if (null handlers)          (muffle-warning ()
265                  (handle-unclaimed-port-death ex-port)            :report (lambda (stream)
266                  (dolist (fun handlers) (funcall fun ex-port))))                      (write-string (intl:gettext "Skip warning.") stream))
267            mach:kern-success))            (return-from warn nil)))
268          (format *error-output* (intl:gettext "~&~@<Warning:  ~3i~:_~A~:>~%") condition)))
269  (defvar *pornography-of-death* t    nil)
   "If true, nothing is said about port deaths.")  
   
 (defun handle-unclaimed-port-death (port)  
   (unless *pornography-of-death*  
     (format *trace-output* "~&[Port ~S just bit the dust.]~%" port)))  
   
 ;;; Port receive and ownership rights messages are handled simlarly, but  
 ;;; by default we deallocate the port to make sure it's really dead.  This  
 ;;; gets around problems with ports being exhausted because some servers  
 ;;; don't really nuke the port when the deallocate the object.  
 ;;;  
   
 (defvar *port-receive-rights-handlers* (make-hash-table :test #'eql)  
   "This is a hashtable from ports to functions.  The function is called with  
   the port as its argument when a port receive rights message for that port  
   is received from the kernel.")  
   
 (defvar *port-ownership-rights-handlers* (make-hash-table :test #'eql)  
   "This is a hashtable from ports to functions.  The function is called with  
   the port as its argument when a port ownership rights message for that port  
   is received from the kernel.")  
   
 (setf (object-set-operation *kernel-messages* mach:notify-receive-rights)  
       #'(lambda (obj)  
           (declare (ignore obj))  
           (let ((ex-port (alien-access  
                           (port-death-msg-ex-port  
                            (server-message-port-death-msg server-message)))))  
             (funcall (gethash ex-port *port-receive-rights-handlers*  
                               #'handle-unclaimed-port-rights)  
                      ex-port))  
           mach:kern-success))  
   
 (setf (object-set-operation *kernel-messages* mach:notify-ownership-rights)  
       #'(lambda (obj)  
           (declare (ignore obj))  
           (let ((ex-port (alien-access  
                           (port-death-msg-ex-port  
                            (server-message-port-death-msg server-message)))))  
             (funcall (gethash ex-port *port-ownership-rights-handlers*  
                               #'handle-unclaimed-port-rights)  
                      ex-port))  
           mach:kern-success))  
   
 (defun handle-unclaimed-port-rights (port)  
   (unless *pornography-of-death*  
     (format *trace-output* "~&[Rights received for port ~D, deallocating it.]~%"  
             port))  
   (mach:port_deallocate *task-self* port)  
   (remhash port *port-receive-rights-handlers*)  
   (remhash port *port-ownership-rights-handlers*)  
   (remhash port *port-table*))  
   
 (add-port-object *task-data* nil *kernel-messages*)  
   
 ;;; Clear-Port-Tables  --  Internal  
 ;;;  
 ;;;    A before-save initialization which clears all of the port hashtables.  
 ;;;  
 (defun clear-port-tables ()  
   (clrhash *port-table*)  
   (clrhash *port-death-handlers*)  
   (clrhash *port-receive-rights-handlers*)  
   (clrhash *port-ownership-rights-handlers*))  
270    
271  (pushnew 'clear-port-tables *before-save-initializations*)  ;;; Utility functions
272    
273  |#  (defun simple-program-error (datum &rest arguments)
274      "Invokes the signal facility on a condition formed from datum and arguments.
275       If the condition is not handled, the debugger is invoked.  This function
276       is just like error, except that the condition type defaults to the type
277       simple-program-error, instead of program-error."
278      (kernel:infinite-error-protect
279        (let ((condition (coerce-to-condition datum arguments
280                                              'simple-program-error
281                                              'simple-program-error))
282              (debug:*stack-top-hint* debug:*stack-top-hint*))
283          (unless (and (condition-function-name condition) debug:*stack-top-hint*)
284            (multiple-value-bind
285                (name frame)
286                (kernel:find-caller-name)
287              (unless (condition-function-name condition)
288                (setf (condition-function-name condition) name))
289              (unless debug:*stack-top-hint*
290                (setf debug:*stack-top-hint* frame))))
291          (let ((debug:*stack-top-hint* nil))
292            (signal condition))
293          (invoke-debugger condition))))
294    
295    (in-package "LISP")
296    
297    
298  ;;; %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
# Line 472  Line 303 
303  ;;; %End-Of-The-World.  We quit this way so that all outstanding cleanup forms  ;;; %End-Of-The-World.  We quit this way so that all outstanding cleanup forms
304  ;;; in Unwind-Protects will get executed.  ;;; in Unwind-Protects will get executed.
305    
306  (proclaim '(special *lisp-initialization-functions*))  (declaim (special *lisp-initialization-functions*
307                      *load-time-values*))
308    
309  (eval-when (compile)  (eval-when (compile)
310    (defmacro print-and-call (name)    (defmacro print-and-call (name)
311      `(progn      `(progn
312         (%primitive print ,(symbol-name name))         (%primitive print ,(symbol-name name))
313         (,name))))         (,name))))
314    #+nil
315    (defun hexstr(thing)
316      (let ((addr (kernel:get-lisp-obj-address thing))
317            (str (make-string 10)))
318        (setf (char str 0) #\0
319              (char str 1) #\x)
320        (dotimes (i 8)
321          (let* ((nib (ldb (byte 4 0) addr))
322                 (chr (char "0123456789abcdef" nib)))
323            (declare (type (unsigned-byte 4) nib)
324                     (base-char chr))
325            (setf (char str (- 9 i)) chr
326                  addr (ash addr -4))))
327        str))
328    
329  (defun %initial-function ()  (defun %initial-function ()
330    "Gives the world a shove and hopes it spins."    "Gives the world a shove and hopes it spins."
   (setq *already-maybe-gcing* t)  
   (setf *gc-inhibit* t)  
   (setf *need-to-collect-garbage* nil)  
331    (%primitive print "In initial-function, and running.")    (%primitive print "In initial-function, and running.")
332      #-gengc (setf *already-maybe-gcing* t)
333      #-gengc (setf *gc-inhibit* t)
334      #-gengc (setf *need-to-collect-garbage* nil)
335      (setf *gc-verbose* #-gengc t #+gengc nil)
336      (setf *before-gc-hooks* nil)
337      (setf *after-gc-hooks* nil)
338      #-gengc (setf unix::*interrupts-enabled* t)
339      #-gengc (setf unix::*interrupt-pending* nil)
340      (setf *type-system-initialized* nil)
341      (setf *break-on-signals* nil)
342      (setf unix::*filename-encoding* nil)
343      #+gengc (setf conditions::*handler-clusters* nil)
344      (setq intl::*default-domain* "cmucl")
345      (setq intl::*locale* "C")
346    
347    ;; Many top-level forms call INFO, (SETF INFO).    ;; Many top-level forms call INFO, (SETF INFO).
348    (print-and-call c::globaldb-init)    (print-and-call c::globaldb-init)
349    
350    ;; Some of the random top-level forms call Make-Array, which calls Subtypep...    ;; Set up the fdefn database.
351      (print-and-call fdefn-init)
352    
353      ;; Some of the random top-level forms call Make-Array, which calls Subtypep
354      (print-and-call typedef-init)
355      (print-and-call class-init)
356    
357    (print-and-call type-init)    (print-and-call type-init)
358    
359    (setq *lisp-initialization-functions*    (let ((funs (nreverse *lisp-initialization-functions*)))
360          (nreverse *lisp-initialization-functions*))      (%primitive print "Calling top-level forms.")
361    (%primitive print "Calling top-level forms.")      #+nil (%primitive print (length funs))
362    (dolist (fun *lisp-initialization-functions*)      (dolist (fun funs)
363      (%primitive print fun)        #+nil (%primitive print fun)
364      (funcall fun))        (typecase fun
365            (function
366             (funcall fun))
367            (cons
368             (case (car fun)
369               (:load-time-value
370                (setf (svref *load-time-values* (third fun))
371                      (funcall (second fun))))
372               (:load-time-value-fixup
373                #-gengc
374                (setf (#+amd64 sap-ref-64
375                       #-amd64 sap-ref-32 (second fun) 0)
376                      (get-lisp-obj-address
377                       (svref *load-time-values* (third fun))))
378                #+gengc
379                (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))
380               #+(and (or x86 amd64) gencgc)
381               (:load-time-code-fixup
382                (vm::do-load-time-code-fixup (second fun) (third fun) (fourth fun)
383                                             (fifth fun)))
384               (t
385                (%primitive print
386                            "Bogus fixup in *lisp-initialization-functions*")
387                (%halt))))
388            (t
389             (%primitive print
390                         "Bogus function in *lisp-initialization-functions*")
391             (%halt)))))
392    (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.    (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
393      (makunbound '*load-time-values*)
394    
395      ;; Only do this after top level forms have run, 'cause thats where
396      ;; deftypes are.
397      (setf *type-system-initialized* t)
398    
399    (print-and-call os-init)    (print-and-call os-init)
   #+nil  
400    (print-and-call filesys-init)    (print-and-call filesys-init)
   #+nil  
   (print-and-call conditions::error-init)  
401    
   #+nil  
402    (print-and-call reader-init)    (print-and-call reader-init)
403    #+nil    ;; Note: sharpm and backq not yet loaded, so this is not the final RT.
404    (print-and-call backq-init)    (setf *readtable* (copy-readtable std-lisp-readtable))
   #+nil  
   (print-and-call sharp-init)  
   ;; After the various reader subsystems have done their thing to the standard  
   ;; readtable, copy it to *readtable*.  
   #+nil  
   (setq *readtable* (copy-readtable std-lisp-readtable))  
405    
   #+nil  
406    (print-and-call stream-init)    (print-and-call stream-init)
407    #+nil    (print-and-call loader-init)
   (print-and-call random-init)  
   #+nil  
   (print-and-call format-init)  
   #+nil  
408    (print-and-call package-init)    (print-and-call package-init)
409    #+nil    (print-and-call kernel::signal-init)
410    (print-and-call pprint-init)    (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
411    
412      (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero))
413    
414      ;; This is necessary because some of the initial top level forms might
415      ;; have changed the compilation policy in strange ways.
416      (print-and-call c::proclaim-init)
417    
418      (print-and-call kernel::class-finalize)
419    
420    (setq *already-maybe-gcing* nil)    (setq intl::*default-domain* nil)
421      (%primitive print "Done initializing.")
422    
423      #-gengc (setf *already-maybe-gcing* nil)
424      #+gengc (setf *gc-verbose* t)
425    (terpri)    (terpri)
426    (princ "CMU Common Lisp kernel core image ")    (princ "CMU Common Lisp kernel core image ")
427    (princ (lisp-implementation-version))    (princ (lisp-implementation-version))
# Line 537  Line 429 
429    (terpri)    (terpri)
430    (princ "[You are in the LISP package.]")    (princ "[You are in the LISP package.]")
431    (terpri)    (terpri)
432    (catch '%end-of-the-world    (let ((wot (catch '%end-of-the-world
433      (loop                 (loop
434       (%top-level)                   (%top-level)
435       (write-line "You're certainly a clever child.")))                   (write-line "You're certainly a clever child.")))))
436    #+nil      (unix:unix-exit wot)))
437    (mach:unix-exit 0))  
438    #+gengc
439    (defun do-load-time-value-fixup (object offset index)
440      (declare (type index offset))
441      (macrolet ((lose (msg)
442                   `(progn
443                      (%primitive print ,msg)
444                      (%halt))))
445        (let ((value (svref *load-time-values* index)))
446          (typecase object
447            (list
448             (case offset
449               (0 (setf (car object) value))
450               (1 (setf (cdr object) value))
451               (t (lose "Bogus offset in cons cell."))))
452            (instance
453             (setf (%instance-ref object (- offset vm:instance-slots-offset))
454                   value))
455            (code-component
456             (setf (code-header-ref object offset) value))
457            (simple-vector
458             (setf (svref object (- offset vm:vector-data-offset)) value))
459            (t
460             (lose "Unknown kind of object for load-time-value fixup."))))))
461    
462    
463  ;;;; Initialization functions:  ;;;; Initialization functions:
464    
465  ;;; Reinit is called to reinitialize the world when a saved core image  ;;; Print seems to not like x86 NPX denormal floats like
466  ;;; is resumed.  ;;; least-negative-single-float, so the :underflow exceptions
467  (defvar *task-notify* NIL)  ;;; is disabled by default. Joe User can explicitly enable them
468    ;;; if desired.
469    
470  (defun reinit ()  (defun reinit ()
471    (without-interrupts    (without-interrupts
472     (setq *already-maybe-gcing* t)     (without-gcing
473     (os-init)      (os-init)
474     #+nil      (stream-reinit)
475     (stream-reinit)      (kernel::signal-init)
476     (setq *already-maybe-gcing* nil))      (gc-init)
477    #+nil      (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
478    (setq *task-notify* (mach:mach-task_notify))      (set-floating-point-modes :traps
479    #+nil                                '(:overflow :invalid :divide-by-zero))
480    (mach:port_enable (mach:mach-task_self) *task-notify*)      ;; Clear pseudo atomic in case this core wasn't compiled with support.
481    #+nil      #+(or x86 amd64) (setf lisp::*pseudo-atomic-atomic* 0))))
   (add-port-object *task-notify* nil *kernel-messages*)  
   #+nil  
   (init-mach-signals))  
   
   
 ;;; OS-Init initializes our operating-system interface.  It sets the values  
 ;;; of the global port variables to what they should be and calls the functions  
 ;;; that set up the argument blocks for the server interfaces.  
   
 (defun os-init ()  
   #+nil  
   (setq *task-self* (mach:mach-task_self))  
   #+nil  
   (setq *task-data* (mach:mach-task_data)))  
   
   
 ;;; Setup-path-search-list returns a list of the directories that are  
 ;;; in the unix path environment variable.  This is so that run-program  
 ;;; can be smarter about where to find a program to run.  
 (defun setup-path-search-list ()  
   (let ((path (cdr (assoc :path ext::*environment-list*))))  
     (when path  
       (do* ((i 0 (1+ p))  
             (p (position #\: path :start i)  
                (position #\: path :start i))  
             (pl ()))  
            ((null p)  
             (let ((s (subseq path i)))  
               (if (string= s "")  
                   (push "default:" pl)  
                   (push (concatenate 'simple-string s "/") pl)))  
             (nreverse pl))  
         (let ((s (subseq path i p)))  
           (if (string= s "")  
               (push "default:" pl)  
               (push (concatenate 'simple-string s "/") pl)))))))  
482    
483    
484  ;;;; Miscellaneous external functions:  ;;;; Miscellaneous external functions:
485    
486  (defun print-herald ()  (defvar *cleanup-functions* nil
487    (write-string "CMU Common Lisp ")    "Functions to be invoked during cleanup at Lisp exit.")
   (write-line (lisp-implementation-version))  
   (write-string "Hemlock ") (write-string *hemlock-version*)  
   (write-string ", Compiler ") (write-line compiler-version)  
   (write-line "Send bug reports and questions to Gripe.")  
   (values))  
   
 (defvar *editor-lisp-p* nil  
   "This is true if and only if the lisp was started with the -edit switch.")  
   
 #+nil ;; Can't save lisps yet  
 (defun save-lisp (core-file-name &key  
                                  (purify t)  
                                  (root-structures ())  
                                  (init-function  
                                   #'(lambda ()  
                                       (throw 'top-level-catcher nil)))  
                                  (load-init-file t)  
                                  (print-herald t)  
                                  (process-command-line t))  
   "Saves a Spice Lisp core image in the file of the specified name.  The  
   following keywords are defined:  
   
   :purify  
       If true, do a purifying GC which moves all dynamically allocated  
   objects into static space so that they stay pure.  This takes somewhat  
   longer than the normal GC which is otherwise done, but GC's will done  
   less often and take less time in the resulting core file.  
   
   :root-structures  
       This should be a list of the main entry points in any newly loaded  
   systems.  This need not be supplied, but locality will be better if it  
   is.  This is meaningless if :purify is Nil.  
   
   :init-function  
       This is a function which is called when the created core file is  
   resumed.  The default function simply aborts to the top level  
   read-eval-print loop.  If the function returns it will be the value  
   of Save-Lisp.  
   
   :load-init-file  
       If true, then look for an init.lisp or init.fasl file when the core  
   file is resumed.  
   
   :print-herald  
       If true, print out the lisp system herald when starting."  
   
   (if purify  
       (purify :root-structures root-structures)  
       (gc))  
   (unless (save core-file-name)  
     (setf (search-list "default:") (list (default-directory)))  
     (setf (search-list "path:") (setup-path-search-list))  
     (when process-command-line (ext::process-command-strings))  
     (setf *editor-lisp-p* nil)  
     (macrolet ((find-switch (name)  
                  `(find ,name *command-line-switches*  
                         :key #'cmd-switch-name  
                         :test #'(lambda (x y)  
                                   (declare (simple-string x y))  
                                   (string-equal x y)))))  
       (when (and process-command-line (find-switch "edit"))  
         (setf *editor-lisp-p* t))  
       (when (and load-init-file  
                  (not (and process-command-line (find-switch "noinit"))))  
         (let* ((cl-switch (find-switch "init"))  
                (name (or (and cl-switch  
                               (or (cmd-switch-value cl-switch)  
                                   (car (cmd-switch-words cl-switch))  
                                   "init"))  
                          "init")))  
           (load (merge-pathnames name (user-homedir-pathname))  
                 :if-does-not-exist nil))))  
     (when print-herald  
       (print-herald))  
     (when process-command-line  
       (ext::invoke-switch-demons *command-line-switches*  
                                  *command-switch-demons*))  
     (funcall init-function)))  
   
488    
489  ;;; Quit gets us out, one way or another.  ;;; Quit gets us out, one way or another.
490    
# Line 691  Line 492 
492    "Terminates the current Lisp.  Things are cleaned up unless Recklessly-P is    "Terminates the current Lisp.  Things are cleaned up unless Recklessly-P is
493    non-Nil."    non-Nil."
494    (if recklessly-p    (if recklessly-p
495        (mach:unix-exit 0)        (unix:unix-exit 0)
496        (throw '%end-of-the-world nil)))        (progn
497            (mapc (lambda (fn) (ignore-errors (funcall fn))) *cleanup-functions*)
498            (throw '%end-of-the-world 0))))
 #| might be something different.  
499    
 (defalien sleep-msg mach:msg (record-size 'mach:msg))  
 (setf (alien-access (mach:msg-simplemsg sleep-msg)) T)  
 (setf (alien-access (mach:msg-msgtype sleep-msg)) 0)  
 (setf (alien-access (mach:msg-msgsize sleep-msg))  
       (/ (record-size 'mach:msg) 8))  
   
 ;;; Currently there is a bug in the Mach timeout code that if the timeout  
 ;;; period is too short the receive never returns.  
500    
501    #-mp ; Multi-processing version defined in multi-proc.lisp.
502  (defun sleep (n)  (defun sleep (n)
503    "This function causes execution to be suspended for N seconds.  N may    _N"This function causes execution to be suspended for N seconds.  N may
504    be any non-negative, non-complex number."    be any non-negative, non-complex number."
505    (with-reply-port (sleep-port)    (when (or (not (realp n))
506      (let ((m (round (* 1000 n))))              (minusp n))
507        (cond ((minusp m)      (error 'simple-type-error
508               (error "Argument to Sleep, ~S, is a negative number." n))             :format-control
509              ((zerop m))             "Invalid argument to SLEEP: ~S.~%~
510              (t              Must be a non-negative, non-complex number."
511               (setf (alien-access (mach:msg-localport sleep-msg)) sleep-port)             :format-arguments (list n)
512               (let ((gr (mach:msg-receive sleep-msg mach:rcv-timeout m)))             :datum n
513                 (unless (eql gr mach:rcv-timed-out)             :expected-type '(real 0)))
514                   (gr-error 'mach:receive gr)))))))    (multiple-value-bind (sec usec)
515        (if (integerp n)
516            (values n 0)
517            (multiple-value-bind (sec frac) (truncate n)
518              (values sec (truncate frac 1e-6))))
519        (unix:unix-select 0 0 0 0 sec usec))
520    nil)    nil)
521    
522    ;;;; SCRUB-CONTROL-STACK
523    
524  |#  #+stack-checking
525    (alien:def-alien-routine "os_guard_control_stack" c-call:void
526      (zone   c-call:int)
527      (guardp c-call:int))
528    
529    
530    (defconstant bytes-per-scrub-unit 2048)
531    
532    ;;; Scrub-control-stack.
533    ;;;
534    #-(or x86 amd64)
535    (defun %scrub-control-stack ()
536      _N"Zero the unused portion of the control stack so that old objects are not
537       kept alive because of uninitialized stack variables."
538      (declare (optimize (speed 3) (safety 0))
539               (values (unsigned-byte 20)))
540      (labels
541          ((scrub (ptr offset count)
542             (declare (type system-area-pointer ptr)
543                      (type (unsigned-byte 16) offset)
544                      (type (unsigned-byte 20) count)
545                      (values (unsigned-byte 20)))
546             (cond ((= offset bytes-per-scrub-unit)
547                    (look (sap+ ptr bytes-per-scrub-unit) 0 count))
548                   (t
549                    (setf (sap-ref-32 ptr offset) 0)
550                    (scrub ptr (+ offset vm:word-bytes) count))))
551           (look (ptr offset count)
552             (declare (type system-area-pointer ptr)
553                      (type (unsigned-byte 16) offset)
554                      (type (unsigned-byte 20) count)
555                      (values (unsigned-byte 20)))
556             (cond ((= offset bytes-per-scrub-unit)
557                    count)
558                   ((zerop (sap-ref-32 ptr offset))
559                    (look ptr (+ offset vm:word-bytes) count))
560                   (t
561                    (scrub ptr offset (+ count vm:word-bytes))))))
562        (let* ((csp (sap-int (c::control-stack-pointer-sap)))
563               (initial-offset (logand csp (1- bytes-per-scrub-unit))))
564          (declare (type (unsigned-byte 32) csp))
565          (scrub (int-sap (- csp initial-offset))
566                 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
567                 0))))
568    
569    ;;; Scrub-control-stack.
570    ;;;
571    ;;; On the x86 and amd64 port the stack grows downwards, and to support grow on
572    ;;; demand stacks the stack must be decreased as it is scrubbed.
573    ;;;
574    (defun scrub-control-stack ()
575      "Zero the unused portion of the control stack so that old objects are not
576       kept alive because of uninitialized stack variables."
577      ;;
578      ;; The guard zone of the control stack is used by Lisp sometimes,
579      ;; so I think it should be zero'd out, too.
580      #+stack-checking (os-guard-control-stack 0 0)
581      (%scrub-control-stack)
582      #+stack-checking (os-guard-control-stack 0 1))
583    
584    #+(or x86 amd64)
585    (defun %scrub-control-stack ()
586      (%scrub-control-stack))
587    
588    
589  ;;;; TOP-LEVEL loop.  ;;;; TOP-LEVEL loop.
# Line 747  Line 609 
609  (defun interactive-eval (form)  (defun interactive-eval (form)
610    "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,    "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
611    +, ///, //, /, and -."    +, ///, //, /, and -."
612    (setf +++ ++    (when (and (fboundp 'commandp) (funcall 'commandp form))
613          ++ +      (return-from interactive-eval (funcall 'invoke-command-interactive form)))
614          + -    (setf - form)
         - form)  
615    (let ((results (multiple-value-list (eval form))))    (let ((results (multiple-value-list (eval form))))
616        (finish-standard-output-streams)
617      (setf /// //      (setf /// //
618            // /            // /
619            / results            / results
620            *** **            *** **
621            ** *            ** *
622            * (car results)))            * (car results)))
623      (setf +++ ++
624            ++ +
625            + -)
626    (unless (boundp '*)    (unless (boundp '*)
627      ;; The bogon returned an unbound marker.      ;; The bogon returned an unbound marker.
628      (setf * nil)      (setf * nil)
629      (cerror "Go on with * set to NIL."      (cerror (intl:gettext "Go on with * set to NIL.")
630              "EVAL returned an unbound marker."))              (intl:gettext "EVAL returned an unbound marker.")))
631    (values-list /))    (values-list /))
632    
633    
634  (defconstant eofs-before-quit 10)  (defconstant eofs-before-quit 10)
635    
636    (defparameter *reserved-heap-pages* 256
637      "How many pages to reserve from the total heap space so we can handle
638    heap overflow.")
639    
640    #+heap-overflow-check
641    (alien:def-alien-variable "reserved_heap_pages" c-call:unsigned-long)
642    
643  (defun %top-level ()  (defun %top-level ()
644    "Top-level READ-EVAL-PRINT loop.  Do not call this."    "Top-level READ-EVAL-PRINT loop.  Do not call this."
645    (let  ((* nil) (** nil) (*** nil)    (let  ((* nil) (** nil) (*** nil)
# Line 775  Line 648 
648           (magic-eof-cookie (cons :eof nil))           (magic-eof-cookie (cons :eof nil))
649           (number-of-eofs 0))           (number-of-eofs 0))
650      (loop      (loop
651       (with-simple-restart (abort "Return to Top-Level.")        (with-simple-restart (abort (intl:gettext "Return to Top-Level."))
652         (catch 'top-level-catcher          (catch 'top-level-catcher
653           (let ((*in-top-level-catcher* t))            (unix:unix-sigsetmask 0)
654             (loop            (let ((*in-top-level-catcher* t))
655               (fresh-line)              (loop
656               (princ (if (functionp *prompt*)                (scrub-control-stack)
657                          (funcall *prompt*)                (fresh-line)
658                          *prompt*))                ;; Reset reserved pages in the heap
659               (force-output)                #+heap-overflow-check (setf reserved-heap-pages *reserved-heap-pages*)
660               (let ((form (read *standard-input* nil magic-eof-cookie)))                (princ (if (functionp *prompt*)
661                 (cond ((not (eq form magic-eof-cookie))                           (funcall *prompt*)
662                        (let ((results                           *prompt*))
663                               (multiple-value-list (interactive-eval form))))                (force-output)
664                          (dolist (result results)                (let ((form (read *standard-input* nil magic-eof-cookie)))
665                            (fresh-line)                  (cond ((not (eq form magic-eof-cookie))
666                            (prin1 result)))                         (let ((results
667                        (setf number-of-eofs 0))                                (multiple-value-list (interactive-eval form))))
668                       ((eql (incf number-of-eofs) 1)                           (dolist (result results)
669                        (let ((stream (make-synonym-stream '*terminal-io*)))                             (fresh-line)
670                          (setf *standard-input* stream)                             (prin1 result)))
671                          (setf *standard-output* stream)                         (setf number-of-eofs 0))
672                          (format t "~&Received EOF on *standard-input*, ~                        ((eql (incf number-of-eofs) 1)
673                                    switching to *terminal-io*.~%")))                         (if *batch-mode*
674                       ((> number-of-eofs eofs-before-quit)                             (quit)
675                        (format t "~&Received more than ~D EOFs; Aborting.~%"                             (let ((stream (make-synonym-stream '*terminal-io*)))
676                                eofs-before-quit)                               (setf *standard-input* stream)
677                        (quit))                               (setf *standard-output* stream)
678                       (t                               (format t (intl:gettext "~&Received EOF on *standard-input*, ~
679                        (format t "~&Received EOF.~%")))))))))))                                          switching to *terminal-io*.~%")))))
680                          ((> number-of-eofs eofs-before-quit)
681                           (format t (intl:gettext "~&Received more than ~D EOFs; Aborting.~%")
682                                   eofs-before-quit)
683                           (quit))
684                          (t
685                           (format t (intl:gettext "~&Received EOF.~%"))))))))))))
686    
687    
688  ;;; %Halt  --  Interface  ;;; %Halt  --  Interface

Legend:
Removed from v.1.1.1.3  
changed lines
  Added in v.1.82

  ViewVC Help
Powered by ViewVC 1.1.5