0.9.1.59:

[sbcl.git] / contrib / sb-aclrepl / repl.lisp

diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp
index c3377e7..e2d3f82 100644 (file)
--- 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
@@ -86,21 +69,24 @@
 
 (defun read-cmd (input-stream)
   ;; Reads a command from the user and returns a user-cmd object
-  (let ((next-char (peek-char-non-whitespace input-stream)))
-    (cond
-      ((eql *command-char* next-char)
-       (dispatch-command-line input-stream))
-      ((eql #\newline next-char)
-       (read-char input-stream)
-       *null-cmd*)
-      ((eql :eof next-char)
-       *eof-cmd*)
-      (t
-       (let* ((eof (cons nil *eof-marker*))
-             (form (read input-stream nil eof)))
-        (if (eq form eof)
-            *eof-cmd*
-            (make-user-cmd :input form :func nil :hnum *cmd-number*)))))))
+  (let* ((next-char (peek-char-non-whitespace input-stream))
+        (cmd (cond
+               ((eql *command-char* next-char)
+                (dispatch-command-line input-stream))
+               ((eql #\newline next-char)
+                (read-char input-stream)
+                *null-cmd*)
+               ((eql :eof next-char)
+                *eof-cmd*)
+               (t
+                (let* ((eof (cons nil *eof-marker*))
+                       (form (read input-stream nil eof)))
+                  (if (eq form eof)
+                      *eof-cmd*
+                      (make-user-cmd :input form :func nil :hnum *cmd-number*)))))))
+    (if (and (eq cmd *eof-cmd*) (typep input-stream 'string-stream))
+       (throw 'repl-catcher cmd)
+       cmd)))
 
 (defun dispatch-command-line (input-stream)
   "Processes an input line that starts with *command-char*"
@@ -317,7 +303,7 @@
 #+sb-thread
 (defun thread-pids ()
   "Return a list of the pids for all threads"
-  (let ((offset (* 4 sb-vm::thread-pid-slot)))
+  (let ((offset (* 4 sb-vm::thread-os-thread-slot)))
     (sb-thread::mapcar-threads
      #'(lambda (sap) (sb-sys:sap-ref-32 sap offset)))))
 
@@ -425,7 +411,7 @@
     (values)))
 
 (defun inspect-cmd (arg)
-  (inspector-fun arg nil *output*)
+  (inspector-fun (eval arg) nil *output*)
   (values))
 
 (defun istep-cmd (&optional arg-string)
@@ -636,8 +622,7 @@
   (values))
 
 (defun reset-cmd ()
-  ;; The last restart goes to the toplevel
-  (invoke-restart-interactively (car (last (compute-restarts)))))
+  (throw 'sb-impl::toplevel-catcher nil))
 
 (defun dirs-cmd ()
   (dolist (dir *dir-stack*)
@@ -775,29 +760,23 @@
   (and (characterp x)
        (or (char= x #\space)
           (char= x #\tab)
+          (char= x #\page)
           (char= x #\newline)
           (char= x #\return))))
 
 (defun whitespace-char-not-newline-p (x)
   (and (whitespace-char-p x)
        (not (char= x #\newline))))
-
 \f
 ;;;; linking into SBCL hooks
 
-
 (defun repl-prompt-fun (stream)
   (let ((break-level (when (plusp *break-level*)
                       *break-level*))
        (frame-number (when (and (plusp *break-level*)
                                 sb-debug::*current-frame*)
                        (sb-di::frame-number sb-debug::*current-frame*))))
-    #+sb-thread
-    (let ((lock sb-thread::*session-lock*))
-      (sb-thread::get-foreground)
-      (let ((stopped-threads (sb-thread::waitqueue-data lock)))
-       (when stopped-threads
-         (format stream "~{~&Thread ~A suspended~}~%" stopped-threads))))
+    (sb-thread::get-foreground)
     (fresh-line stream)
     (if (functionp *prompt*)
        (write-string (funcall *prompt*
@@ -832,7 +811,7 @@
        ((eq (user-cmd-func user-cmd) :cmd-error)
         (format *output* "Unknown top-level command: ~s.~%"
                 (user-cmd-input user-cmd))
-        (format *output* "Type `:help' for the list of commands.~%")
+        (format *output* "Type `~Ahelp' for the list of commands.~%" *command-char*)
         t)
        ((eq (user-cmd-func user-cmd) :history-error)
         (format *output* "Input numbered ~d is not on the history list~%"
@@ -863,5 +842,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))