Implement queueing mechanism is REPL implementation so that programs

can queue events to happen in place of user input.  Use this mechanism
to process --eval and --load command-line arguments, so that their
evaluations occur in the proper dynamic context.

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index 7894cd4f1a83efb0df8d82f1795c86ad651f4dcf..c3f88b9e00f49fbcda2361ea17299d1aef99bd23 100644 (file)
--- a/v7/src/runtime/load.scm
+++ b/v7/src/runtime/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: load.scm,v 14.68 2004/12/06 21:21:44 cph Exp $
+$Id: load.scm,v 14.69 2005/03/29 05:03:53 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1999,2000,2001,2002,2003 Massachusetts Institute of Technology
@@ -550,10 +550,18 @@ USA.
     (lambda ()
       (set! generate-suspend-file? #f)
       unspecific))
-  (argument-command-line-parser "load" #t load)
+  (argument-command-line-parser "load" #t
+    (lambda (arg)
+      (run-in-nearest-repl
+       (lambda (repl)
+        repl
+        (load arg)))))
   (argument-command-line-parser "eval" #t
     (lambda (arg)
-      (eval (with-input-from-string arg read) user-initial-environment))))
+      (run-in-nearest-repl
+       (lambda (repl)
+        (let ((sexp (with-input-from-string arg read)))
+          (repl-write repl sexp (repl-eval repl sexp))))))))
 \f
 ;;;; Loader for packed binaries
 

diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm
index ab325fd535c483e1eb54c12f76deff0f69a4b662..31ca8158bc7b036f3e8ecbc4bc758068a95fdc95 100644 (file)
--- a/v7/src/runtime/rep.scm
+++ b/v7/src/runtime/rep.scm
@@ -1,10 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: rep.scm,v 14.62 2004/02/16 05:38:05 cph Exp $
+$Id: rep.scm,v 14.63 2005/03/29 05:04:00 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1992,1993,1994,1998,1999,2001 Massachusetts Institute of Technology
-Copyright 2003 Massachusetts Institute of Technology
+Copyright 2003,2004,2005 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -35,6 +35,7 @@ USA.
 
 (define (initialize-package!)
   (set! *nearest-cmdl* #f)
+  (set! hook/repl-read default/repl-read)
   (set! hook/repl-eval default/repl-eval)
   (set! hook/repl-write default/repl-write)
   (set! hook/set-default-environment default/set-default-environment)
@@ -75,6 +76,8 @@ USA.
   (operations cmdl/operations)
   (properties cmdl/properties))
 
+(define-guarantee cmdl "command loop")
+
 (define (make-cmdl parent port driver state operations)
   (if (not (or (not parent) (cmdl? parent)))
       (error:wrong-type-argument parent "cmdl" 'MAKE-CMDL))
@@ -428,25 +431,37 @@ USA.
                    (operation repl condition)))
              (hook/error-decision
               (hook/error-decision repl condition)))))
-  (let ((reader-history (repl/reader-history repl))
-       (printer-history (repl/printer-history repl)))
-    (port/set-default-environment (cmdl/port repl) (repl/environment repl))
+  (port/set-default-environment (cmdl/port repl) (repl/environment repl))
+  (let ((queue (repl/input-queue repl)))
     (do () (#f)
-      (let ((s-expression
-            (prompt-for-command-expression (cons 'STANDARD (repl/prompt repl))
-                                           (cmdl/port repl))))
-       (repl-history/record! reader-history s-expression)
-       (let ((value
-              (hook/repl-eval repl s-expression (repl/environment repl))))
-         (repl-history/record! printer-history value)
-         (hook/repl-write repl s-expression value))))))
+      (if (queue-empty? queue)
+         (let ((s-expression (repl-read repl)))
+           (repl-write repl s-expression (repl-eval repl s-expression)))
+         ((dequeue! queue) repl)))))
+
+(define (run-in-nearest-repl procedure)
+  (guarantee-procedure-of-arity procedure 1 'run-in-nearest-repl)
+  (enqueue! (repl/input-queue (nearest-repl)) procedure))
+
+(define (repl-read repl)
+  (guarantee-repl repl 'repl-read)
+  (hook/repl-read repl))
+
+(define hook/repl-read)
+(define (default/repl-read repl)
+  (prompt-for-command-expression (cons 'STANDARD (repl/prompt repl))
+                                (cmdl/port repl)))
+
+(define (repl-eval repl s-expression)
+  (guarantee-repl repl 'repl-eval)
+  (repl-history/record! (repl/reader-history repl) s-expression)
+  (let ((value (hook/repl-eval repl s-expression (repl/environment repl))))
+    (repl-history/record! (repl/printer-history repl) value)
+    value))
 
 (define hook/repl-eval)
 (define (default/repl-eval repl s-expression environment)
-  (let ((scode (syntax s-expression environment)))
-    (with-repl-eval-boundary repl
-      (lambda ()
-       (extended-scode-eval scode environment)))))
+  (repl-scode-eval repl (syntax s-expression environment) environment))
 
 (define (repl-scode-eval repl scode environment)
   (with-repl-eval-boundary repl
@@ -459,6 +474,10 @@ USA.
    with-repl-eval-boundary
    repl))
 
+(define (repl-write repl s-expression value)
+  (guarantee-repl repl 'repl-write)
+  (hook/repl-write repl s-expression value))
+
 (define hook/repl-write)
 (define (default/repl-write repl s-expression object)
   (port/write-result (cmdl/port repl)
@@ -615,12 +634,15 @@ USA.
   environment
   (condition #f read-only #t)
   (reader-history (make-repl-history repl-reader-history-size))
-  (printer-history (make-repl-history repl-printer-history-size)))
+  (printer-history (make-repl-history repl-printer-history-size))
+  (input-queue (make-queue) read-only #t))
 
 (define (repl? object)
   (and (cmdl? object)
        (repl-state? (cmdl/state object))))
 
+(define-guarantee repl "read-eval-print loop")
+
 (define-integrable (repl/prompt repl)
   (repl-state/prompt (cmdl/state repl)))
 
@@ -650,6 +672,9 @@ USA.
 (define-integrable (set-repl/printer-history! repl printer-history)
   (set-repl-state/printer-history! (cmdl/state repl) printer-history))
 
+(define-integrable (repl/input-queue repl)
+  (repl-state/input-queue (cmdl/state repl)))
+
 (define (repl/parent repl)
   (skip-non-repls (cmdl/parent repl)))
 
@@ -722,11 +747,8 @@ USA.
     (set-repl/environment! (nearest-repl) environment)
     environment))
 
-(define (->environment object #!optional procedure)
-  (let ((procedure
-        (if (or (default-object? procedure) (not procedure))
-            '->ENVIRONMENT
-            procedure)))
+(define (->environment object #!optional caller)
+  (let ((caller (if (default-object? caller) '->ENVIRONMENT caller)))
     (cond ((environment? object) object)
          ((package? object) (package/environment object))
          ((procedure? object) (procedure-environment object))
@@ -740,21 +762,14 @@ USA.
                    (and package-name
                         (name->package package-name)))))
             (if (not package)
-                (error:wrong-type-argument object "environment" procedure))
+                (error:wrong-type-argument object "environment" caller))
             (package/environment package))))))
 
 (define (re #!optional index)
   (let ((repl (nearest-repl)))
-    (hook/repl-eval repl
-                   (let ((history (repl/reader-history repl)))
-                     (let ((s-expression
-                            (repl-history/read history
-                                               (if (default-object? index)
-                                                   1
-                                                   index))))
-                       (repl-history/replace-current! history s-expression)
-                       s-expression))
-                   (repl/environment repl))))
+    (repl-eval repl
+              (repl-history/read (repl/reader-history repl)
+                                 (if (default-object? index) 1 index)))))
 
 (define (in #!optional index)
   (repl-history/read (repl/reader-history (nearest-repl))

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index acc7af69886b8f26dd67ade64bd171ecdfb6f69e..71bad22de84cfa227d9842a5582c9e89dace10ac 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.534 2005/03/19 05:08:28 cph Exp $
+$Id: runtime.pkg,v 14.535 2005/03/29 05:04:09 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -1135,6 +1135,7 @@ USA.
          continuation/dynamic-state
          continuation/type
          continuation?
+         error:not-continuation
          guarantee-continuation
          make-continuation
          non-reentrant-call-with-current-continuation
@@ -1360,10 +1361,15 @@ USA.
          entity-extra
          entity-procedure
          entity?
+         error:not-compiled-procedure
+         error:not-compound-procedure
+         error:not-primitive-procedure
+         error:not-procedure
          guarantee-compiled-procedure
          guarantee-compound-procedure
          guarantee-primitive-procedure
          guarantee-procedure
+         guarantee-procedure-of-arity
          implemented-primitive-procedure?
          make-apply-hook
          make-arity-dispatched-procedure
@@ -1376,6 +1382,7 @@ USA.
          procedure-components
          procedure-environment
          procedure-lambda
+         procedure-of-arity?
          procedure?
          set-apply-hook-extra!
          set-apply-hook-procedure!
@@ -2131,6 +2138,7 @@ USA.
          error:not-list
          error:not-pair
          error:not-restricted-keyword-list
+         error:not-unique-keyword-list
          error:not-weak-list
          except-last-pair
          except-last-pair!
@@ -2152,6 +2160,7 @@ USA.
          guarantee-list-of-type->length
          guarantee-pair
          guarantee-restricted-keyword-list
+         guarantee-unique-keyword-list
          guarantee-weak-list
          keep-matching-items
          keyword-list->alist
@@ -2200,6 +2209,7 @@ USA.
          tenth
          third
          tree-copy
+         unique-keyword-list?
          weak-car
          weak-cdr
          weak-cons
@@ -2840,7 +2850,14 @@ USA.
          cmdl?
          condition-type:breakpoint
          condition/breakpoint?
+         error:not-cmdl
+         error:not-repl
          ge
+         guarantee-cmdl
+         guarantee-repl
+         hook/repl-eval
+         hook/repl-read
+         hook/repl-write
          in
          initial-top-level-repl
          make-cmdl
@@ -2861,12 +2878,15 @@ USA.
          push-repl
          re
          read-eval-print
+         repl-eval
          repl-history/read
          repl-history/record!
          repl-history/size
          repl-printer-history-size
+         repl-read
          repl-reader-history-size
          repl-scode-eval
+         repl-write
          repl/base
          repl/condition
          repl/environment
@@ -2879,6 +2899,7 @@ USA.
          repl:write-result-hash-numbers?
          repl?
          restart
+         run-in-nearest-repl
          set-cmdl/state!
          set-repl/environment!
          set-repl/printer-history!
@@ -2889,14 +2910,10 @@ USA.
          standard-breakpoint-hook
          ve
          with-repl-eval-boundary)
-  (export (runtime load)
-         hook/repl-eval
-         hook/repl-write)
+  (export (runtime load))
   (export (runtime emacs-interface)
          hook/error-decision
          set-cmdl/port!)
-  (export (runtime user-interface)
-         hook/repl-eval)
   (export (runtime debugger)
          write-restarts)
   (export (runtime working-directory)