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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5