contrib/sb-aclrepl/toplevel.lisp

   1 (cl:defpackage :sb-aclrepl
   2   (:use "COMMON-LISP" "SB-EXT")
   3   (:shadowing-import-from "SB-IMPL" "SCRUB-CONTROL-STACK")
   4   (:shadowing-import-from "SB-INT" "*REPL-PROMPT-FUN*" "*REPL-READ-FORM-FUN*" "*STEP*" "*STEPPING*")
   5   (:export
   6    ;; user-level customization of UI
   7    "*PROMPT*" "*EXIT-ON-EOF*" "*MAX-HISTORY*"
   8    "*USE-SHORT-PACKAGE-NAME*" "*COMMAND-CHAR*"
   9    ;; user-level customization of functionality
  10    "ALIAS"
  11    ;; internalsish, but the documented way to make a new repl "object"
  12    ;; such that it inherits the current state of the repl but has its
  13    ;; own independent state subsequently.
  14    "MAKE-REPL-FUN"))
  15
  16 (cl:in-package :sb-aclrepl)
  17
  18 (defvar *noprint* nil
  19   "boolean: T if don't print prompt and output")
  20 (defvar *break-level* 0
  21   "current break level")
  22 (defvar *inspect-break* nil
  23   "boolean: T if break caused by inspect")
  24 (defvar *continuable-break* nil
  25   "boolean: T if break caused by continuable error")
  26
  27 (defun repl (&key
  28              (break-level (1+ *break-level*))
  29              (noprint *noprint*)
  30              (inspect nil)
  31              (continuable nil))
  32   (let ((*noprint* noprint)
  33         (*break-level* break-level)
  34         (*inspect-break* inspect)
  35         (*continuable-break* continuable))
  36     (sb-int:/show0 "entering REPL")
  37     (loop
  38      (multiple-value-bind (reason reason-param)
  39          (catch 'repl-catcher
  40            (loop
  41             (unwind-protect
  42                  (rep-one)
  43               ;; reset toplevel step-condition handler
  44               (setf *step* nil
  45                     *stepping* nil))))
  46        (declare (ignore reason-param))
  47        (cond
  48          ((and (eq reason :inspect)
  49                (plusp *break-level*))
  50           (return-from repl))
  51          ((and (eq reason :pop)
  52                (plusp *break-level*))
  53           (return-from repl)))))))
  54
  55 (defun rep-one ()
  56   "Read-Eval-Print one form"
  57   ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.)
  58   (scrub-control-stack)
  59   (unless *noprint*
  60     (funcall *repl-prompt-fun* *standard-output*)
  61     ;; (Should *REPL-PROMPT-FUN* be responsible for doing its own
  62     ;; FORCE-OUTPUT? I can't imagine a valid reason for it not to
  63     ;; be done here, so leaving it up to *REPL-PROMPT-FUN* seems
  64     ;; odd. But maybe there *is* a valid reason in some
  65     ;; circumstances? perhaps some deadlock issue when being driven
  66     ;; by another process or something...)
  67     (force-output *standard-output*))
  68   (let* ((form (funcall *repl-read-form-fun*
  69                         *standard-input*
  70                         *standard-output*))
  71          (results (multiple-value-list (sb-impl::interactive-eval form))))
  72     (unless *noprint*
  73       (dolist (result results)
  74         ;; FIXME: Calling fresh-line before a result ensures the result starts
  75         ;; on a newline, but it usually generates an empty line.
  76         ;; One solution would be to have the newline's entered on the
  77         ;; input stream inform the output stream that the column should be
  78         ;; reset to the beginning of the line.
  79         (fresh-line *standard-output*)
  80         (prin1 result *standard-output*)))))