From 116bd1da77033cca268635fddc8402bf801a9ff8 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 31 Jul 1993 03:11:56 +0000 Subject: [PATCH] Make WORKING-DIRECTORY-PATHNAME and *DEFAULT-PATHNAME-DEFAULTS* be different for each CMDL. Change SET-WORKING-DIRECTORY-PATHNAME! so that it only changes the working directory of the Scheme process if the CMDL is the initial top-level REPL. The end result of these changes is to make the working directory of an Edwin inferior REPL buffer be independent of the global working directory. --- v7/src/runtime/rep.scm | 85 ++++++++++++++++++++++++-------------- v7/src/runtime/runtime.pkg | 15 ++++--- v7/src/runtime/wrkdir.scm | 8 ++-- v8/src/runtime/runtime.pkg | 15 ++++--- 4 files changed, 74 insertions(+), 49 deletions(-) diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index e63502d31..b5c9f5517 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rep.scm,v 14.30 1993/01/18 05:21:57 cph Exp $ +$Id: rep.scm,v 14.31 1993/07/31 03:11:54 cph Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -58,16 +58,23 @@ MIT in each case. |# user-initial-environment user-initial-syntax-table false - '() + `((SET-DEFAULT-DIRECTORY + ,top-level-repl/set-default-directory)) user-initial-prompt) (cmdl-message/strings "Cold load finished"))))) (define root-continuation) + +(define (top-level-repl/set-default-directory cmdl pathname) + cmdl + ((ucode-primitive set-working-directory-pathname! 1) + (->namestring pathname))) ;;;; Command Loops (define cmdl-rtd - (make-record-type "cmdl" '(LEVEL PARENT PORT DRIVER STATE OPERATIONS))) + (make-record-type "cmdl" + '(LEVEL PARENT PORT DRIVER STATE OPERATIONS PROPERTIES))) (define cmdl? (record-predicate cmdl-rtd)) (define cmdl/level (record-accessor cmdl-rtd 'LEVEL)) @@ -78,11 +85,13 @@ MIT in each case. |# (define cmdl/state (record-accessor cmdl-rtd 'STATE)) (define set-cmdl/state! (record-updater cmdl-rtd 'STATE)) (define cmdl/operations (record-accessor cmdl-rtd 'OPERATIONS)) +(define cmdl/properties (record-accessor cmdl-rtd 'PROPERTIES)) (define make-cmdl (let ((constructor - (record-constructor cmdl-rtd - '(LEVEL PARENT PORT DRIVER STATE OPERATIONS)))) + (record-constructor + cmdl-rtd + '(LEVEL PARENT PORT DRIVER STATE OPERATIONS PROPERTIES)))) (lambda (parent port driver state operations) (if (not (or (false? parent) (cmdl? parent))) (error:wrong-type-argument parent "cmdl" 'MAKE-CMDL)) @@ -91,7 +100,8 @@ MIT in each case. |# port driver state - (parse-operations-list operations 'MAKE-CMDL))))) + (parse-operations-list operations 'MAKE-CMDL) + (make-1d-table))))) (define (push-cmdl driver state operations) (let ((parent (nearest-cmdl))) @@ -102,6 +112,12 @@ MIT in each case. |# (if parent (cmdl/base parent) cmdl))) + +(define (cmdl/set-default-directory cmdl pathname) + (let ((operation (cmdl/local-operation cmdl 'SET-DEFAULT-DIRECTORY))) + (if operation + (operation cmdl pathname))) + (port/set-default-directory (cmdl/port cmdl) pathname)) (define (cmdl/start cmdl message) (let ((operation @@ -113,7 +129,13 @@ MIT in each case. |# (fluid-let ((*nearest-cmdl* cmdl) (dynamic-handler-frames '()) (*bound-restarts* - (if (cmdl/parent cmdl) *bound-restarts* '()))) + (if (cmdl/parent cmdl) *bound-restarts* '())) + (standard-error-hook false) + (standard-warning-hook false) + (*working-directory-pathname* + *working-directory-pathname*) + (*default-pathname-defaults* + *default-pathname-defaults*)) (let loop ((message message)) (loop (call-with-current-continuation @@ -325,6 +347,9 @@ MIT in each case. |# (append (if (default-object? operations) '() operations) default-repl-operations))) +(define default-repl-operations + `((START-CHILD ,(lambda (cmdl thunk) cmdl (with-history-disabled thunk))))) + (define (push-repl environment syntax-table #!optional condition operations prompt) (let ((parent (nearest-cmdl))) @@ -335,31 +360,29 @@ MIT in each case. |# (if (default-object? condition) false condition) (if (default-object? operations) '() operations) (if (default-object? prompt) 'INHERIT prompt)))) - + (define (repl-driver repl) (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-syntax-table (cmdl/port repl) (repl/syntax-table repl)) - (fluid-let ((standard-error-hook false) - (standard-warning-hook false)) - (do () (false) - (hook/repl-write - repl - (let ((value - (hook/repl-eval - (let ((s-expression - (hook/repl-prompt - (string-append (number->string (cmdl/level repl)) - " " - (repl/prompt repl)) - (cmdl/port repl)))) - (repl-history/record! reader-history s-expression) - s-expression) - (repl/environment repl) - (repl/syntax-table repl)))) - (repl-history/record! printer-history value) - value)))))) + (do () (false) + (hook/repl-write + repl + (let ((value + (hook/repl-eval + (let ((s-expression + (hook/repl-prompt + (string-append (number->string (cmdl/level repl)) + " " + (repl/prompt repl)) + (cmdl/port repl)))) + (repl-history/record! reader-history s-expression) + s-expression) + (repl/environment repl) + (repl/syntax-table repl)))) + (repl-history/record! printer-history value) + value))))) (define hook/repl-prompt) (define (default/repl-prompt prompt port) @@ -379,9 +402,6 @@ MIT in each case. |# (not (interned-symbol? object)) (not (number? object)) (object-hash object)))) - -(define default-repl-operations - `((START-CHILD ,(lambda (cmdl thunk) cmdl (with-history-disabled thunk))))) (define (repl/start repl #!optional message) (cmdl/start repl @@ -442,10 +462,11 @@ MIT in each case. |# (if (not (interpreter-environment? environment)) (begin (fresh-line port) - (write-string ";Warning! this environment is a compiled-code environment: + (write-string + ";Warning! this environment is a compiled-code environment: ; Assignments to most compiled-code bindings are prohibited, ; as are certain other environment operations." - port))) + port))) (let ((package (environment->package environment))) (if package (begin diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index cbf0e6a0f..1b0bfa99d 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.187 1993/07/28 03:42:14 cph Exp $ +$Id: runtime.pkg,v 14.188 1993/07/31 03:11:55 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -221,7 +221,6 @@ MIT in each case. |# (files "infstr" "infutl") (parent ()) (export () - compiled-code-block/filename compiled-entry/block compiled-entry/dbg-object compiled-entry/filename @@ -1782,11 +1781,12 @@ MIT in each case. |# cmdl-message/strings cmdl/base cmdl/driver + cmdl/level cmdl/operation cmdl/operation-names - cmdl/port - cmdl/level cmdl/parent + cmdl/port + cmdl/properties cmdl/start cmdl/state cmdl? @@ -1847,6 +1847,8 @@ MIT in each case. |# hook/repl-eval) (export (runtime debugger) write-restarts) + (export (runtime working-directory) + cmdl/set-default-directory) (initialization (initialize-package!))) (define-package (runtime save/restore) @@ -2423,6 +2425,8 @@ MIT in each case. |# set-working-directory-pathname! with-working-directory-pathname working-directory-pathname) + (export (runtime rep) + *working-directory-pathname*) (initialization (initialize-package!))) (define-package (runtime user-interface) @@ -2438,7 +2442,7 @@ MIT in each case. |# port/set-default-environment port/set-default-syntax-table port/write-result) - (export (runtime working-directory) + (export (runtime rep) port/set-default-directory) (export (runtime debugger-command-loop) port/debugger-failure @@ -2455,7 +2459,6 @@ MIT in each case. |# (files "thread") (parent ()) (export () - allow-thread-event-delivery block-thread-events condition-type:thread-dead condition-type:thread-deadlock diff --git a/v7/src/runtime/wrkdir.scm b/v7/src/runtime/wrkdir.scm index 483afc94e..1fb66a585 100644 --- a/v7/src/runtime/wrkdir.scm +++ b/v7/src/runtime/wrkdir.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wrkdir.scm,v 14.6 1992/02/08 15:08:47 cph Exp $ +$Id: wrkdir.scm,v 14.7 1993/07/31 03:11:56 cph Exp $ -Copyright (c) 1988-92 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -65,9 +65,7 @@ MIT in each case. |# (set! *working-directory-pathname* pathname) (set! *default-pathname-defaults* (merge-pathnames pathname *default-pathname-defaults*)) - ((ucode-primitive set-working-directory-pathname! 1) - (->namestring pathname)) - (port/set-default-directory (nearest-cmdl/port) pathname) + (cmdl/set-default-directory (nearest-cmdl) pathname) pathname))) (define (with-working-directory-pathname name thunk) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index cbf0e6a0f..1b0bfa99d 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.187 1993/07/28 03:42:14 cph Exp $ +$Id: runtime.pkg,v 14.188 1993/07/31 03:11:55 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -221,7 +221,6 @@ MIT in each case. |# (files "infstr" "infutl") (parent ()) (export () - compiled-code-block/filename compiled-entry/block compiled-entry/dbg-object compiled-entry/filename @@ -1782,11 +1781,12 @@ MIT in each case. |# cmdl-message/strings cmdl/base cmdl/driver + cmdl/level cmdl/operation cmdl/operation-names - cmdl/port - cmdl/level cmdl/parent + cmdl/port + cmdl/properties cmdl/start cmdl/state cmdl? @@ -1847,6 +1847,8 @@ MIT in each case. |# hook/repl-eval) (export (runtime debugger) write-restarts) + (export (runtime working-directory) + cmdl/set-default-directory) (initialization (initialize-package!))) (define-package (runtime save/restore) @@ -2423,6 +2425,8 @@ MIT in each case. |# set-working-directory-pathname! with-working-directory-pathname working-directory-pathname) + (export (runtime rep) + *working-directory-pathname*) (initialization (initialize-package!))) (define-package (runtime user-interface) @@ -2438,7 +2442,7 @@ MIT in each case. |# port/set-default-environment port/set-default-syntax-table port/write-result) - (export (runtime working-directory) + (export (runtime rep) port/set-default-directory) (export (runtime debugger-command-loop) port/debugger-failure @@ -2455,7 +2459,6 @@ MIT in each case. |# (files "thread") (parent ()) (export () - allow-thread-event-delivery block-thread-events condition-type:thread-dead condition-type:thread-deadlock -- 2.25.1