contrib/sb-aclrepl/toplevel.lisp

   1 (cl:defpackage :sb-aclrepl
   2   (:use :cl :sb-ext))
   3
   4 (cl:in-package :sb-aclrepl)
   5
   6 (defvar *noprint* nil "boolean: T if don't print prompt and output")
   7 (defvar *break-level* 0 "current break level")
   8 (defvar *inspect-break* nil "boolean: T if break caused by inspect")
   9 (defvar *continuable-break* nil "boolean: T if break caused by continuable error")
  10
  11 (shadowing-import '(sb-impl::scrub-control-stack
  12                     sb-int:*repl-prompt-fun* sb-int:*repl-read-form-fun*)
  13                   :sb-aclrepl)
  14
  15
  16 (defun repl (&key
  17              (break-level (1+ *break-level*))
  18              (noprint *noprint*)
  19              (inspect nil)
  20              (continuable nil))
  21   (let ((*noprint* noprint)
  22         (*break-level* break-level)
  23         (*inspect-break* inspect)
  24         (*continuable-break* continuable)
  25         (*dir-stack* nil)
  26         (*history* nil)
  27         (*cmd-number* 1)
  28         (*package* *package*))
  29     (sb-int:/show0 "entering REPL")
  30     (loop
  31      (multiple-value-bind (reason reason-param)
  32          (catch 'repl-catcher
  33            (loop
  34             (rep-one)))
  35        (cond
  36          ((and (eq reason :inspect)
  37                (plusp *break-level*))
  38           (return-from repl))
  39          ((and (eq reason :pop)
  40                (plusp *break-level*))
  41           (return-from repl)))))))
  42
  43 (defun rep-one ()
  44   "Read-Eval-Print one form"
  45   ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.)
  46   (scrub-control-stack)
  47   (unless *noprint*
  48     (funcall *repl-prompt-fun* *standard-output*)
  49     ;; (Should *REPL-PROMPT-FUN* be responsible for doing its own
  50     ;; FORCE-OUTPUT? I can't imagine a valid reason for it not to
  51     ;; be done here, so leaving it up to *REPL-PROMPT-FUN* seems
  52     ;; odd. But maybe there *is* a valid reason in some
  53     ;; circumstances? perhaps some deadlock issue when being driven
  54     ;; by another process or something...)
  55     (force-output *standard-output*))
  56   (let* ((form (funcall *repl-read-form-fun*
  57                         *standard-input*
  58                         *standard-output*))
  59          (results (multiple-value-list (sb-impl::interactive-eval form))))
  60     (unless *noprint*
  61       (dolist (result results)
  62         ;; FIXME: Calling fresh-line before a result ensures the result starts
  63         ;; on a newline, but it usually generates an empty line.
  64         ;; One solution would be to have the newline's entered on the
  65         ;; input stream inform the output stream that the column should be
  66         ;; reset to the beginning of the line.
  67         (fresh-line *standard-output*)
  68         (prin1 result *standard-output*)))))
  69
  70 (defun repl-fun (noprint)
  71   (repl :noprint noprint :break-level 0))
  72
  73 (when (boundp 'sb-impl::*repl-fun*)
  74   (setq sb-impl::*repl-fun* #'repl-fun))