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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.56 - (show annotations)
Fri Apr 10 11:42:42 1998 UTC (16 years ago) by pw
Branch: MAIN
Changes since 1.55: +3 -3 lines
Export type boolean from common-lisp package.
1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/lispinit.lisp,v 1.56 1998/04/10 11:42:42 pw Exp $")
9 ;;;
10 ;;; **********************************************************************
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)
18
19 (export '(most-positive-fixnum most-negative-fixnum sleep
20 ++ +++ ** *** // ///))
21
22 (in-package :system)
23 (export '(compiler-version scrub-control-stack))
24
25 (in-package :extensions)
26 (export '(quit *prompt*))
27
28 (in-package :lisp)
29
30 ;;; Make the error system enable interrupts.
31
32 (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum
33 "The fixnum closest in value to positive infinity.")
34
35 (defconstant most-negative-fixnum #.vm:target-most-negative-fixnum
36 "The fixnum closest in value to negative infinity.")
37
38
39 ;;; Random information:
40
41 (defvar *lisp-implementation-version* "4.0(?)")
42
43
44 ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs...
45 (declaim
46 #-gengc
47 (special *gc-inhibit* *already-maybe-gcing*
48 *need-to-collect-garbage* *gc-verbose*
49 *before-gc-hooks* *after-gc-hooks*
50 #+x86 *pseudo-atomic-atomic*
51 #+x86 *pseudo-atomic-interrupted*
52 unix::*interrupts-enabled*
53 unix::*interrupt-pending*
54 *type-system-initialized*)
55 #+gengc
56 (special *gc-verbose* *before-gc-hooks* *after-gc-hooks*
57 *type-system-initialized*))
58
59
60 ;;;; Random magic specials.
61
62
63 ;;; These are filled in by Genesis.
64
65 #-gengc
66 (progn
67
68 (defvar *current-catch-block*)
69 (defvar *current-unwind-protect-block*)
70 (defvar *free-interrupt-context-index*)
71
72 ); #-gengc progn
73
74
75 ;;;; Random stuff that needs to be in the cold load which would otherwise be
76 ;;;; byte-compiled.
77 ;;;;
78 (defvar hi::*in-the-editor* nil)
79
80 ;;;; Called by defmacro expanders...
81
82 ;;; VERIFY-KEYWORDS -- internal
83 ;;;
84 ;;; Determine if key-list is a valid list of keyword/value pairs. Do not
85 ;;; signal the error directly, 'cause we don't know how it should be signaled.
86 ;;;
87 (defun verify-keywords (key-list valid-keys allow-other-keys)
88 (do ((already-processed nil)
89 (unknown-keyword nil)
90 (remaining key-list (cddr remaining)))
91 ((null remaining)
92 (if (and unknown-keyword
93 (not allow-other-keys)
94 (not (lookup-keyword :allow-other-keys key-list)))
95 (values :unknown-keyword (list unknown-keyword valid-keys))
96 (values nil nil)))
97 (cond ((not (and (consp remaining) (listp (cdr remaining))))
98 (return (values :dotted-list key-list)))
99 ((null (cdr remaining))
100 (return (values :odd-length key-list)))
101 ((member (car remaining) already-processed)
102 (return (values :duplicate (car remaining))))
103 ((or (eq (car remaining) :allow-other-keys)
104 (member (car remaining) valid-keys))
105 (push (car remaining) already-processed))
106 (t
107 (setf unknown-keyword (car remaining))))))
108
109 (defun lookup-keyword (keyword key-list)
110 (do ((remaining key-list (cddr remaining)))
111 ((endp remaining))
112 (when (eq keyword (car remaining))
113 (return (cadr remaining)))))
114 ;;;
115 (defun keyword-supplied-p (keyword key-list)
116 (do ((remaining key-list (cddr remaining)))
117 ((endp remaining))
118 (when (eq keyword (car remaining))
119 (return t))))
120
121 (in-package "CONDITIONS")
122
123 (defvar *break-on-signals* nil
124 "When (typep condition *break-on-signals*) is true, then calls to SIGNAL will
125 enter the debugger prior to signalling that condition.")
126
127 (defun signal (datum &rest arguments)
128 "Invokes the signal facility on a condition formed from datum and arguments.
129 If the condition is not handled, nil is returned. If
130 (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked before
131 any signalling is done."
132 (let ((condition (coerce-to-condition datum arguments
133 'simple-condition 'signal))
134 (*handler-clusters* *handler-clusters*))
135 (let ((obos *break-on-signals*)
136 (*break-on-signals* nil))
137 (when (typep condition obos)
138 (break "~A~%Break entered because of *break-on-signals* (now NIL.)"
139 condition)))
140 (loop
141 (unless *handler-clusters* (return))
142 (let ((cluster (pop *handler-clusters*)))
143 (dolist (handler cluster)
144 (when (typep condition (car handler))
145 (funcall (cdr handler) condition)))))
146 nil))
147
148 ;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and
149 ;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a single
150 ;;; argument that's directly usable by all the other routines.
151 ;;;
152 (defun coerce-to-condition (datum arguments default-type function-name)
153 (cond ((typep datum 'condition)
154 (if arguments
155 (cerror "Ignore the additional arguments."
156 'simple-type-error
157 :datum arguments
158 :expected-type 'null
159 :format-control "You may not supply additional arguments ~
160 when giving ~S to ~S."
161 :format-arguments (list datum function-name)))
162 datum)
163 ((symbolp datum) ;Roughly, (subtypep datum 'condition).
164 (apply #'make-condition datum arguments))
165 ((or (stringp datum) (functionp datum))
166 (make-condition default-type
167 :format-control datum
168 :format-arguments arguments))
169 (t
170 (error 'simple-type-error
171 :datum datum
172 :expected-type '(or symbol string)
173 :format-control "Bad argument to ~S: ~S"
174 :format-arguments (list function-name datum)))))
175
176 (defun error (datum &rest arguments)
177 "Invokes the signal facility on a condition formed from datum and arguments.
178 If the condition is not handled, the debugger is invoked."
179 (kernel:infinite-error-protect
180 (let ((condition (coerce-to-condition datum arguments
181 'simple-error 'error))
182 (debug:*stack-top-hint* debug:*stack-top-hint*))
183 (unless (and (condition-function-name condition) debug:*stack-top-hint*)
184 (multiple-value-bind
185 (name frame)
186 (kernel:find-caller-name)
187 (unless (condition-function-name condition)
188 (setf (condition-function-name condition) name))
189 (unless debug:*stack-top-hint*
190 (setf debug:*stack-top-hint* frame))))
191 (let ((debug:*stack-top-hint* nil))
192 (signal condition))
193 (invoke-debugger condition))))
194
195 ;;; CERROR must take care to not use arguments when datum is already a
196 ;;; condition object.
197 ;;;
198 (defun cerror (continue-string datum &rest arguments)
199 (kernel:infinite-error-protect
200 (with-simple-restart
201 (continue "~A" (apply #'format nil continue-string arguments))
202 (let ((condition (if (typep datum 'condition)
203 datum
204 (coerce-to-condition datum arguments
205 'simple-error 'error)))
206 (debug:*stack-top-hint* debug:*stack-top-hint*))
207 (unless (and (condition-function-name condition)
208 debug:*stack-top-hint*)
209 (multiple-value-bind
210 (name frame)
211 (kernel:find-caller-name)
212 (unless (condition-function-name condition)
213 (setf (condition-function-name condition) name))
214 (unless debug:*stack-top-hint*
215 (setf debug:*stack-top-hint* frame))))
216 (with-condition-restarts condition (list (find-restart 'continue))
217 (let ((debug:*stack-top-hint* nil))
218 (signal condition))
219 (invoke-debugger condition)))))
220 nil)
221
222 (defun break (&optional (datum "Break") &rest arguments)
223 "Prints a message and invokes the debugger without allowing any possibility
224 of condition handling occurring."
225 (kernel:infinite-error-protect
226 (with-simple-restart (continue "Return from BREAK.")
227 (let ((debug:*stack-top-hint*
228 (or debug:*stack-top-hint*
229 (nth-value 1 (kernel:find-caller-name)))))
230 (invoke-debugger
231 (coerce-to-condition datum arguments 'simple-condition 'break)))))
232 nil)
233
234 (defun warn (datum &rest arguments)
235 "Warns about a situation by signalling a condition formed by datum and
236 arguments. While the condition is being signaled, a muffle-warning restart
237 exists that causes WARN to immediately return nil."
238 (kernel:infinite-error-protect
239 (let ((condition (coerce-to-condition datum arguments
240 'simple-warning 'warn)))
241 (check-type condition warning "a warning condition")
242 (restart-case (signal condition)
243 (muffle-warning ()
244 :report "Skip warning."
245 (return-from warn nil)))
246 (format *error-output* "~&~@<Warning: ~3i~:_~A~:>~%" condition)))
247 nil)
248
249 (in-package "LISP")
250
251
252 ;;; %Initial-Function is called when a cold system starts up. First we zoom
253 ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
254 ;;; at "load time." Then we initialize the various subsystems and call the
255 ;;; read-eval-print loop. The top-level Read-Eval-Print loop is executed until
256 ;;; someone (most likely the Quit function) throws to the tag
257 ;;; %End-Of-The-World. We quit this way so that all outstanding cleanup forms
258 ;;; in Unwind-Protects will get executed.
259
260 (proclaim '(special *lisp-initialization-functions*
261 *load-time-values*))
262
263 (eval-when (compile)
264 (defmacro print-and-call (name)
265 `(progn
266 (%primitive print ,(symbol-name name))
267 (,name))))
268 #+nil
269 (defun hexstr(thing)
270 (let ((addr (kernel:get-lisp-obj-address thing))
271 (str (make-string 10)))
272 (setf (char str 0) #\0
273 (char str 1) #\x)
274 (dotimes (i 8)
275 (let* ((nib (ldb (byte 4 0) addr))
276 (chr (char "0123456789abcdef" nib)))
277 (declare (type (unsigned-byte 4) nib)
278 (base-char chr))
279 (setf (char str (- 9 i)) chr
280 addr (ash addr -4))))
281 str))
282
283 (defun %initial-function ()
284 "Gives the world a shove and hopes it spins."
285 (%primitive print "In initial-function, and running.")
286 #-gengc (setf *already-maybe-gcing* t)
287 #-gengc (setf *gc-inhibit* t)
288 #-gengc (setf *need-to-collect-garbage* nil)
289 (setf *gc-verbose* #-gengc t #+gengc nil)
290 (setf *before-gc-hooks* nil)
291 (setf *after-gc-hooks* nil)
292 #-gengc (setf unix::*interrupts-enabled* t)
293 #-gengc (setf unix::*interrupt-pending* nil)
294 (setf *type-system-initialized* nil)
295 (setf *break-on-signals* nil)
296 #+gengc (setf conditions::*handler-clusters* nil)
297
298 ;; Many top-level forms call INFO, (SETF INFO).
299 (print-and-call c::globaldb-init)
300
301 ;; Set up the fdefn database.
302 (print-and-call fdefn-init)
303
304 ;; Some of the random top-level forms call Make-Array, which calls Subtypep
305 (print-and-call typedef-init)
306 (print-and-call class-init)
307 (print-and-call type-init)
308
309 (let ((funs (nreverse *lisp-initialization-functions*)))
310 (%primitive print "Calling top-level forms.")
311 (dolist (fun funs) #+nil (%primitive print (hexstr fun))
312 (typecase fun
313 (function
314 (funcall fun))
315 (cons
316 (case (car fun)
317 (:load-time-value
318 (setf (svref *load-time-values* (third fun))
319 (funcall (second fun))))
320 (:load-time-value-fixup
321 #-gengc
322 (setf (sap-ref-32 (second fun) 0)
323 (get-lisp-obj-address
324 (svref *load-time-values* (third fun))))
325 #+gengc
326 (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))
327 #+(and x86 gencgc)
328 (:load-time-code-fixup
329 (vm::do-load-time-code-fixup (second fun) (third fun) (fourth fun)
330 (fifth fun)))
331 (t
332 (%primitive print
333 "Bogus fixup in *lisp-initialization-functions*")
334 (%halt))))
335 (t
336 (%primitive print
337 "Bogus function in *lisp-initialization-functions*")
338 (%halt)))))
339 (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
340 (makunbound '*load-time-values*)
341
342 ;; Only do this after top level forms have run, 'cause thats where
343 ;; deftypes are.
344 (setf *type-system-initialized* t)
345
346 (print-and-call os-init)
347 (print-and-call filesys-init)
348
349 (print-and-call reader-init)
350 ;; Note: sharpm and backq not yet loaded, so this is not the final RT.
351 (setf *readtable* (copy-readtable std-lisp-readtable))
352
353 (print-and-call stream-init)
354 (print-and-call loader-init)
355 (print-and-call package-init)
356 (print-and-call kernel::signal-init)
357 (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
358
359 (set-floating-point-modes :traps '(:overflow #-x86 :underflow :invalid
360 :divide-by-zero))
361 ;; This is necessary because some of the initial top level forms might
362 ;; have changed the compliation policy in strange ways.
363 (print-and-call c::proclaim-init)
364
365 (print-and-call kernel::class-finalize)
366
367 (%primitive print "Done initializing.")
368
369 #-gengc (setf *already-maybe-gcing* nil)
370 #+gengc (setf *gc-verbose* t)
371 (terpri)
372 (princ "CMU Common Lisp kernel core image ")
373 (princ (lisp-implementation-version))
374 (princ ".")
375 (terpri)
376 (princ "[You are in the LISP package.]")
377 (terpri)
378 (let ((wot
379 (catch '%end-of-the-world
380 (loop
381 (%top-level)
382 (write-line "You're certainly a clever child.")))))
383 (unix:unix-exit wot)))
384
385 #+gengc
386 (defun do-load-time-value-fixup (object offset index)
387 (declare (type index offset))
388 (macrolet ((lose (msg)
389 `(progn
390 (%primitive print ,msg)
391 (%halt))))
392 (let ((value (svref *load-time-values* index)))
393 (typecase object
394 (list
395 (case offset
396 (0 (setf (car object) value))
397 (1 (setf (cdr object) value))
398 (t (lose "Bogus offset in cons cell."))))
399 (instance
400 (setf (%instance-ref object (- offset vm:instance-slots-offset))
401 value))
402 (code-component
403 (setf (code-header-ref object offset) value))
404 (simple-vector
405 (setf (svref object (- offset vm:vector-data-offset)) value))
406 (t
407 (lose "Unknown kind of object for load-time-value fixup."))))))
408
409
410 ;;;; Initialization functions:
411
412 ;;; Print seems to not like x86 NPX denormal floats like
413 ;;; least-negative-single-float, so the :underflow exceptions
414 ;;; is disabled by default. Joe User can explicitly enable them
415 ;;; if desired.
416
417 (defun reinit ()
418 (without-interrupts
419 (without-gcing
420 (os-init)
421 (stream-reinit)
422 (kernel::signal-init)
423 (gc-init)
424 (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
425 (set-floating-point-modes :traps
426 '(:overflow #-x86 :underflow :invalid
427 :divide-by-zero))
428 ;; Clear pseudo atomic in case it this core wasn't compiled with
429 ;; support.
430 #+x86 (setf lisp::*pseudo-atomic-atomic* 0))))
431
432
433
434 ;;;; Miscellaneous external functions:
435
436 ;;; Quit gets us out, one way or another.
437
438 (defun quit (&optional recklessly-p)
439 "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
440 non-Nil."
441 (if recklessly-p
442 (unix:unix-exit 0)
443 (throw '%end-of-the-world 0)))
444
445
446 #-mp ; Multi-processing version defined in multi-proc.lisp.
447 (defun sleep (n)
448 "This function causes execution to be suspended for N seconds. N may
449 be any non-negative, non-complex number."
450 (when (or (not (realp n))
451 (minusp n))
452 (error "Invalid argument to SLEEP: ~S.~%~
453 Must be a non-negative, non-complex number."
454 n))
455 (multiple-value-bind (sec usec)
456 (if (integerp n)
457 (values n 0)
458 (values (truncate n)
459 (truncate (* n 1000000))))
460 (unix:unix-select 0 0 0 0 sec usec))
461 nil)
462
463
464 ;;;; SCRUB-CONTROL-STACK
465
466
467 (defconstant bytes-per-scrub-unit 2048)
468
469 #-x86
470 (defun scrub-control-stack ()
471 "Zero the unused portion of the control stack so that old objects are not
472 kept alive because of uninitialized stack variables."
473 (declare (optimize (speed 3) (safety 0))
474 (values (unsigned-byte 20)))
475 (labels
476 ((scrub (ptr offset count)
477 (declare (type system-area-pointer ptr)
478 (type (unsigned-byte 16) offset)
479 (type (unsigned-byte 20) count)
480 (values (unsigned-byte 20)))
481 (cond ((= offset bytes-per-scrub-unit)
482 (look (sap+ ptr bytes-per-scrub-unit) 0 count))
483 (t
484 (setf (sap-ref-32 ptr offset) 0)
485 (scrub ptr (+ offset vm:word-bytes) count))))
486 (look (ptr offset count)
487 (declare (type system-area-pointer ptr)
488 (type (unsigned-byte 16) offset)
489 (type (unsigned-byte 20) count)
490 (values (unsigned-byte 20)))
491 (cond ((= offset bytes-per-scrub-unit)
492 count)
493 ((zerop (sap-ref-32 ptr offset))
494 (look ptr (+ offset vm:word-bytes) count))
495 (t
496 (scrub ptr offset (+ count vm:word-bytes))))))
497 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
498 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
499 (declare (type (unsigned-byte 32) csp))
500 (scrub (int-sap (- csp initial-offset))
501 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
502 0))))
503
504 #+x86 ;; Stack grows downwards
505 (defun scrub-control-stack ()
506 "Zero the unused portion of the control stack so that old objects are not
507 kept alive because of uninitialized stack variables."
508 (declare (optimize (speed 3) (safety 0))
509 (values (unsigned-byte 20)))
510 (labels
511 ((scrub (ptr offset count)
512 (declare (type system-area-pointer ptr)
513 (type (unsigned-byte 16) offset)
514 (type (unsigned-byte 20) count)
515 (values (unsigned-byte 20)))
516 (let ((loc (int-sap (- (sap-int ptr) (+ offset vm:word-bytes)))))
517 (cond ((= offset bytes-per-scrub-unit)
518 (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit))
519 0 count))
520 (t ;; need to fix bug in %set-stack-ref
521 (setf (sap-ref-32 loc 0) 0)
522 (scrub ptr (+ offset vm:word-bytes) count)))))
523 (look (ptr offset count)
524 (declare (type system-area-pointer ptr)
525 (type (unsigned-byte 16) offset)
526 (type (unsigned-byte 20) count)
527 (values (unsigned-byte 20)))
528 (let ((loc (int-sap (- (sap-int ptr) offset))))
529 (cond ((= offset bytes-per-scrub-unit)
530 count)
531 ((zerop (kernel::get-lisp-obj-address (stack-ref loc 0)))
532 ; ((zerop (stack-ref loc 0))
533 (look ptr (+ offset vm:word-bytes) count))
534 (t
535 (scrub ptr offset (+ count vm:word-bytes)))))))
536 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
537 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
538 (declare (type (unsigned-byte 32) csp))
539 (scrub (int-sap (+ csp initial-offset))
540 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
541 0))))
542
543
544
545
546 ;;;; TOP-LEVEL loop.
547
548 (defvar / nil
549 "Holds a list of all the values returned by the most recent top-level EVAL.")
550 (defvar // nil "Gets the previous value of / when a new value is computed.")
551 (defvar /// nil "Gets the previous value of // when a new value is computed.")
552 (defvar * nil "Holds the value of the most recent top-level EVAL.")
553 (defvar ** nil "Gets the previous value of * when a new value is computed.")
554 (defvar *** nil "Gets the previous value of ** when a new value is computed.")
555 (defvar + nil "Holds the value of the most recent top-level READ.")
556 (defvar ++ nil "Gets the previous value of + when a new value is read.")
557 (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
558 (defvar - nil "Holds the form curently being evaluated.")
559 (defvar *prompt* "* "
560 "The top-level prompt string. This also may be a function of no arguments
561 that returns a simple-string.")
562 (defvar *in-top-level-catcher* nil
563 "True if we are within the Top-Level-Catcher. This is used by interrupt
564 handlers to see whether it is o.k. to throw.")
565
566 (defun interactive-eval (form)
567 "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
568 +, ///, //, /, and -."
569 (setf - form)
570 (let ((results (multiple-value-list (eval form))))
571 (setf /// //
572 // /
573 / results
574 *** **
575 ** *
576 * (car results)))
577 (setf +++ ++
578 ++ +
579 + -)
580 (unless (boundp '*)
581 ;; The bogon returned an unbound marker.
582 (setf * nil)
583 (cerror "Go on with * set to NIL."
584 "EVAL returned an unbound marker."))
585 (values-list /))
586
587
588 (defconstant eofs-before-quit 10)
589
590 (defun %top-level ()
591 "Top-level READ-EVAL-PRINT loop. Do not call this."
592 (let ((* nil) (** nil) (*** nil)
593 (- nil) (+ nil) (++ nil) (+++ nil)
594 (/// nil) (// nil) (/ nil)
595 (magic-eof-cookie (cons :eof nil))
596 (number-of-eofs 0))
597 (loop
598 (with-simple-restart (abort "Return to Top-Level.")
599 (catch 'top-level-catcher
600 (unix:unix-sigsetmask 0)
601 (let ((*in-top-level-catcher* t))
602 (loop
603 (scrub-control-stack)
604 (fresh-line)
605 (princ (if (functionp *prompt*)
606 (funcall *prompt*)
607 *prompt*))
608 (force-output)
609 (let ((form (read *standard-input* nil magic-eof-cookie)))
610 (cond ((not (eq form magic-eof-cookie))
611 (let ((results
612 (multiple-value-list (interactive-eval form))))
613 (dolist (result results)
614 (fresh-line)
615 (prin1 result)))
616 (setf number-of-eofs 0))
617 ((eql (incf number-of-eofs) 1)
618 (if *batch-mode*
619 (quit)
620 (let ((stream (make-synonym-stream '*terminal-io*)))
621 (setf *standard-input* stream)
622 (setf *standard-output* stream)
623 (format t "~&Received EOF on *standard-input*, ~
624 switching to *terminal-io*.~%"))))
625 ((> number-of-eofs eofs-before-quit)
626 (format t "~&Received more than ~D EOFs; Aborting.~%"
627 eofs-before-quit)
628 (quit))
629 (t
630 (format t "~&Received EOF.~%")))))))))))
631
632 (defun %handled-top-level ()
633 "Wrap %top-level read-eval-print loop in an error handler for *batch-mode*."
634 (handler-case
635 (progn
636 (%top-level)
637 (quit))
638 (error (cond)
639 (format *error-output* "Error in batch processing:~%~A" cond)
640 (throw '%end-of-the-world 1))))
641
642
643 ;;; %Halt -- Interface
644 ;;;
645 ;;; A convenient way to get into the assembly level debugger.
646 ;;;
647 (defun %halt ()
648 (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5