From a27597cbd6bb8edc1dc36652460cd39c8698b84b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 29 Mar 2005 05:04:09 +0000 Subject: [PATCH] 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. --- v7/src/runtime/load.scm | 14 +++++-- v7/src/runtime/rep.scm | 83 ++++++++++++++++++++++---------------- v7/src/runtime/runtime.pkg | 29 ++++++++++--- 3 files changed, 83 insertions(+), 43 deletions(-) diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index 7894cd4f1..c3f88b9e0 100644 --- 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)))))))) ;;;; Loader for packed binaries diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index ab325fd53..31ca8158b 100644 --- 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 acc7af698..71bad22de 100644 --- 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) -- 2.25.1