From dfae0cd85d45a30d8687d6a366b608d10350872f Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sun, 16 Nov 2003 23:52:04 +0000 Subject: [PATCH] 0.8.5.44: SB-ACLREPL threading ... delete erroneous previous attempt (binding specials outside DEFUN forms) ... define a repl fun maker, which (a) has state in closure variables and (b) saves its state to said variables on non-local exit. ... rearrange sb-aclrepl package manipulation a little ... RESET-CMD now searches for the sb-impl::toplevel restart by name All this requires some core support ... *REPL-FUN* is ok for stateless repls, but not for stateful ones; change protocol to make a repl-fun by calling *REPL-FUN-GENERATOR* instead (I feel a bit bad about this, but since this is all in the SB-IMPL:: package I don't feel /too/ bad about breaking the interface. I doubt anything but SB-ACLREPL used it anyway) ... rebind cl specials per TOPLEVEL so that IN-PACKAGEs don't collide (don't use WITH-STANDARD-IO-SYNTAX, duh) --- NEWS | 3 ++ contrib/sb-aclrepl/inspect.lisp | 1 - contrib/sb-aclrepl/repl.lisp | 42 ++++++++--------- contrib/sb-aclrepl/toplevel.lisp | 38 ++++++++------- package-data-list.lisp-expr | 3 +- src/code/early-extensions.lisp | 28 +++++++++++ src/code/toplevel.lisp | 95 +++++++++++++++++++++----------------- version.lisp-expr | 2 +- 8 files changed, 128 insertions(+), 84 deletions(-) diff --git a/NEWS b/NEWS index b821401..b4bdb33 100644 --- a/NEWS +++ b/NEWS @@ -2183,6 +2183,9 @@ changes in sbcl-0.8.6 relative to sbcl-0.8.5: 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. diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp index b0c5c84..2a7f83f 100644 --- a/contrib/sb-aclrepl/inspect.lisp +++ b/contrib/sb-aclrepl/inspect.lisp @@ -58,7 +58,6 @@ The commands are: (defun inspector-fun (object input-stream output-stream) - (declare (ignore input-stream)) (let ((*current-inspect* nil) (*inspect-raw* nil) (*inspect-length* *inspect-length*) diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp index 6b2431b..e31f696 100644 --- a/contrib/sb-aclrepl/repl.lisp +++ b/contrib/sb-aclrepl/repl.lisp @@ -52,11 +52,6 @@ (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)) @@ -64,18 +59,6 @@ (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 @@ -639,8 +622,7 @@ (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*) @@ -866,5 +848,23 @@ (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)) diff --git a/contrib/sb-aclrepl/toplevel.lisp b/contrib/sb-aclrepl/toplevel.lisp index 25f5481..36c36da 100644 --- a/contrib/sb-aclrepl/toplevel.lisp +++ b/contrib/sb-aclrepl/toplevel.lisp @@ -1,17 +1,28 @@ (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*)) @@ -28,6 +39,7 @@ (catch 'repl-catcher (loop (rep-one))) + (declare (ignore reason-param)) (cond ((and (eq reason :inspect) (plusp *break-level*)) @@ -62,9 +74,3 @@ ;; 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)) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 30d8648..5adc2ea 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -779,12 +779,11 @@ retained, possibly temporariliy, because it might be used internally." "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" diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 065f569..cf74775 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1138,3 +1138,31 @@ which can be found at .~:@>" (defun promise-ready-p (promise) (or (not (consp promise)) (car promise))) + +;;; 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))) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 5367a75..5aadeec 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -478,6 +478,23 @@ ;; (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") @@ -485,34 +502,41 @@ (- 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 - "~@") - (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 + "~@") + (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) @@ -529,21 +553,6 @@ (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 diff --git a/version.lisp-expr b/version.lisp-expr index 6a2e73c..301c1fc 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4