contrib/sb-aclrepl/toplevel.lisp

   1 ;;;; Toplevel for sb-aclrepl
   2
   3 (cl:defpackage :sb-aclrepl
   4   (:use :cl :sb-ext))
   5
   6 (cl:in-package :sb-aclrepl)
   7
   8 (defvar *break-level* 0 "Current break level")
   9 (defvar *inspect-reason* nil
  10   "Boolean if break level was started for inspecting.")
  11 (defvar *continuable-reason* nil
  12   "Boolean if break level was started by continuable error.")
  13 (defvar *noprint* nil "Boolean is output should be displayed")
  14 (defvar *input* nil "Input stream")
  15 (defvar *output* nil "Output stream")
  16
  17 (defun aclrepl (&key
  18                 (break-level (1+ *break-level*))
  19                 ;; Break level is started to inspect an object
  20                 inspect
  21                 ;; Signals a continuable error
  22                 continuable)
  23   (let ((*break-level* break-level)
  24         (*inspect-reason* inspect)
  25         (*continuable-reason* continuable))
  26     (loop
  27      ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.)
  28      (sb-impl::scrub-control-stack)
  29      (unless *noprint*
  30        (funcall (the function sb-int:*repl-prompt-fun*) *output*)
  31        (force-output *output*))
  32      (let* ((form (funcall (the function sb-int:*repl-read-form-fun*)
  33                            *input* *output*))
  34             (results (multiple-value-list (interactive-eval form))))
  35        (unless *noprint*
  36          (dolist (result results)
  37            (fresh-line *output*)
  38            (prin1 result *output*)))))))
  39
  40
  41 ;;; read-eval-print loop for the default system toplevel
  42 (defun toplevel-aclrepl-fun (noprint)
  43   (let ((* nil) (** nil) (*** nil)
  44         (- nil)
  45         (+ nil) (++ nil) (+++ nil)
  46         (/// nil) (// nil) (/ nil))
  47     ;; WITH-SIMPLE-RESTART doesn't actually restart its body as some
  48     ;; (like WHN for an embarrassingly long time ca. 2001-12-07) might
  49     ;; think, but instead drops control back out at the end. So when a
  50     ;; TOPLEVEL or outermost-ABORT restart happens, we need this outer
  51     ;; LOOP wrapper to grab control and start over again. (And it also
  52     ;; wraps CATCH 'TOPLEVEL-CATCHER for similar reasons.)
  53     (loop
  54      ;; There should only be one TOPLEVEL restart, and it's here, so
  55      ;; restarting at TOPLEVEL always bounces you all the way out here.
  56      (with-simple-restart (toplevel
  57                            "Restart at toplevel READ/EVAL/PRINT loop.")
  58        ;; We add a new ABORT restart for every debugger level, so
  59        ;; restarting at ABORT in a nested debugger gets you out to the
  60        ;; innermost enclosing debugger, and only when you're in the
  61        ;; outermost, unnested debugger level does restarting at ABORT
  62        ;; get you out to here.
  63        (with-simple-restart
  64            (abort
  65             "~@<Reduce debugger level (leaving debugger, returning to toplevel).~@:>")
  66          (catch 'toplevel-catcher
  67            #-sunos (sb-unix:unix-sigsetmask 0)  ; FIXME: What is this for?
  68            ;; in the event of a control-stack-exhausted-error, we should
  69            ;; have unwound enough stack by the time we get here that this
  70            ;; is now possible
  71            (sb-kernel::protect-control-stack-guard-page 1)
  72            (let ((*noprint* noprint)
  73                  (*input* *standard-input*)
  74                  (*output* *standard-output*))
  75              (aclrepl :break-level 0))
  76            (sb-impl::critically-unreachable "after REPL")))))))
  77
  78 #+ignore
  79 (when (boundp 'sb-impl::*toplevel-repl-fun*)
  80   (setq sb-impl::*toplevel-repl-fun* #'toplevel-aclrepl-fun))