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     (sb-int:/show0 "entering REPL")
  26     (loop
  27      (multiple-value-bind (reason reason-param)
  28          (catch 'repl-catcher
  29            (loop
  30             (rep-one)))
  31        (cond
  32          ((and (eq reason :inspect)
  33                (plusp *break-level*))
  34           (return-from repl))
  35          ((and (eq reason :pop)
  36                (plusp *break-level*))
  37           (return-from repl)))))))
  38
  39 (defun rep-one ()
  40   "Read-Eval-Print one form"
  41   ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.)
  42   (scrub-control-stack)
  43   (unless *noprint*
  44     (funcall *repl-prompt-fun* *standard-output*)
  45     ;; (Should *REPL-PROMPT-FUN* be responsible for doing its own
  46     ;; FORCE-OUTPUT? I can't imagine a valid reason for it not to
  47     ;; be done here, so leaving it up to *REPL-PROMPT-FUN* seems
  48     ;; odd. But maybe there *is* a valid reason in some
  49     ;; circumstances? perhaps some deadlock issue when being driven
  50     ;; by another process or something...)
  51     (force-output *standard-output*))
  52   (let* ((form (funcall *repl-read-form-fun*
  53                         *standard-input*
  54                         *standard-output*))
  55          (results (multiple-value-list (sb-impl::interactive-eval form))))
  56     (unless *noprint*
  57       (dolist (result results)
  58         ;; FIXME: Calling fresh-line before a result ensures the result starts
  59         ;; on a newline, but it usually generates an empty line.
  60         ;; One solution would be to have the newline's entered on the
  61         ;; input stream inform the output stream that the column should be
  62         ;; reset to the beginning of the line.
  63         (fresh-line *standard-output*)
  64         (prin1 result *standard-output*)))))
  65
  66 (defun repl-fun (noprint)
  67   (repl :noprint noprint :break-level 0))
  68
  69 (when (boundp 'sb-impl::*repl-fun*)
  70   (setq sb-impl::*repl-fun* #'repl-fun))