src/code/toplevel.lisp

   1 ;;;; stuff related to the toplevel read-eval-print loop, plus some
   2 ;;;; other miscellaneous functions that we don't have any better place
   3 ;;;; for
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; This software is derived from the CMU CL system, which was
   9 ;;;; written at Carnegie Mellon University and released into the
  10 ;;;; public domain. The software is in the public domain and is
  11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  12 ;;;; files for more information.
  13
  14 (in-package "SB!IMPL")
  15 \f
  16 (defconstant most-positive-fixnum #.sb!vm:*target-most-positive-fixnum*
  17   #!+sb-doc
  18   "the fixnum closest in value to positive infinity")
  19
  20 (defconstant most-negative-fixnum #.sb!vm:*target-most-negative-fixnum*
  21   #!+sb-doc
  22   "the fixnum closest in value to negative infinity")
  23 \f
  24 ;;;; magic specials initialized by GENESIS
  25
  26 ;;; FIXME: The DEFVAR here is redundant with the (DECLAIM (SPECIAL ..))
  27 ;;; of all static symbols in early-impl.lisp.
  28 #!-gengc
  29 (progn
  30   (defvar *current-catch-block*)
  31   (defvar *current-unwind-protect-block*)
  32   (defvar *free-interrupt-context-index*))
  33 \f
  34 ;;; specials initialized by !COLD-INIT
  35
  36 ;;; FIXME: These could be converted to DEFVARs, and the stuff shared
  37 ;;; in both #!+GENGC and #!-GENGC (actually everything in #!+GENGC)
  38 ;;; could be made non-conditional.
  39 (declaim
  40   #!-gengc
  41   (special *gc-inhibit* *already-maybe-gcing*
  42            *need-to-collect-garbage*
  43            *gc-notify-stream*
  44            *before-gc-hooks* *after-gc-hooks*
  45            #!+x86 *pseudo-atomic-atomic*
  46            #!+x86 *pseudo-atomic-interrupted*
  47            sb!unix::*interrupts-enabled*
  48            sb!unix::*interrupt-pending*
  49            *type-system-initialized*)
  50   #!+gengc
  51   (special *before-gc-hooks* *after-gc-hooks*
  52            *gc-notify-stream*
  53            *type-system-initialized*))
  54
  55 (defvar *cold-init-complete-p*)
  56
  57 ;;; counts of nested errors (with internal errors double-counted)
  58 (defvar *maximum-error-depth*)
  59 (defvar *current-error-depth*)
  60 \f
  61 ;;;; miscellaneous utilities for working with with TOPLEVEL
  62
  63 ;;; Execute BODY in a context where any %END-OF-THE-WORLD (thrown e.g.
  64 ;;; by QUIT) is caught and any final processing and return codes are
  65 ;;; handled appropriately.
  66 (defmacro handling-end-of-the-world (&body body)
  67   (let ((caught (gensym "CAUGHT")))
  68     `(let ((,caught (catch '%end-of-the-world
  69                       (/show0 "inside CATCH '%END-OF-THE-WORLD")
  70                       ,@body)))
  71        (/show0 "back from CATCH '%END-OF-THE-WORLD, flushing output")
  72        (flush-standard-output-streams)
  73        (/show0 "calling UNIX-EXIT")
  74        (sb!unix:unix-exit ,caught))))
  75 \f
  76 ;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH*
  77
  78 ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out
  79 ;;; of hyperspace.
  80 (defmacro infinite-error-protect (&rest forms)
  81   `(unless (infinite-error-protector)
  82      (/show0 "back from INFINITE-ERROR-PROTECTOR")
  83      (let ((*current-error-depth* (1+ *current-error-depth*)))
  84        (/show0 "in INFINITE-ERROR-PROTECT, incremented error depth")
  85        #+sb-show (sb-debug:backtrace)
  86        ,@forms)))
  87
  88 ;;; a helper function for INFINITE-ERROR-PROTECT
  89 (defun infinite-error-protector ()
  90   (/show0 "entering INFINITE-ERROR-PROTECTOR, *CURRENT-ERROR-DEPTH*=..")
  91   (/hexstr *current-error-depth*)
  92   (cond ((not *cold-init-complete-p*)
  93          (%primitive print "Argh! error in cold init, halting")
  94          (%primitive sb!c:halt))
  95         ((or (not (boundp '*current-error-depth*))
  96              (not (realp   *current-error-depth*))
  97              (not (boundp '*maximum-error-depth*))
  98              (not (realp   *maximum-error-depth*)))
  99          (%primitive print "Argh! corrupted error depth, halting")
 100          (%primitive sb!c:halt))
 101         ((> *current-error-depth* *maximum-error-depth*)
 102          (/show0 "*MAXIMUM-ERROR-DEPTH*=..")
 103          (/hexstr *maximum-error-depth*)
 104          (/show0 "in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR")
 105          (error-error "Help! "
 106                       *current-error-depth*
 107                       " nested errors. "
 108                       "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
 109          t)
 110         (t
 111          (/show0 "returning normally from INFINITE-ERROR-PROTECTOR")
 112          nil)))
 113
 114 ;;; FIXME: I had a badly broken version of INFINITE-ERROR-PROTECTOR at
 115 ;;; one point (shown below), and SBCL cross-compiled it without
 116 ;;; warning about FORMS being undefined. Check whether that problem
 117 ;;; (missing warning) is repeatable in the final system and if so, fix
 118 ;;; it.
 119 #|
 120 (defun infinite-error-protector ()
 121   `(cond ((not *cold-init-complete-p*)
 122           (%primitive print "Argh! error in cold init, halting")
 123           (%primitive sb!c:halt))
 124          ((or (not (boundp '*current-error-depth*))
 125               (not (realp   *current-error-depth*))
 126               (not (boundp '*maximum-error-depth*))
 127               (not (realp   *maximum-error-depth*)))
 128           (%primitive print "Argh! corrupted error depth, halting")
 129           (%primitive sb!c:halt))
 130          ((> *current-error-depth* *maximum-error-depth*)
 131           (/show0 "in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR")
 132           (error-error "Help! "
 133                        *current-error-depth*
 134                        " nested errors. "
 135                        "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
 136           (progn ,@forms)
 137           t)
 138          (t
 139           (/show0 "in INFINITE-ERROR-PROTECTOR, returning normally")
 140           nil)))
 141 |#
 142 \f
 143 ;;;; miscellaneous external functions
 144
 145 #!-mp ; The multi-processing version is defined in multi-proc.lisp.
 146 (defun sleep (n)
 147   #!+sb-doc
 148   "This function causes execution to be suspended for N seconds. N may
 149   be any non-negative, non-complex number."
 150   (when (or (not (realp n))
 151             (minusp n))
 152     (error "Invalid argument to SLEEP: ~S.~%~
 153             Must be a non-negative, non-complex number."
 154            n))
 155   (multiple-value-bind (sec usec)
 156       (if (integerp n)
 157           (values n 0)
 158           (multiple-value-bind (sec frac)
 159               (truncate n)
 160             (values sec(truncate frac 1e-6))))
 161     (sb!unix:unix-select 0 0 0 0 sec usec))
 162   nil)
 163 \f
 164 ;;;; SCRUB-CONTROL-STACK
 165
 166 (defconstant bytes-per-scrub-unit 2048)
 167
 168 ;;; Zero the unused portion of the control stack so that old objects
 169 ;;; are not kept alive because of uninitialized stack variables.
 170 ;;;
 171 ;;; FIXME: Why do we need to do this instead of just letting GC read
 172 ;;; the stack pointer and avoid messing with the unused portion of
 173 ;;; the control stack? (Is this a multithreading thing where there's
 174 ;;; one control stack and stack pointer per thread, and it might not
 175 ;;; be easy to tell what a thread's stack pointer value is when
 176 ;;; looking in from another thread?)
 177 (defun scrub-control-stack ()
 178   (declare (optimize (speed 3) (safety 0))
 179            (values (unsigned-byte 20))) ; FIXME: DECLARE VALUES?
 180
 181   #!-x86 ; machines where stack grows upwards (I guess) -- WHN 19990906
 182   (labels
 183       ((scrub (ptr offset count)
 184          (declare (type system-area-pointer ptr)
 185                   (type (unsigned-byte 16) offset)
 186                   (type (unsigned-byte 20) count)
 187                   (values (unsigned-byte 20)))
 188          (cond ((= offset bytes-per-scrub-unit)
 189                 (look (sap+ ptr bytes-per-scrub-unit) 0 count))
 190                (t
 191                 (setf (sap-ref-32 ptr offset) 0)
 192                 (scrub ptr (+ offset sb!vm:word-bytes) count))))
 193        (look (ptr offset count)
 194          (declare (type system-area-pointer ptr)
 195                   (type (unsigned-byte 16) offset)
 196                   (type (unsigned-byte 20) count)
 197                   (values (unsigned-byte 20)))
 198          (cond ((= offset bytes-per-scrub-unit)
 199                 count)
 200                ((zerop (sap-ref-32 ptr offset))
 201                 (look ptr (+ offset sb!vm:word-bytes) count))
 202                (t
 203                 (scrub ptr offset (+ count sb!vm:word-bytes))))))
 204     (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
 205            (initial-offset (logand csp (1- bytes-per-scrub-unit))))
 206       (declare (type (unsigned-byte 32) csp))
 207       (scrub (int-sap (- csp initial-offset))
 208              (* (floor initial-offset sb!vm:word-bytes) sb!vm:word-bytes)
 209              0)))
 210
 211   #!+x86 ;; (Stack grows downwards.)
 212   (labels
 213       ((scrub (ptr offset count)
 214          (declare (type system-area-pointer ptr)
 215                   (type (unsigned-byte 16) offset)
 216                   (type (unsigned-byte 20) count)
 217                   (values (unsigned-byte 20)))
 218          (let ((loc (int-sap (- (sap-int ptr) (+ offset sb!vm:word-bytes)))))
 219            (cond ((= offset bytes-per-scrub-unit)
 220                   (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit))
 221                         0 count))
 222                  (t ;; need to fix bug in %SET-STACK-REF
 223                   (setf (sap-ref-32 loc 0) 0)
 224                   (scrub ptr (+ offset sb!vm:word-bytes) count)))))
 225        (look (ptr offset count)
 226          (declare (type system-area-pointer ptr)
 227                   (type (unsigned-byte 16) offset)
 228                   (type (unsigned-byte 20) count)
 229                   (values (unsigned-byte 20)))
 230          (let ((loc (int-sap (- (sap-int ptr) offset))))
 231            (cond ((= offset bytes-per-scrub-unit)
 232                   count)
 233                  ((zerop (sb!kernel::get-lisp-obj-address (stack-ref loc 0)))
 234                   (look ptr (+ offset sb!vm:word-bytes) count))
 235                  (t
 236                   (scrub ptr offset (+ count sb!vm:word-bytes)))))))
 237     (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
 238            (initial-offset (logand csp (1- bytes-per-scrub-unit))))
 239       (declare (type (unsigned-byte 32) csp))
 240       (scrub (int-sap (+ csp initial-offset))
 241              (* (floor initial-offset sb!vm:word-bytes) sb!vm:word-bytes)
 242              0))))
 243 \f
 244 ;;;; the default toplevel function
 245
 246 ;;; FIXME: Most stuff below here can probably be byte-compiled.
 247
 248 (defvar / nil
 249   #!+sb-doc
 250   "a list of all the values returned by the most recent top-level EVAL")
 251 (defvar //  nil #!+sb-doc "the previous value of /")
 252 (defvar /// nil #!+sb-doc "the previous value of //")
 253 (defvar *   nil #!+sb-doc "the value of the most recent top-level EVAL")
 254 (defvar **  nil #!+sb-doc "the previous value of *")
 255 (defvar *** nil #!+sb-doc "the previous value of **")
 256 (defvar +   nil #!+sb-doc "the value of the most recent top-level READ")
 257 (defvar ++  nil #!+sb-doc "the previous value of +")
 258 (defvar +++ nil #!+sb-doc "the previous value of ++")
 259 (defvar -   nil #!+sb-doc "the form currently being evaluated")
 260 (defvar *prompt* "* "
 261   #!+sb-doc
 262   "The top-level prompt string. This also may be a function of no arguments
 263    that returns a simple-string.")
 264
 265 (defun interactive-eval (form)
 266   "Evaluate FORM, returning whatever it returns and adjusting ***, **, *,
 267    +++, ++, +, ///, //, /, and -."
 268   (setf - form)
 269   (let ((results (multiple-value-list (eval form))))
 270     (setf /// //
 271           // /
 272           / results
 273           *** **
 274           ** *
 275           * (car results)))
 276   (setf +++ ++
 277         ++ +
 278         + -)
 279   (unless (boundp '*)
 280     ;; The bogon returned an unbound marker.
 281     ;; FIXME: It would be safer to check every one of the values in RESULTS,
 282     ;; instead of just the first one.
 283     (setf * nil)
 284     (cerror "Go on with * set to NIL."
 285             "EVAL returned an unbound marker."))
 286   (values-list /))
 287
 288 ;;; Flush anything waiting on one of the ANSI Common Lisp standard
 289 ;;; output streams before proceeding.
 290 (defun flush-standard-output-streams ()
 291   (dolist (name '(*debug-io*
 292                   *error-output*
 293                   *query-io*
 294                   *standard-output*
 295                   *trace-output*))
 296     (finish-output (symbol-value name)))
 297   (values))
 298
 299 ;;; the default system top-level function
 300 (defun toplevel-init ()
 301
 302   (/show0 "entering TOPLEVEL-INIT")
 303
 304   (let ((sysinit nil)        ; value of --sysinit option
 305         (userinit nil)       ; value of --userinit option
 306         (reversed-evals nil) ; values of --eval options, in reverse order
 307         (noprint nil)        ; Has a --noprint option been seen?
 308         (noprogrammer nil)   ; Has a --noprogammer option been seen?
 309         (options (rest *posix-argv*))) ; skipping program name
 310
 311     (/show0 "done with outer LET in TOPLEVEL-INIT")
 312
 313     ;; FIXME: There are lots of ways for errors to happen around here
 314     ;; (e.g. bad command line syntax, or READ-ERROR while trying to
 315     ;; READ an --eval string). Make sure that they're handled
 316     ;; reasonably. Also, perhaps all errors while parsing the command
 317     ;; line should cause the system to QUIT, instead of trying to go
 318     ;; into the Lisp debugger.
 319
 320     ;; Parse command line options.
 321     (loop while options do
 322           (/show0 "at head of LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")
 323           (let ((option (first options)))
 324             (flet ((pop-option ()
 325                      (if options
 326                          (pop options)
 327                          (error "unexpected end of command line options"))))
 328               (cond ((string= option "--sysinit")
 329                      (pop-option)
 330                      (if sysinit
 331                          (error "multiple --sysinit options")
 332                          (setf sysinit (pop-option))))
 333                     ((string= option "--userinit")
 334                      (pop-option)
 335                      (if userinit
 336                          (error "multiple --userinit options")
 337                          (setf userinit (pop-option))))
 338                     ((string= option "--eval")
 339                      (pop-option)
 340                      (let ((eval-as-string (pop-option)))
 341                        (with-input-from-string (eval-stream eval-as-string)
 342                          (let* ((eof-marker (cons :eof :eof))
 343                                 (eval (read eval-stream nil eof-marker))
 344                                 (eof (read eval-stream nil eof-marker)))
 345                            (cond ((eq eval eof-marker)
 346                                   (error "unable to parse ~S"
 347                                          eval-as-string))
 348                                  ((not (eq eof eof-marker))
 349                                   (error "more than one expression in ~S"
 350                                          eval-as-string))
 351                                  (t
 352                                   (push eval reversed-evals)))))))
 353                     ((string= option "--noprint")
 354                      (pop-option)
 355                      (setf noprint t))
 356                     ((string= option "--noprogrammer")
 357                      (pop-option)
 358                      (setf noprogrammer t))
 359                     ((string= option "--end-toplevel-options")
 360                      (pop-option)
 361                      (return))
 362                     (t
 363                      ;; Anything we don't recognize as a toplevel
 364                      ;; option must be the start of user-level
 365                      ;; options.. except that if we encounter
 366                      ;; "--end-toplevel-options" after we gave up
 367                      ;; because we didn't recognize an option as a
 368                      ;; toplevel option, then the option we gave up on
 369                      ;; must have been an error. (E.g. in
 370                      ;;  "sbcl --eval '(a)' --eval'(b)' --end-toplevel-options"
 371                      ;; this test will let us detect that the string
 372                      ;; "--eval(b)" is an error.)
 373                      (if (find "--end-toplevel-options" options
 374                                :test #'string=)
 375                          (error "bad toplevel option: ~S" (first options))
 376                          (return)))))))
 377     (/show0 "done with LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")
 378
 379     ;; Excise all the options that we processed, so that only
 380     ;; user-level options are left visible to user code.
 381     (setf (rest *posix-argv*) options)
 382
 383     ;; Handle --noprogrammer option. We intentionally do this
 384     ;; early so that it will affect the handling of initialization
 385     ;; files and --eval options.
 386     (/show0 "handling --noprogrammer option in TOPLEVEL-INIT")
 387     (when noprogrammer
 388       (setf *debugger-hook* 'noprogrammer-debugger-hook-fun
 389             *debug-io* *error-output*))
 390
 391     ;; FIXME: Verify that errors in init files and/or --eval operations
 392     ;; lead to reasonable behavior.
 393
 394     ;; Handle initialization files.
 395     (/show0 "handling initialization files in TOPLEVEL-INIT")
 396     (flet (;; If any of POSSIBLE-INIT-FILE-NAMES names a real file,
 397            ;; return its truename.
 398            (probe-init-files (&rest possible-init-file-names)
 399              (/show0 "entering PROBE-INIT-FILES")
 400              (prog1
 401                  (find-if (lambda (x)
 402                             (and (stringp x) (probe-file x)))
 403                           possible-init-file-names)
 404                (/show0 "leaving PROBE-INIT-FILES"))))
 405       (let* ((sbcl-home (posix-getenv "SBCL_HOME"))
 406              (sysinit-truename (if sbcl-home
 407                                    (probe-init-files sysinit
 408                                                      (concatenate
 409                                                       'string
 410                                                       sbcl-home
 411                                                       "/sbclrc"))
 412                                    (probe-init-files sysinit
 413                                                      "/etc/sbclrc"
 414                                                      "/usr/local/etc/sbclrc")))
 415              (user-home (or (posix-getenv "HOME")
 416                             (error "The HOME environment variable is unbound, ~
 417                                     so user init file can't be found.")))
 418              (userinit-truename (probe-init-files userinit
 419                                                   (concatenate
 420                                                    'string
 421                                                    user-home
 422                                                    "/.sbclrc"))))
 423         (/show0 "assigned SYSINIT-TRUENAME and USERINIT-TRUENAME")
 424
 425
 426         ;; We wrap all the pre-REPL user/system customized startup code
 427         ;; in a restart.
 428         ;;
 429         ;; (Why not wrap everything, even the stuff above, in this
 430         ;; restart? Errors above here are basically command line or
 431         ;; Unix environment errors, e.g. a missing file or a typo on
 432         ;; the Unix command line, and you don't need to get into Lisp
 433         ;; to debug them, you should just start over and do it right
 434         ;; at the Unix level. Errors below here are usually errors in
 435         ;; user Lisp code, and it might be helpful to let the user
 436         ;; reach the REPL in order to help figure out what's going on.)
 437         (restart-case
 438             (flet ((process-init-file (truename)
 439                      (when truename
 440                        (unless (load truename)
 441                          (error "~S was not successfully loaded." truename))
 442                        (flush-standard-output-streams))))
 443               (process-init-file sysinit-truename)
 444               (process-init-file userinit-truename)
 445
 446               ;; Process --eval options.
 447               (/show0 "handling --eval options in TOPLEVEL-INIT")
 448               (dolist (eval (reverse reversed-evals))
 449                 (/show0 "handling one --eval option in TOPLEVEL-INIT")
 450                 (eval eval)
 451                 (flush-standard-output-streams)))
 452           (continue ()
 453                     :report "Continue anyway (skipping to toplevel read/eval/print loop)."
 454                     (values)) ; (no-op, just fall through)
 455           (quit ()
 456                 :report "Quit SBCL (calling #'QUIT, killing the process)."
 457                 (quit))))
 458
 459       ;; one more time for good measure, in case we fell out of the
 460       ;; RESTART-CASE above before one of the flushes in the ordinary
 461       ;; flow of control had a chance to operate
 462       (flush-standard-output-streams)
 463
 464       (/show0 "falling into TOPLEVEL-REPL from TOPLEVEL-INIT")
 465       (toplevel-repl noprint))))
 466
 467 ;;; read-eval-print loop for the default system toplevel
 468 (defun toplevel-repl (noprint)
 469   (/show0 "entering TOPLEVEL-REPL")
 470   (let ((* nil) (** nil) (*** nil)
 471         (- nil)
 472         (+ nil) (++ nil) (+++ nil)
 473         (/// nil) (// nil) (/ nil)
 474         (eof-marker (cons :eof nil)))
 475     (loop
 476       (/show0 "at head of outer LOOP in TOPLEVEL-REPL")
 477       ;; There should only be one TOPLEVEL restart, and it's here, so
 478       ;; restarting at TOPLEVEL always bounces you all the way out here.
 479       (with-simple-restart (toplevel
 480                             "Restart at toplevel READ/EVAL/PRINT loop.")
 481         ;; We add a new ABORT restart for every debugger level, so
 482         ;; restarting at ABORT in a nested debugger gets you out to the
 483         ;; innermost enclosing debugger, and only when you're in the
 484         ;; outermost, unnested debugger level does restarting at ABORT
 485         ;; get you out to here.
 486         (with-simple-restart (abort
 487                               "Reduce debugger level (leaving debugger).")
 488           (catch 'top-level-catcher
 489           (sb!unix:unix-sigsetmask 0)   ; FIXME: What is this for?
 490           (/show0 "about to enter inner LOOP in TOPLEVEL-REPL")
 491           (loop                         ; FIXME: Do we need this inner LOOP?
 492            ;; FIXME: It seems bad to have GC behavior depend on scrubbing
 493            ;; the control stack before each interactive command. Isn't
 494            ;; there some way we can convince the GC to just ignore
 495            ;; dead areas of the control stack, so that we don't need to
 496            ;; rely on this half-measure?
 497            (scrub-control-stack)
 498            (unless noprint
 499              (fresh-line)
 500              (princ (if (functionp *prompt*)
 501                         (funcall *prompt*)
 502                         *prompt*))
 503              (flush-standard-output-streams))
 504            (let ((form (read *standard-input* nil eof-marker)))
 505              (if (eq form eof-marker)
 506                  (quit)
 507                  (let ((results
 508                         (multiple-value-list (interactive-eval form))))
 509                    (unless noprint
 510                      (dolist (result results)
 511                        (fresh-line)
 512                        (prin1 result)))))))))))))
 513
 514 (defun noprogrammer-debugger-hook-fun (condition old-debugger-hook)
 515   (declare (ignore old-debugger-hook))
 516   (flet ((failure-quit (&key recklessly-p)
 517            (quit :unix-status 1 :recklessly-p recklessly-p)))
 518     ;; This HANDLER-CASE is here mostly to stop output immediately
 519     ;; (and fall through to QUIT) when there's an I/O error. Thus,
 520     ;; when we're run under a shell script or something, we can die
 521     ;; cleanly when the script dies (and our pipes are cut), instead
 522     ;; of falling into ldb or something messy like that.
 523     (handler-case
 524         (progn
 525           (format *error-output*
 526                   "~@<unhandled condition (of type ~S): ~2I~_~A~:>~2%"
 527                   (type-of condition)
 528                   condition)
 529           ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that
 530           ;; even if we hit an error within BACKTRACE we'll at least
 531           ;; have the CONDITION printed out before we die.
 532           (finish-output *error-output*)
 533           ;; (Where to truncate the BACKTRACE is of course arbitrary, but
 534           ;; it seems as though we should at least truncate it somewhere.)
 535           (sb!debug:backtrace 128 *error-output*)
 536           (format *error-output*
 537                   "~%unhandled condition in --noprogrammer mode, quitting~%")
 538           (finish-output *error-output*)
 539           (failure-quit))
 540       (condition ()
 541         ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can
 542         ;; fail when our output streams are blown away, as e.g. when
 543         ;; we're running under a Unix shell script and it dies somehow
 544         ;; (e.g. because of a SIGINT). In that case, we might as well
 545         ;; just give it up for a bad job, and stop trying to notify
 546         ;; the user of anything.
 547         ;;
 548         ;; Actually, the only way I've run across to exercise the
 549         ;; problem is to have more than one layer of shell script.
 550         ;; I have a shell script which does
 551         ;;   time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp
 552         ;; and the problem occurs when I interrupt this with Ctrl-C
 553         ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1).
 554         ;; I haven't figured out whether it's bash, time, tee, Linux, or
 555         ;; what that is responsible, but that it's possible at all
 556         ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24
 557         (ignore-errors
 558          (%primitive print "Argh! error within --noprogrammer error handling"))
 559         (failure-quit :recklessly-p t)))))
 560 \f
 561 ;;; a convenient way to get into the assembly-level debugger
 562 (defun %halt ()
 563   (%primitive sb!c:halt))