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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5