1.0.23.50: Less magic constants in the MIPS backend.
[sbcl.git] / 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*")
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               ;; if we started stepping in the debugger, now is the
44               ;; time to stop
45               (sb-impl::disable-stepping))))
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*)))))