to the "max args" entry point. (reported by Brian Downing)
* tweaked disassembly notes to be less confident about proclaiming
some instruction as an LRA. (thanks to Brian Downing)
+ * contrib update: SB-ACLREPL is now threadsafe; multiple listeners
+ now each have their own history, command character, and other
+ characteristics. (thanks to David Lichteblau)
* fixed some bugs revealed by Paul Dietz' test suite:
** compiler failure in compiling LOGAND expressions including a
constant 0.
(defun inspector-fun (object input-stream output-stream)
- (declare (ignore input-stream))
(let ((*current-inspect* nil)
(*inspect-raw* nil)
(*inspect-length* *inspect-length*)
(declaim (type list *history*))
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(*prompt* *exit-on-eof* *max-history*
- *use-short-package-name* *command-char*
- alias)))
-
(defvar *eof-marker* :eof)
(defvar *eof-cmd* (make-user-cmd :func :eof))
(defvar *null-cmd* (make-user-cmd :func :null-cmd))
(defparameter *cmd-table-hash*
(make-hash-table :size 30 :test #'equal))
-;; Set up binding for multithreading
-
-(let ((*prompt* #.*default-prompt*)
- (*use-short-package-name* t)
- (*dir-stack* nil)
- (*command-char* #\:)
- (*max-history* 100)
- (*exit-on-eof* t)
- (*history* nil)
- (*cmd-number* 1)
- )
-
(defun prompt-package-name ()
(if *use-short-package-name*
(car (sort (append
(values))
(defun reset-cmd ()
- ;; The last restart goes to the toplevel
- (invoke-restart-interactively (car (last (compute-restarts)))))
+ (invoke-restart-interactively (find-restart 'sb-impl::toplevel)))
(defun dirs-cmd ()
(dolist (dir *dir-stack*)
(setf sb-int:*repl-prompt-fun* #'repl-prompt-fun
sb-int:*repl-read-form-fun* #'repl-read-form-fun)
-) ;; close special variables bindings
-
+(defmacro with-new-repl-state ((&rest vars) &body forms)
+ (let ((gvars (mapcar (lambda (var) (gensym (symbol-name var))) vars)))
+ `(let (,@(mapcar (lambda (var gvar) `(,gvar ,var)) vars gvars))
+ (lambda (noprint)
+ (let ((*noprint* noprint))
+ (let (,@(mapcar (lambda (var gvar) `(,var ,gvar)) vars gvars))
+ (unwind-protect
+ (progn ,@forms)
+ ,@(mapcar (lambda (var gvar) `(setf ,gvar ,var))
+ vars gvars))))))))
+
+(defun make-repl-fun ()
+ (with-new-repl-state (*break-level* *inspect-break* *continuable-break*
+ *dir-stack* *command-char* *prompt*
+ *use-short-package-name* *max-history* *exit-on-eof*
+ *history* *cmd-number*)
+ (repl :noprint noprint :break-level 0)))
+
+(when (boundp 'sb-impl::*repl-fun-generator*)
+ (setq sb-impl::*repl-fun-generator* #'make-repl-fun))
(cl:defpackage :sb-aclrepl
- (:use :cl :sb-ext))
+ (:use "COMMON-LISP" "SB-EXT")
+ (:shadowing-import-from "SB-IMPL" "SCRUB-CONTROL-STACK")
+ (:shadowing-import-from "SB-INT" "*REPL-PROMPT-FUN*" "*REPL-READ-FORM-FUN*")
+ (:export
+ ;; user-level customization of UI
+ "*PROMPT*" "*EXIT-ON-EOF*" "*MAX-HISTORY*"
+ "*USE-SHORT-PACKAGE-NAME*" "*COMMAND-CHAR*"
+ ;; user-level customization of functionality
+ "ALIAS"
+ ;; internalsish, but the documented way to make a new repl "object"
+ ;; such that it inherits the current state of the repl but has its
+ ;; own independent state subsequently.
+ "MAKE-REPL-FUN"))
(cl:in-package :sb-aclrepl)
-(defvar *noprint* nil "boolean: T if don't print prompt and output")
-(defvar *break-level* 0 "current break level")
-(defvar *inspect-break* nil "boolean: T if break caused by inspect")
-(defvar *continuable-break* nil "boolean: T if break caused by continuable error")
-
-(shadowing-import '(sb-impl::scrub-control-stack
- sb-int:*repl-prompt-fun* sb-int:*repl-read-form-fun*)
- :sb-aclrepl)
-
+(defvar *noprint* nil
+ "boolean: T if don't print prompt and output")
+(defvar *break-level* 0
+ "current break level")
+(defvar *inspect-break* nil
+ "boolean: T if break caused by inspect")
+(defvar *continuable-break* nil
+ "boolean: T if break caused by continuable error")
(defun repl (&key
(break-level (1+ *break-level*))
(catch 'repl-catcher
(loop
(rep-one)))
+ (declare (ignore reason-param))
(cond
((and (eq reason :inspect)
(plusp *break-level*))
;; reset to the beginning of the line.
(fresh-line *standard-output*)
(prin1 result *standard-output*)))))
-
-(defun repl-fun (noprint)
- (repl :noprint noprint :break-level 0))
-
-(when (boundp 'sb-impl::*repl-fun*)
- (setq sb-impl::*repl-fun* #'repl-fun))
"AWHEN" "ACOND" "IT"
"BINDING*"
"!DEF-BOOLEAN-ATTRIBUTE"
+ "WITH-REBOUND-IO-SYNTAX"
;; ..and CONDITIONs..
"BUG"
"UNSUPPORTED-OPERATOR"
- "BOOTSTRAP-PACKAGE-NOT-FOUND"
- "BOOTSTRAP-PACKAGE-NAME" "DEBOOTSTRAP-PACKAGE"
;; ..and DEFTYPEs..
"INDEX" "LOAD/STORE-INDEX"
(defun promise-ready-p (promise)
(or (not (consp promise))
(car promise)))
+\f
+;;; toplevel helper
+(defmacro with-rebound-io-syntax (&body body)
+ `(%with-rebound-io-syntax (lambda () ,@body)))
+
+(defun %with-rebound-io-syntax (function)
+ (declare (type function function))
+ (let ((*package* *package*)
+ (*print-array* *print-array*)
+ (*print-base* *print-base*)
+ (*print-case* *print-case*)
+ (*print-circle* *print-circle*)
+ (*print-escape* *print-escape*)
+ (*print-gensym* *print-gensym*)
+ (*print-length* *print-length*)
+ (*print-level* *print-level*)
+ (*print-lines* *print-lines*)
+ (*print-miser-width* *print-miser-width*)
+ (*print-pretty* *print-pretty*)
+ (*print-radix* *print-radix*)
+ (*print-readably* *print-readably*)
+ (*print-right-margin* *print-right-margin*)
+ (*read-base* *read-base*)
+ (*read-default-float-format* *read-default-float-format*)
+ (*read-eval* *read-eval*)
+ (*read-suppress* *read-suppress*)
+ (*readtable* *readtable*))
+ (funcall function)))
;; (classic CMU CL error message: "You're certainly a clever child.":-)
(critically-unreachable "after TOPLEVEL-REPL"))))
+;;; hooks to support customized toplevels like ACL-style toplevel from
+;;; KMR on sbcl-devel 2002-12-21. Altered by CSR 2003-11-16 for
+;;; threaded operation: altered *REPL-FUN* to *REPL-FUN-GENERATOR*.
+(defvar *repl-read-form-fun* #'repl-read-form-fun
+ "a function of two stream arguments IN and OUT for the toplevel REPL to
+ call: Return the next Lisp form to evaluate (possibly handling other
+ magic -- like ACL-style keyword commands -- which precede the next
+ Lisp form). The OUT stream is there to support magic which requires
+ issuing new prompts.")
+(defvar *repl-prompt-fun* #'repl-prompt-fun
+ "a function of one argument STREAM for the toplevel REPL to call: Prompt
+ the user for input.")
+(defvar *repl-fun-generator* (constantly #'repl-fun)
+ "a function of no arguments returning a function of one argument
+ NOPRINT that provides the REPL for the system. Assumes that
+ *STANDARD-INPUT* and *STANDARD-OUTPUT* are set up.")
+
;;; read-eval-print loop for the default system toplevel
(defun toplevel-repl (noprint)
(/show0 "entering TOPLEVEL-REPL")
(- nil)
(+ nil) (++ nil) (+++ nil)
(/// nil) (// nil) (/ nil))
- ;; WITH-SIMPLE-RESTART doesn't actually restart its body as some
- ;; (like WHN for an embarrassingly long time ca. 2001-12-07) might
- ;; think, but instead drops control back out at the end. So when a
- ;; TOPLEVEL or outermost-ABORT restart happens, we need this outer
- ;; LOOP wrapper to grab control and start over again. (And it also
- ;; wraps CATCH 'TOPLEVEL-CATCHER for similar reasons.)
- (loop
- (/show0 "about to set up restarts in TOPLEVEL-REPL")
- ;; There should only be one TOPLEVEL restart, and it's here, so
- ;; restarting at TOPLEVEL always bounces you all the way out here.
- (with-simple-restart (toplevel
- "Restart at toplevel READ/EVAL/PRINT loop.")
- ;; We add a new ABORT restart for every debugger level, so
- ;; restarting at ABORT in a nested debugger gets you out to the
- ;; innermost enclosing debugger, and only when you're in the
- ;; outermost, unnested debugger level does restarting at ABORT
- ;; get you out to here.
- (with-simple-restart
- (abort
- "~@<Reduce debugger level (leaving debugger, returning to toplevel).~@:>")
- (catch 'toplevel-catcher
- (sb!unix::reset-signal-mask)
- ;; in the event of a control-stack-exhausted-error, we should
- ;; have unwound enough stack by the time we get here that this
- ;; is now possible
- (sb!kernel::protect-control-stack-guard-page 1)
- (funcall *repl-fun* noprint)
- (critically-unreachable "after REPL")))))))
+ (/show0 "about to funcall *REPL-FUN-GENERATOR*")
+ (let ((repl-fun (funcall *repl-fun-generator*)))
+ ;; Each REPL in a multithreaded world should have bindings of
+ ;; most CL specials (most critically *PACKAGE*).
+ (with-rebound-io-syntax
+ ;; WITH-SIMPLE-RESTART doesn't actually restart its body as
+ ;; some (like WHN for an embarrassingly long time
+ ;; ca. 2001-12-07) might think, but instead drops control back
+ ;; out at the end. So when a TOPLEVEL or outermost-ABORT
+ ;; restart happens, we need this outer LOOP wrapper to grab
+ ;; control and start over again. (And it also wraps CATCH
+ ;; 'TOPLEVEL-CATCHER for similar reasons.)
+ (loop
+ (/show0 "about to set up restarts in TOPLEVEL-REPL")
+ ;; There should only be one TOPLEVEL restart, and it's here,
+ ;; so restarting at TOPLEVEL always bounces you all the way
+ ;; out here.
+ (with-simple-restart (toplevel
+ "Restart at toplevel READ/EVAL/PRINT loop.")
+ ;; We add a new ABORT restart for every debugger level, so
+ ;; restarting at ABORT in a nested debugger gets you out to
+ ;; the innermost enclosing debugger, and only when you're
+ ;; in the outermost, unnested debugger level does
+ ;; restarting at ABORT get you out to here.
+ (with-simple-restart
+ (abort
+ "~@<Reduce debugger level (leaving debugger, returning to toplevel).~@:>")
+ (catch 'toplevel-catcher
+ (sb!unix::reset-signal-mask)
+ ;; in the event of a control-stack-exhausted-error, we
+ ;; should have unwound enough stack by the time we get
+ ;; here that this is now possible
+ (sb!kernel::protect-control-stack-guard-page 1)
+ (funcall repl-fun noprint)
+ (critically-unreachable "after REPL")))))))))
;;; Our default REPL prompt is the minimal traditional one.
(defun repl-prompt-fun (stream)
(quit)
form)))
-;;; hooks to support customized toplevels like ACL-style toplevel
-;;; from KMR on sbcl-devel 2002-12-21
-(defvar *repl-read-form-fun* #'repl-read-form-fun
- "a function of two stream arguments IN and OUT for the toplevel REPL to
- call: Return the next Lisp form to evaluate (possibly handling other
- magic -- like ACL-style keyword commands -- which precede the next
- Lisp form). The OUT stream is there to support magic which requires
- issuing new prompts.")
-(defvar *repl-prompt-fun* #'repl-prompt-fun
- "a function of one argument STREAM for the toplevel REPL to call: Prompt
- the user for input.")
-(defvar *repl-fun* #'repl-fun
- "a function of one argument NOPRINT that provides the REPL for the system.
- Assumes that *standard-input* and *standard-output* are setup.")
-
(defun repl-fun (noprint)
(/show0 "entering REPL")
(loop
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.5.43"
+"0.8.5.44"
projects / sbcl.git / commitdiff