From 16b1d68e97f03832f1d86a3548b146b2d917ba71 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 26 Nov 1991 07:07:31 +0000 Subject: [PATCH] Changes in appearance: * Loading, dumping, and warning messages now preceded by ";". * New prompts for debugger, where, error, and breakpoint. * REP loops started by the debugger and where no longer have distinctive prompts. Now they use the standard prompt. * PROMPT-FOR-COMMAND-CHAR now echos the character it is prompting for. Changes to port implementation: * Standard output procedures like WRITE no longer flush the output port after they write to it. Instead, they invoke the new operation DISCRETIONARY-FLUSH-OUTPUT (if it exists). At present, only the console defines this new operation to do anything -- thus the console behaves the same as before, unlike other ports. The new procedure FLUSH-OUTPUT is used to explicitly flush output ports. * New port operations control the blocking and terminal modes of ports: PORT/INPUT-BLOCKING-MODE PORT/SET-INPUT-BLOCKING-MODE PORT/WITH-INPUT-BLOCKING-MODE PORT/OUTPUT-BLOCKING-MODE PORT/SET-OUTPUT-BLOCKING-MODE PORT/WITH-OUTPUT-BLOCKING-MODE PORT/INPUT-TERMINAL-MODE PORT/SET-INPUT-TERMINAL-MODE PORT/WITH-INPUT-TERMINAL-MODE PORT/OUTPUT-TERMINAL-MODE PORT/SET-OUTPUT-TERMINAL-MODE PORT/WITH-OUTPUT-TERMINAL-MODE * New input-port operation READ allows the port to define how a READ is performed. This permits the implementation of ports that read s-expressions directly. Changes to CMDL/REPL implementation: * CMDL-MESSAGE/ACTIVE now passes a port to its argument, rather than a cmdl object. * Incompatible changes to arguments and return values of PUSH-CMDL, PUSH-REPL, MAKE-CMDL. The procedures no longer start the cmdl that they create, but just return it. It must be explicitly started by calling one of the new procedures CMDL/START or REPL/START. * cmdl objects now have just one bidirectional port instead of two unidirectional ports. * The prompting procedures PROMPT-FOR-EXPRESSION, PROMPT-FOR-COMMAND-CHAR, and PROMPT-FOR-CONFIRMATION no longer take a cmdl object as their optional second argument -- instead they take a port. The new procedure PROMPT-FOR-COMMAND-EXPRESSION is similar. * cmdl objects now support custom operations of various kinds, to allow the customization of behavior. The previous spawn-child special operation has been eliminated. Changes to DEBUG/WHERE implementation: * Debugger command interface now passes a port to each command procedure, in addition to the state object. The current input and output ports are not bound to anything in particular while the debugger is running. * Arguments to debugger command procedures are now optional, so that using X mode in the debugger is more convenient. Changes to various hooks: * Most of the hooks that were used by the Emacs interface have been eliminated. That functionality is now provided by custom port operations. Hooks that were affected: debugger output prompting run and gc lights repl presentation * Definition of keyboard interrupt hooks changed: if the hooks are #F, they are ignored, otherwise they are invoked. If the interrupt handler hooks return, that means they declined to handle the interrupt, and the standard action is taken. * HOOK/BEFORE-RESTART has been replaced by HOOK/INVOKE-RESTART. The new hook is used by INVOKE-RESTART as well as INVOKE-RESTART-INTERACTIVELY, and it defaults to APPLY. * PARSE-OBJECT/INTERNAL and PARSE-OBJECTs/INTERNAL eliminated. --- v7/src/runtime/dbgcmd.scm | 88 ++--- v7/src/runtime/dbgutl.scm | 163 ++++---- v7/src/runtime/debug.scm | 743 +++++++++++++++++++----------------- v7/src/runtime/ed-ffi.scm | 20 +- v7/src/runtime/emacs.scm | 465 +++++++++++------------ v7/src/runtime/error.scm | 36 +- v7/src/runtime/fileio.scm | 12 +- v7/src/runtime/format.scm | 11 +- v7/src/runtime/gc.scm | 15 +- v7/src/runtime/gcstat.scm | 11 +- v7/src/runtime/genio.scm | 60 ++- v7/src/runtime/global.scm | 8 +- v7/src/runtime/input.scm | 24 +- v7/src/runtime/intrpt.scm | 136 ++----- v7/src/runtime/load.scm | 11 +- v7/src/runtime/output.scm | 27 +- v7/src/runtime/parse.scm | 38 +- v7/src/runtime/port.scm | 125 ++++-- v7/src/runtime/pp.scm | 4 +- v7/src/runtime/rep.scm | 760 +++++++++++++++++-------------------- v7/src/runtime/runtime.pkg | 129 ++++--- v7/src/runtime/savres.scm | 7 +- v7/src/runtime/ttyio.scm | 187 +++++---- v7/src/runtime/version.scm | 4 +- v7/src/runtime/where.scm | 64 ++-- v7/src/runtime/wrkdir.scm | 19 +- v8/src/runtime/dbgutl.scm | 163 ++++---- v8/src/runtime/global.scm | 8 +- v8/src/runtime/load.scm | 11 +- v8/src/runtime/runtime.pkg | 129 ++++--- 30 files changed, 1795 insertions(+), 1683 deletions(-) diff --git a/v7/src/runtime/dbgcmd.scm b/v7/src/runtime/dbgcmd.scm index 914bc8e6b..db8802af5 100644 --- a/v7/src/runtime/dbgcmd.scm +++ b/v7/src/runtime/dbgcmd.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.12 1991/05/15 22:03:00 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.13 1991/11/26 07:05:04 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -62,68 +62,70 @@ MIT in each case. |# (loop (cdr command-set))))))) (define (letter-commands command-set message prompt state) - (push-cmdl letter-commands/driver - (vector command-set prompt state) - message - make-cmdl)) + (cmdl/start (push-cmdl letter-commands/driver + (vector command-set prompt state) + '()) + message)) (define (letter-commands/driver cmdl) (call-with-current-continuation (lambda (continuation) - (bind-condition-handler (list condition-type:error) - (lambda (condition) - (let ((port (cmdl/output-port cmdl))) + (let ((port (cmdl/port cmdl))) + (bind-condition-handler (list condition-type:error) + (lambda (condition) (beep port) + (fresh-line port) (write-string ";Ignoring error:\n;" port) - (write-condition-report condition port)) - (continuation unspecific)) - (lambda () - (let ((command-set (vector-ref (cmdl/state cmdl) 0)) - (prompt (vector-ref (cmdl/state cmdl) 1)) - (state (vector-ref (cmdl/state cmdl) 2))) - (let loop () - (let ((char (char-upcase (prompt-for-command-char prompt cmdl)))) - (with-output-to-port (cmdl/output-port cmdl) - (lambda () - (let ((entry (assv char (cdr command-set)))) - (if entry - ((cadr entry) state) - (begin - (beep) - (newline) - (write-string "Unknown command char: ") - (write char) - (loop))))))))))))) + (write-condition-report condition port) + (continuation unspecific)) + (lambda () + (let ((command-set (vector-ref (cmdl/state cmdl) 0)) + (prompt + (string-append (number->string (cmdl/level cmdl)) + " " + (vector-ref (cmdl/state cmdl) 1))) + (state (vector-ref (cmdl/state cmdl) 2))) + (let loop () + (let ((entry + (assv (char-upcase (prompt-for-command-char prompt port)) + (cdr command-set)))) + (if entry + ((cadr entry) state port) + (begin + (beep port) + (newline port) + (write-string "Unknown command character" port) + (loop))))))))))) (cmdl-message/null)) -(define ((standard-help-command command-set) state) +(define ((standard-help-command command-set) state port) state ;ignore (for-each (lambda (entry) - (newline) - (write-string " ") - (write-char (car entry)) - (write-string " ") - (write-string (caddr entry))) + (newline port) + (write-string " " port) + (write-char (car entry) port) + (write-string " " port) + (write-string (caddr entry) port)) (cdr command-set)) unspecific) -(define (standard-exit-command state) +(define (standard-exit-command state port) state ;ignore (continue) - (debugger-failure "Can't exit; use a restart command instead.")) + (debugger-failure port "Can't exit; use a restart command instead.")) (define (initialize-package!) - (set! hook/leaving-command-loop default/leaving-command-loop)) - -(define hook/leaving-command-loop) + (set! hook/leaving-command-loop default/leaving-command-loop) + unspecific) (define (leaving-command-loop thunk) (hook/leaving-command-loop thunk)) +(define hook/leaving-command-loop) (define (default/leaving-command-loop thunk) (thunk)) -(define (debug/read-eval-print environment from to prompt) +(define (debug/read-eval-print environment from to) (leaving-command-loop (lambda () (with-simple-restart 'CONTINUE @@ -134,10 +136,10 @@ MIT in each case. |# (lambda () (read-eval-print environment - (cmdl-message/standard - (string-append - "You are now in " to ". Type C-c C-u to return to " from ".")) - prompt)))))) + (cmdl-message/strings + (string-append "You are now in " to ".") + (string-append "Type C-c C-u to return to " from ".")) + user-initial-prompt)))))) (define (debug/eval expression environment) (leaving-command-loop diff --git a/v7/src/runtime/dbgutl.scm b/v7/src/runtime/dbgutl.scm index c69aecff2..0b5b64cf1 100644 --- a/v7/src/runtime/dbgutl.scm +++ b/v7/src/runtime/dbgutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgutl.scm,v 14.13 1991/07/15 23:40:42 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgutl.scm,v 14.14 1991/11/26 07:05:11 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -37,41 +37,45 @@ MIT in each case. |# (declare (usual-integrations)) -(define (print-user-friendly-name environment) +(define (print-user-friendly-name environment port) (let ((name (environment-procedure-name environment))) (if name (let ((rename (special-form-procedure-name? name))) (if rename - (begin (write-string "a ") - (write-string (string-upcase rename)) - (write-string " special form")) - (begin (write-string "the procedure: ") - (write-dbg-upcase-name name)))) - (write-string "an unknown procedure")))) - -(define (show-environment-procedure environment) + (begin + (write-string "a " port) + (write-string (string-upcase rename) port) + (write-string " special form") port) + (begin + (write-string "the procedure: " port) + (write-dbg-upcase-name name port)))) + (write-string "an unknown procedure" port)))) + +(define (show-environment-procedure environment port) (let ((scode-lambda (environment-lambda environment))) (if scode-lambda - (presentation (lambda () (pretty-print scode-lambda))) - (debugger-failure "No procedure for this environment.")))) + (debugger-presentation port + (lambda () + (pretty-print scode-lambda port))) + (debugger-failure port "No procedure for this environment.")))) -(define (write-dbg-name name) - (if (string? name) (write-string name) (write name))) +(define (write-dbg-name name port) + (if (string? name) (write-string name port) (write name port))) -(define (write-dbg-upcase-name name) +(define (write-dbg-upcase-name name port) (let ((string (if (string? name) name (with-output-to-string (lambda () (write name)))))) - (write-string (string-upcase string)))) + (write-string (string-upcase string) port))) -(define (debug/read-eval-print-1 environment) +(define (debug/read-eval-print-1 environment port) (let ((value - (debug/eval (prompt-for-expression "Evaluate expression") + (debug/eval (prompt-for-expression "Evaluate expression" port) environment))) (if (undefined-value? value) - (debugger-message "No value") - (debugger-message "Value: " value)))) + (debugger-message port "No value") + (debugger-message port "Value: " value)))) (define (output-to-string length thunk) (let ((x (with-output-to-truncated-string length thunk))) @@ -79,75 +83,77 @@ MIT in each case. |# (substring-move-right! " ..." 0 4 (cdr x) (- length 4))) (cdr x))) -(define (show-frames environment depth) - (presentation - (lambda () - (let loop ((environment environment) (depth depth)) - (write-string "----------------------------------------") - (newline) - (show-frame environment depth true) - (if (eq? true (environment-has-parent? environment)) - (begin - (newline) - (newline) - (loop (environment-parent environment) (1+ depth)))))))) - -(define (show-frame environment depth brief?) - (show-environment-name environment) +(define (show-frames environment depth port) + (debugger-presentation port + (lambda () + (let loop ((environment environment) (depth depth)) + (write-string "----------------------------------------" port) + (newline port) + (show-frame environment depth true port) + (if (eq? true (environment-has-parent? environment)) + (begin + (newline port) + (newline port) + (loop (environment-parent environment) (1+ depth)))))))) + +(define (show-frame environment depth brief? port) + (show-environment-name environment port) (if (not (negative? depth)) - (begin (newline) - (write-string "Depth (relative to initial environment): ") - (write depth))) + (begin + (newline port) + (write-string "Depth (relative to initial environment): " port) + (write depth port))) (if (not (and (environment->package environment) brief?)) (begin - (newline) - (show-environment-bindings environment brief?)))) + (newline port) + (show-environment-bindings environment brief? port)))) -(define (show-environment-name environment) - (write-string "Environment ") +(define (show-environment-name environment port) + (write-string "Environment " port) (let ((package (environment->package environment))) (if package (begin - (write-string "named: ") - (write (package/name package))) + (write-string "named: " port) + (write (package/name package) port)) (begin - (write-string "created by ") - (print-user-friendly-name environment))))) + (write-string "created by " port) + (print-user-friendly-name environment port))))) -(define (show-environment-bindings environment brief?) +(define (show-environment-bindings environment brief? port) (let ((names (environment-bound-names environment))) (let ((n-bindings (length names)) (finish (lambda (names) - (newline) + (newline port) (for-each (lambda (name) (print-binding name - (environment-lookup environment name))) + (environment-lookup environment name) + port)) names)))) (cond ((zero? n-bindings) - (write-string " has no bindings")) + (write-string " has no bindings" port)) ((and brief? (> n-bindings brief-bindings-limit)) - (write-string " has ") - (write n-bindings) - (write-string " bindings (first ") - (write brief-bindings-limit) - (write-string " shown):") + (write-string " has " port) + (write n-bindings port) + (write-string " bindings (first " port) + (write brief-bindings-limit port) + (write-string " shown):" port) (finish (list-head names brief-bindings-limit))) (else - (write-string " has bindings:") + (write-string " has bindings:" port) (finish names)))))) (define brief-bindings-limit 16) -(define (print-binding name value) - (let ((x-size (output-port/x-size (current-output-port)))) - (newline) +(define (print-binding name value port) + (let ((x-size (output-port/x-size port))) + (newline port) (write-string (let ((name (output-to-string (quotient x-size 2) (lambda () - (write-dbg-name name))))) + (write-dbg-name name (current-output-port)))))) (if (unassigned-reference-trap? value) (string-append name " is unassigned") (let ((s (string-append name " = "))) @@ -155,40 +161,19 @@ MIT in each case. |# s (output-to-string (max (- x-size (string-length s)) 0) (lambda () - (write value)))))))))) - -(define hook/debugger-failure) -(define hook/debugger-message) -(define hook/presentation) - -(define (initialize-package!) - (set! hook/debugger-failure default/debugger-failure) - (set! hook/debugger-message default/debugger-message) - (set! hook/presentation default/presentation) - unspecific) + (write value))))))) + port))) -(define (debugger-failure . objects) - (hook/debugger-failure (message-arguments->string objects))) +(define (debugger-failure port . objects) + (port/debugger-failure port (message-arguments->string objects))) -(define (default/debugger-failure message) - (beep) - (default/debugger-message message)) - -(define (debugger-message . objects) - (hook/debugger-message (message-arguments->string objects))) - -(define (default/debugger-message message) - (newline) - (write-string message)) +(define (debugger-message port . objects) + (port/debugger-message port (message-arguments->string objects))) (define (message-arguments->string objects) (apply string-append (map (lambda (x) (if (string? x) x (write-to-string x))) objects))) -(define (presentation thunk) - (hook/presentation thunk)) - -(define (default/presentation thunk) - (newline) - (thunk)) \ No newline at end of file +(define (debugger-presentation port thunk) + (port/debugger-presentation port thunk)) \ No newline at end of file diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index 41e24207e..28d28089c 100644 --- a/v7/src/runtime/debug.scm +++ b/v7/src/runtime/debug.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.30 1991/08/28 22:30:31 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.31 1991/11/26 07:05:17 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -61,29 +61,29 @@ MIT in each case. |# (letter-commands command-set (cmdl-message/active - (lambda (cmdl) - cmdl - (presentation - (lambda () - (let ((n (count-subproblems dstate))) - (write-string "There ") - (write-string (if (= n 1) "is" "are")) - (write-string " ") - (if (> n debugger:count-subproblems-limit) - (begin - (write-string "more than ") - (write debugger:count-subproblems-limit)) - (write n)) - (write-string " subproblem") - (if (not (= n 1)) - (write-string "s"))) - (write-string " on the stack.") - (newline) - (newline) - (print-subproblem dstate))) + (lambda (port) + (debugger-presentation port + (lambda () + (let ((n (count-subproblems dstate))) + (write-string "There " port) + (write-string (if (= n 1) "is" "are") port) + (write-string " " port) + (if (> n debugger:count-subproblems-limit) + (begin + (write-string "more than " port) + (write debugger:count-subproblems-limit port)) + (write n port)) + (write-string " subproblem" port) + (if (not (= n 1)) + (write-string "s" port))) + (write-string " on the stack." port) + (newline port) + (newline port) + (print-subproblem dstate port))) (debugger-message + port "You are now in the debugger. Type q to quit, ? for commands."))) - "Debug-->" + "debug>" dstate))))) (define (make-initial-dstate object) @@ -111,7 +111,8 @@ MIT in each case. |# ((stack-frame? object) (make-dstate object false)) (else - (error:wrong-type-argument object "condition or continuation" + (error:wrong-type-argument object + "condition or continuation" 'DEBUG))))) (define (count-subproblems dstate) @@ -201,211 +202,222 @@ MIT in each case. |# unspecific) (define command-set) + +(define-macro (define-command bvl . body) + (let ((dstate (cadr bvl)) + (port (caddr bvl))) + `(DEFINE (,(car bvl) #!OPTIONAL ,dstate ,port) + (LET ((,dstate (IF (DEFAULT-OBJECT? ,dstate) *DSTATE* ,dstate)) + (,port (IF (DEFAULT-OBJECT? ,port) *PORT* ,port))) + ,@body)))) -(define (command/print-subproblem-or-reduction dstate) - (if (dstate/reduction-number dstate) - (command/print-reduction dstate) - (command/print-subproblem dstate))) +;;;; Display commands -(define (command/print-subproblem dstate) - (presentation (lambda () (print-subproblem dstate)))) +(define-command (command/print-subproblem-or-reduction dstate port) + (if (dstate/reduction-number dstate) + (command/print-reduction dstate port) + (command/print-subproblem dstate port))) + +(define-command (command/print-subproblem dstate port) + (debugger-presentation port + (lambda () + (print-subproblem dstate port)))) + +(define-command (command/print-reduction dstate port) + (debugger-presentation port + (lambda () + (print-reduction (dstate/reduction dstate) + (dstate/subproblem-number dstate) + (dstate/reduction-number dstate) + port)))) + +(define-command (command/print-reductions dstate port) + (let ((reductions (dstate/reductions dstate)) + (subproblem-level (dstate/subproblem-number dstate))) + (if (pair? reductions) + (debugger-presentation port + (lambda () + (write-string "Execution history for this subproblem:" port) + (let loop ((reductions reductions) (number 0)) + (newline port) + (write-string "----------------------------------------" port) + (newline port) + (print-reduction (car reductions) subproblem-level number port) + (if (pair? (cdr reductions)) + (loop (cdr reductions) (1+ number)))))) + (debugger-failure + port + "There is no execution history for this subproblem.")))) -(define (print-subproblem-identification dstate) +(define-command (command/print-expression dstate port) + (debugger-presentation port + (lambda () + (let ((expression (dstate/expression dstate))) + (cond ((debugging-info/compiled-code? expression) + (write-string ";compiled code" port)) + ((not (debugging-info/undefined-expression? expression)) + (pretty-print expression port true 0)) + ((debugging-info/noise? expression) + (write-string ";" port) + (write-string ((debugging-info/noise expression) false) port)) + (else + (write-string ";undefined expression" port))))))) + +(define-command (command/print-environment-procedure dstate port) + (with-current-environment dstate port + (lambda (environment) + (show-environment-procedure environment port)))) + +(define (print-subproblem dstate port) + (print-subproblem-identification dstate port) + (newline port) + (print-subproblem-expression dstate port) + (print-subproblem-environment dstate port) + (print-subproblem-reduction dstate port)) + +(define (print-subproblem-identification dstate port) (let ((subproblem (dstate/subproblem dstate))) - (write-string "Subproblem level: ") + (write-string "Subproblem level: " port) (let ((level (dstate/subproblem-number dstate)) (qualify-level (lambda (adjective) - (write-string " (this is the ") - (write-string adjective) - (write-string " subproblem level)")))) - (write level) + (write-string " (this is the " port) + (write-string adjective port) + (write-string " subproblem level)" port)))) + (write level port) (cond ((not (stack-frame/next-subproblem subproblem)) (qualify-level (if (zero? level) "only" "highest"))) ((zero? level) (qualify-level "lowest")))))) -(define (print-subproblem-environment dstate) - (let ((environment-list (dstate/environment-list dstate))) - (if (pair? environment-list) - (print-environment (car environment-list)) - (begin - (newline) - (write-string "There is no current environment."))))) - -(define (print-subproblem-reduction dstate) - (let ((n-reductions (dstate/number-of-reductions dstate))) - (newline) - (if (positive? n-reductions) - (begin - (write-string - "The execution history for this subproblem contains ") - (write n-reductions) - (write-string " reduction") - (if (> n-reductions 1) - (write-string "s")) - (write-string ".")) - (write-string - "There is no execution history for this subproblem.")))) - -(define (print-subproblem-expression dstate) +(define (print-subproblem-expression dstate port) (let ((expression (dstate/expression dstate)) (subproblem (dstate/subproblem dstate))) (cond ((not (invalid-expression? expression)) - (write-string - (if (stack-frame/compiled-code? subproblem) - "Compiled code expression (from stack):" - "Expression (from stack):")) - (newline) + (write-string (if (stack-frame/compiled-code? subproblem) + "Compiled code expression (from stack):" + "Expression (from stack):") + port) + (newline port) (let ((subexpression (dstate/subexpression dstate))) (if (or (debugging-info/undefined-expression? subexpression) (debugging-info/unknown-expression? subexpression)) - (debugger-pp expression expression-indentation) + (debugger-pp expression expression-indentation port) (begin (debugger-pp (unsyntax-with-substitutions expression (list (cons subexpression subexpression-marker))) - expression-indentation) - (newline) - (write-string " subproblem being executed (marked by ") - (write subexpression-marker) - (write-string "):") - (newline) - (debugger-pp subexpression expression-indentation))))) + expression-indentation + port) + (newline port) + (write-string " subproblem being executed (marked by " port) + (write subexpression-marker port) + (write-string "):" port) + (newline port) + (debugger-pp subexpression expression-indentation port))))) ((debugging-info/noise? expression) - (write-string ((debugging-info/noise expression) true))) + (write-string ((debugging-info/noise expression) true) port)) (else - (write-string - (if (stack-frame/compiled-code? subproblem) - "Compiled code expression unknown" - "Expression unknown")) - (newline) - (write (stack-frame/return-address subproblem)))))) - -(define (print-subproblem dstate) - (print-subproblem-identification dstate) - (newline) - (print-subproblem-expression dstate) - (print-subproblem-environment dstate) - (print-subproblem-reduction dstate)) + (write-string (if (stack-frame/compiled-code? subproblem) + "Compiled code expression unknown" + "Expression unknown") + port) + (newline port) + (write (stack-frame/return-address subproblem) port))))) (define subexpression-marker (string->symbol "###")) - -(define (command/print-reductions dstate) - (let ((reductions (dstate/reductions dstate)) - (subproblem-level (dstate/subproblem-number dstate))) - (if (pair? reductions) - (presentation - (lambda () - (write-string "Execution history for this subproblem:") - (let loop ((reductions reductions) (number 0)) - (newline) - (write-string "----------------------------------------") - (newline) - (print-reduction (car reductions) subproblem-level number) - (if (pair? (cdr reductions)) - (loop (cdr reductions) (1+ number)))))) - (debugger-failure - "There is no execution history for this subproblem.")))) -(define (command/print-reduction dstate) - (presentation - (lambda () - (print-reduction (dstate/reduction dstate) - (dstate/subproblem-number dstate) - (dstate/reduction-number dstate))))) - -(define (print-reduction-identification subproblem-number reduction-number) - (write-string "Subproblem level: ") - (write subproblem-number) - (write-string " Reduction number: ") - (write reduction-number)) - -(define (print-reduction-expression reduction) - (write-string "Expression (from execution history):") - (newline) - (debugger-pp (reduction-expression reduction) expression-indentation)) - -(define (print-reduction-environment reduction) - (print-environment (reduction-environment reduction))) - -(define (print-reduction reduction subproblem-number reduction-number) - (print-reduction-identification subproblem-number reduction-number) - (newline) - (print-reduction-expression reduction) - (print-reduction-environment reduction)) - -(define (print-environment environment) - (newline) - (show-environment-name environment) +(define (print-subproblem-environment dstate port) + (let ((environment-list (dstate/environment-list dstate))) + (if (pair? environment-list) + (print-environment (car environment-list) port) + (begin + (newline port) + (write-string "There is no current environment." port))))) + +(define (print-subproblem-reduction dstate port) + (let ((n-reductions (dstate/number-of-reductions dstate))) + (newline port) + (if (positive? n-reductions) + (begin + (write-string "The execution history for this subproblem contains " + port) + (write n-reductions port) + (write-string " reduction" port) + (if (> n-reductions 1) + (write-string "s" port)) + (write-string "." port)) + (write-string "There is no execution history for this subproblem." + port)))) + +(define (print-reduction reduction subproblem-number reduction-number port) + (print-reduction-identification subproblem-number reduction-number port) + (newline port) + (print-reduction-expression reduction port) + (print-reduction-environment reduction port)) + +(define (print-reduction-identification subproblem-number reduction-number + port) + (write-string "Subproblem level: " port) + (write subproblem-number port) + (write-string " Reduction number: " port) + (write reduction-number port)) + +(define (print-reduction-expression reduction port) + (write-string "Expression (from execution history):" port) + (newline port) + (debugger-pp (reduction-expression reduction) expression-indentation port)) + +(define (print-reduction-environment reduction port) + (print-environment (reduction-environment reduction) port)) + +(define (print-environment environment port) + (newline port) + (show-environment-name environment port) (if (not (environment->package environment)) (begin - (newline) + (newline port) (let ((arguments (environment-arguments environment))) (if (eq? arguments 'UNKNOWN) - (show-environment-bindings environment true) + (show-environment-bindings environment true port) (begin - (write-string " applied to: ") + (write-string " applied to: " port) (write-string (cdr (write-to-string arguments - (- (output-port/x-size (current-output-port)) 11)))))))))) - -(define (debugger-pp expression indentation) - (fluid-let ((*unparser-list-depth-limit* debugger:list-depth-limit) - (*unparser-list-breadth-limit* debugger:list-breadth-limit) - (*unparser-string-length-limit* debugger:string-length-limit)) - (pretty-print expression (current-output-port) true indentation))) - -(define expression-indentation 4) - -(define (command/print-expression dstate) - (presentation - (lambda () - (let ((expression (dstate/expression dstate))) - (cond ((debugging-info/compiled-code? expression) - (write-string ";compiled code")) - ((not (debugging-info/undefined-expression? expression)) - (pretty-print expression (current-output-port) true 0)) - ((debugging-info/noise? expression) - (write-string ";") - (write-string ((debugging-info/noise expression) false))) - (else - (write-string ";undefined expression"))))))) - -(define (command/print-environment-procedure dstate) - (with-current-environment dstate show-environment-procedure)) + (- (output-port/x-size port) 11))) + port))))))) -;;;; Short subproblem display +;;;; Subproblem summary -(define (command/summarize-subproblems dstate) +(define-command (command/summarize-subproblems dstate port) (let ((top-subproblem (let ((previous-subproblems (dstate/previous-subproblems dstate))) (if (null? previous-subproblems) (dstate/subproblem dstate) (car (last-pair previous-subproblems)))))) - (presentation - (lambda () - (write-string "SL# Procedure-name Expression") - (newline) - (let loop ((frame top-subproblem) (level 0)) - (if frame - (begin - (with-values - (lambda () (stack-frame/debugging-info frame)) - (lambda (expression environment subexpression) - subexpression - (terse-print-expression level - expression - environment))) - (loop (stack-frame/next-subproblem frame) (1+ level))))))))) - -(define (terse-print-expression level expression environment) - (newline) - (write-string (string-pad-right (number->string level) 4)) - (write-string " ") + (debugger-presentation port + (lambda () + (write-string "SL# Procedure-name Expression" port) + (newline port) + (let loop ((frame top-subproblem) (level 0)) + (if frame + (begin + (with-values (lambda () (stack-frame/debugging-info frame)) + (lambda (expression environment subexpression) + subexpression + (terse-print-expression level + expression + environment + port))) + (loop (stack-frame/next-subproblem frame) (1+ level))))))))) + +(define (terse-print-expression level expression environment port) + (newline port) + (write-string (string-pad-right (number->string level) 4) port) + (write-string " " port) (write-string (string-pad-right (let ((name @@ -414,9 +426,12 @@ MIT in each case. |# (if (or (not name) (special-form-procedure-name? name)) "" - (output-to-string 20 (lambda () (write-dbg-name name))))) - 20)) - (write-string " ") + (output-to-string 20 + (lambda () + (write-dbg-name name (current-output-port)))))) + 20) + port) + (write-string " " port) (write-string (cond ((debugging-info/compiled-code? expression) ";compiled code") @@ -432,15 +447,16 @@ MIT in each case. |# (lambda () (write-string ((debugging-info/noise expression) false))))) (else - ";undefined expression")))) + ";undefined expression")) + port)) ;;;; Subproblem motion -(define (command/earlier-subproblem dstate) - (maybe-stop-using-history! dstate) - (earlier-subproblem dstate false finish-move-to-subproblem!)) +(define-command (command/earlier-subproblem dstate port) + (maybe-stop-using-history! dstate port) + (earlier-subproblem dstate port false finish-move-to-subproblem!)) -(define (earlier-subproblem dstate reason if-successful) +(define (earlier-subproblem dstate port reason if-successful) (let ((subproblem (dstate/subproblem dstate))) (let ((next (stack-frame/next-subproblem subproblem))) (if next @@ -449,34 +465,36 @@ MIT in each case. |# dstate next (cons subproblem (dstate/previous-subproblems dstate))) - (if-successful dstate)) + (if-successful dstate port)) (debugger-failure + port (reason+message (or reason "no more subproblems") "already at highest subproblem level.")))))) -(define (command/later-subproblem dstate) - (maybe-stop-using-history! dstate) - (later-subproblem dstate false finish-move-to-subproblem!)) +(define-command (command/later-subproblem dstate port) + (maybe-stop-using-history! dstate port) + (later-subproblem dstate port false finish-move-to-subproblem!)) -(define (later-subproblem dstate reason if-successful) +(define (later-subproblem dstate port reason if-successful) (if (null? (dstate/previous-subproblems dstate)) (debugger-failure + port (reason+message reason "already at lowest subproblem level.")) (begin (let ((p (dstate/previous-subproblems dstate))) (set-current-subproblem! dstate (car p) (cdr p))) - (if-successful dstate)))) + (if-successful dstate port)))) -(define (command/goto dstate) - (maybe-stop-using-history! dstate) - (let ((subproblems (select-subproblem dstate))) +(define-command (command/goto dstate port) + (maybe-stop-using-history! dstate port) + (let ((subproblems (select-subproblem dstate port))) (set-current-subproblem! dstate (car subproblems) (cdr subproblems))) - (finish-move-to-subproblem! dstate)) + (finish-move-to-subproblem! dstate port)) -(define (select-subproblem dstate) +(define (select-subproblem dstate port) (let top-level-loop () (let ((delta - (- (prompt-for-nonnegative-integer "Subproblem number" false) + (- (prompt-for-nonnegative-integer "Subproblem number" false port) (dstate/subproblem-number dstate)))) (if (negative? delta) (list-tail (dstate/previous-subproblems dstate) (-1+ (- delta))) @@ -491,51 +509,19 @@ MIT in each case. |# (loop next (cons subproblem subproblems) (-1+ delta)) (begin (debugger-failure + port "Subproblem number too large (limit is " (length subproblems) " inclusive).") (top-level-loop)))))))))) -(define (prompt-for-nonnegative-integer prompt limit) - (prompt-for-integer prompt 0 limit)) - -(define (prompt-for-integer prompt lower upper) - (let loop () - (let ((expression - (prompt-for-expression - (string-append - prompt - (if lower - (if upper - (string-append " (" (number->string lower) - " through " - (number->string (- upper 1)) - " inclusive)") - (string-append " (minimum " (number->string lower) ")")) - (if upper - (string-append " (maximum " - (number->string (- upper 1)) - ")") - "")))))) - (cond ((not (exact-integer? expression)) - (debugger-failure prompt " must be exact integer.") - (loop)) - ((and lower (< expression lower)) - (debugger-failure prompt " too small.") - (loop)) - ((and upper (>= expression upper)) - (debugger-failure prompt " too large.") - (loop)) - (else - expression))))) - ;;;; Reduction motion -(define (command/earlier-reduction dstate) - (maybe-start-using-history! dstate) +(define-command (command/earlier-reduction dstate port) + (maybe-start-using-history! dstate port) (let ((up (lambda () - (earlier-subproblem dstate false finish-move-to-subproblem!)))) + (earlier-subproblem dstate port false finish-move-to-subproblem!)))) (if (not (dstate/using-history? dstate)) (up) (let ((n-reductions (dstate/number-of-reductions dstate)) @@ -544,42 +530,46 @@ MIT in each case. |# (lambda (reason) (earlier-subproblem dstate + port reason - (lambda (dstate) + (lambda (dstate port) (debugger-message + port (reason+message reason "going to the next (less recent) subproblem.")) - (finish-move-to-subproblem! dstate)))))) + (finish-move-to-subproblem! dstate port)))))) (cond ((zero? n-reductions) (up)) ((not reduction-number) - (move-to-reduction! dstate 0)) + (move-to-reduction! dstate port 0)) ((and (< reduction-number (-1+ n-reductions)) (not (and debugger:student-walk? (positive? (dstate/subproblem-number dstate)) (= reduction-number 0)))) - (move-to-reduction! dstate (1+ reduction-number))) + (move-to-reduction! dstate port (1+ reduction-number))) (debugger:student-walk? (up)) (else (wrap "no more reductions"))))))) - -(define (command/later-reduction dstate) - (maybe-start-using-history! dstate) + +(define-command (command/later-reduction dstate port) + (maybe-start-using-history! dstate port) (let ((down (lambda () - (later-subproblem dstate false finish-move-to-subproblem!)))) + (later-subproblem dstate port false finish-move-to-subproblem!)))) (if (not (dstate/using-history? dstate)) - (later-subproblem dstate false finish-move-to-subproblem!) + (later-subproblem dstate port false finish-move-to-subproblem!) (let ((reduction-number (dstate/reduction-number dstate)) (wrap (lambda (reason) (later-subproblem dstate + port reason - (lambda (dstate) + (lambda (dstate port) (debugger-message + port (reason+message reason "going to the previous (more recent) subproblem.")) @@ -587,25 +577,26 @@ MIT in each case. |# (if (and n (positive? n)) (move-to-reduction! dstate + port (if (and debugger:student-walk? (positive? (dstate/subproblem-number dstate))) 0 (-1+ n))) - (finish-move-to-subproblem! dstate)))))))) + (finish-move-to-subproblem! dstate port)))))))) (cond ((zero? (dstate/number-of-reductions dstate)) (down)) ((not reduction-number) (wrap false)) ((positive? reduction-number) - (move-to-reduction! dstate (-1+ reduction-number))) + (move-to-reduction! dstate port (-1+ reduction-number))) ((special-history-subproblem? dstate) ;; Reset state (set-current-subproblem! dstate (dstate/subproblem dstate) (dstate/previous-subproblems dstate)) (set-dstate/reduction-number! dstate false) - (command/print-subproblem dstate)) + (command/print-subproblem dstate port)) (debugger:student-walk? (down)) (else @@ -613,79 +604,81 @@ MIT in each case. |# ;;;; Environment motion and display -(define (command/show-current-frame dstate) +(define-command (command/show-current-frame dstate port) (if (pair? (dstate/environment-list dstate)) - (show-current-frame dstate false) - (undefined-environment))) + (show-current-frame dstate false port) + (undefined-environment port))) -(define (command/show-all-frames dstate) +(define-command (command/show-all-frames dstate port) (let ((environment-list (dstate/environment-list dstate))) (if (pair? environment-list) - (show-frames (car (last-pair environment-list)) 0) - (undefined-environment)))) + (show-frames (car (last-pair environment-list)) 0 port) + (undefined-environment port)))) -(define (command/move-to-parent-environment dstate) +(define-command (command/move-to-parent-environment dstate port) (let ((environment-list (dstate/environment-list dstate))) (cond ((not (pair? environment-list)) - (undefined-environment)) + (undefined-environment port)) ((eq? true (environment-has-parent? (car environment-list))) (set-dstate/environment-list! dstate (cons (environment-parent (car environment-list)) environment-list)) - (show-current-frame dstate true)) + (show-current-frame dstate true port)) (else - (debugger-failure "The current environment has no parent."))))) + (debugger-failure port "The current environment has no parent."))))) -(define (command/move-to-child-environment dstate) +(define-command (command/move-to-child-environment dstate port) (let ((environment-list (dstate/environment-list dstate))) (cond ((not (pair? (dstate/environment-list dstate))) - (undefined-environment)) + (undefined-environment port)) ((not (pair? (cdr environment-list))) (debugger-failure + port "This is the initial environment; can't move to child.")) (else (set-dstate/environment-list! dstate (cdr environment-list)) - (show-current-frame dstate true))))) - -(define (show-current-frame dstate brief?) - (presentation - (lambda () - (let ((environment-list (dstate/environment-list dstate))) - (show-frame (car environment-list) - (length (cdr environment-list)) - brief?))))) - -(define (command/enter-read-eval-print-loop dstate) - (debug/read-eval-print (get-evaluation-environment dstate) + (show-current-frame dstate true port))))) + +(define (show-current-frame dstate brief? port) + (debugger-presentation port + (lambda () + (let ((environment-list (dstate/environment-list dstate))) + (show-frame (car environment-list) + (length (cdr environment-list)) + brief? + port))))) + +(define-command (command/enter-read-eval-print-loop dstate port) + (debug/read-eval-print (get-evaluation-environment dstate port) "the debugger" - "the desired environment" - "Eval-in-env-->")) + "the environment for this frame")) -(define (command/eval-in-current-environment dstate) - (debug/read-eval-print-1 (get-evaluation-environment dstate))) +(define-command (command/eval-in-current-environment dstate port) + (debug/read-eval-print-1 (get-evaluation-environment dstate port) port)) -(define (command/enter-where dstate) - (with-current-environment dstate debug/where)) +(define-command (command/enter-where dstate port) + port + (with-current-environment dstate port debug/where)) ;;;; Condition commands -(define (command/condition-report dstate) +(define-command (command/condition-report dstate port) (let ((condition (dstate/condition dstate))) (if condition - (presentation - (lambda () - (write-condition-report condition (current-output-port)))) - (debugger-failure "No condition to report.")))) + (debugger-presentation port + (lambda () + (write-condition-report condition port))) + (debugger-failure port "No condition to report.")))) -(define (command/condition-restart dstate) +(define-command (command/condition-restart dstate port) (let ((restarts (let ((condition (dstate/condition dstate))) (if condition (condition/restarts condition) (bound-restarts))))) (if (null? restarts) - (debugger-failure "No options to choose from.") + (debugger-failure port "No options to choose from.") (let ((n-restarts (length restarts)) (write-index (lambda (index port) @@ -695,34 +688,38 @@ MIT in each case. |# (lambda (n) (invoke-restart-interactively (list-ref restarts (- n-restarts n)))))) - (presentation - (lambda () - (let ((port (current-output-port))) - (if (= n-restarts 1) - (begin - (write-string "There is only one option:" port) - (write-restarts restarts port write-index) - (if (prompt-for-confirmation "Use this option") - (invoke-option 1))) - (begin - (write-string "Choose an option by number:" port) - (write-restarts restarts port write-index) - (invoke-option - (prompt-for-integer "Option number" - 1 - (+ n-restarts 1))))))))))))) + (debugger-presentation port + (lambda () + (if (= n-restarts 1) + (begin + (write-string "There is only one option:" port) + (write-restarts restarts port write-index) + (if (prompt-for-confirmation "Use this option" port) + (invoke-option 1))) + (begin + (write-string "Choose an option by number:" port) + (write-restarts restarts port write-index) + (invoke-option + (prompt-for-integer "Option number" + 1 + (+ n-restarts 1) + port))))))))))) ;;;; Advanced hacking commands -(define hook/debugger-before-return) +(define-command (command/return-from dstate port) + (let ((next (stack-frame/next-subproblem (dstate/subproblem dstate)))) + (if next + (enter-subproblem dstate port next) + (debugger-failure port "Can't continue!!!")))) -(define (default/debugger-before-return) - '()) +(define-command (command/return-to dstate port) + (enter-subproblem dstate port (dstate/subproblem dstate))) -(define (enter-subproblem subproblem dstate) +(define (enter-subproblem dstate port subproblem) (let ((invalid-expression? (invalid-expression? (dstate/expression dstate))) - (environment (get-evaluation-environment dstate)) + (environment (get-evaluation-environment dstate port)) (return (lambda (value) (hook/debugger-before-return) @@ -734,7 +731,8 @@ MIT in each case. |# "Expression to EVALUATE and CONTINUE with" (if invalid-expression? "" - " ($ to retry)"))))) + " ($ to retry)")) + port))) (if (and (not invalid-expression?) (eq? expression '$)) (debug/scode-eval (dstate/expression dstate) @@ -742,57 +740,55 @@ MIT in each case. |# (debug/eval expression environment))))) (if debugger:print-return-values? (begin - (newline) - (write-string "That evaluates to:") - (newline) - (write value) - (if (prompt-for-confirmation "Confirm") (return value))) + (newline port) + (write-string "That evaluates to:" port) + (newline port) + (write value port) + (if (prompt-for-confirmation "Confirm" port) (return value))) (return value))))) -(define (command/return-from dstate) - (let ((next (stack-frame/next-subproblem (dstate/subproblem dstate)))) - (if next - (enter-subproblem next dstate) - (debugger-failure "Can't continue!!!")))) - -(define (command/return-to dstate) - (enter-subproblem (dstate/subproblem dstate) dstate)) +(define hook/debugger-before-return) +(define (default/debugger-before-return) + '()) (define *dstate*) +(define *port*) -(define (command/internal dstate) - (fluid-let ((*dstate* dstate)) +(define (command/internal dstate port) + (fluid-let ((*dstate* dstate) + (*port* port)) (debug/read-eval-print (->environment '(RUNTIME DEBUGGER)) "the debugger" - "the debugger environment" - "Debugger-->"))) - -(define (command/frame dstate) - (presentation - (lambda () - (write-string "Stack frame: ") - (write (dstate/subproblem dstate)) - (for-each (lambda (element) - (newline) - (debugger-pp element 0)) - (named-structure/description (dstate/subproblem dstate)))))) + "the debugger environment"))) + +(define-command (command/frame dstate port) + (debugger-presentation port + (lambda () + (write-string "Stack frame: " port) + (write (dstate/subproblem dstate) port) + (for-each (lambda (element) + (newline port) + (debugger-pp element 0 port)) + (named-structure/description (dstate/subproblem dstate)))))) ;;;; Low-level Side-effects -(define (maybe-start-using-history! dstate) +(define (maybe-start-using-history! dstate port) (if (eq? 'ENABLED (dstate/history-state dstate)) (begin (set-dstate/history-state! dstate 'NOW) (if (not (zero? (dstate/number-of-reductions dstate))) (debugger-message + port "Now using information from the execution history."))))) -(define (maybe-stop-using-history! dstate) +(define (maybe-stop-using-history! dstate port) (if (eq? 'NOW (dstate/history-state dstate)) (begin (set-dstate/history-state! dstate 'ENABLED) (if (not (zero? (dstate/number-of-reductions dstate))) (debugger-message + port "Now ignoring information from the execution history."))))) (define (dstate/using-history? dstate) @@ -819,21 +815,21 @@ MIT in each case. |# '() (list environment)))))) -(define (finish-move-to-subproblem! dstate) +(define (finish-move-to-subproblem! dstate port) (if (and (dstate/using-history? dstate) (positive? (dstate/number-of-reductions dstate)) (not (special-history-subproblem? dstate))) - (move-to-reduction! dstate 0) + (move-to-reduction! dstate port 0) (begin (set-dstate/reduction-number! dstate false) - (command/print-subproblem dstate)))) + (command/print-subproblem dstate port)))) -(define (move-to-reduction! dstate reduction-number) +(define (move-to-reduction! dstate port reduction-number) (set-dstate/reduction-number! dstate reduction-number) (set-dstate/environment-list! dstate (list (reduction-environment (dstate/reduction dstate)))) - (command/print-reduction dstate)) + (command/print-reduction dstate port)) (define (special-history-subproblem? dstate) (eq? (stack-frame/type (dstate/subproblem dstate)) @@ -868,25 +864,68 @@ MIT in each case. |# (or (debugging-info/undefined-expression? expression) (debugging-info/compiled-code? expression))) -(define (get-evaluation-environment dstate) +(define (get-evaluation-environment dstate port) (let ((environment-list (dstate/environment-list dstate))) (if (and (pair? environment-list) (environment? (car environment-list))) (car environment-list) (begin (debugger-message + port "Cannot evaluate in current environment; using the read-eval-print environment instead.") (nearest-repl/environment))))) -(define (with-current-environment dstate receiver) +(define (with-current-environment dstate port receiver) (let ((environment-list (dstate/environment-list dstate))) (if (pair? environment-list) (receiver (car environment-list)) - (undefined-environment)))) + (undefined-environment port)))) -(define (undefined-environment) - (debugger-failure "There is no current environment.")) +(define (undefined-environment port) + (debugger-failure port "There is no current environment.")) (define (reason+message reason message) - (string-capitalize (if reason (string-append reason "; " message) message))) \ No newline at end of file + (string-capitalize (if reason (string-append reason "; " message) message))) + +(define (debugger-pp expression indentation port) + (fluid-let ((*unparser-list-depth-limit* debugger:list-depth-limit) + (*unparser-list-breadth-limit* debugger:list-breadth-limit) + (*unparser-string-length-limit* debugger:string-length-limit)) + (pretty-print expression port true indentation))) + +(define expression-indentation 4) + +(define (prompt-for-nonnegative-integer prompt limit port) + (prompt-for-integer prompt 0 limit port)) + +(define (prompt-for-integer prompt lower upper port) + (let loop () + (let ((expression + (prompt-for-expression + (string-append + prompt + (if lower + (if upper + (string-append " (" (number->string lower) + " through " + (number->string (- upper 1)) + " inclusive)") + (string-append " (minimum " (number->string lower) ")")) + (if upper + (string-append " (maximum " + (number->string (- upper 1)) + ")") + ""))) + port))) + (cond ((not (exact-integer? expression)) + (debugger-failure port prompt " must be exact integer.") + (loop)) + ((and lower (< expression lower)) + (debugger-failure port prompt " too small.") + (loop)) + ((and upper (>= expression upper)) + (debugger-failure port prompt " too large.") + (loop)) + (else + expression))))) \ No newline at end of file diff --git a/v7/src/runtime/ed-ffi.scm b/v7/src/runtime/ed-ffi.scm index 192816382..230136fde 100644 --- a/v7/src/runtime/ed-ffi.scm +++ b/v7/src/runtime/ed-ffi.scm @@ -4,8 +4,6 @@ (standard-scheme-find-file-initialization '#( - ("Sgraph" (runtime starbase-graphics) - syntax-table/system-internal) ("advice" (runtime advice) syntax-table/system-internal) ("arith" (runtime number) @@ -48,9 +46,7 @@ syntax-table/system-internal) ("events" (runtime event-distributor) syntax-table/system-internal) - ("filein" (runtime file-input) - syntax-table/system-internal) - ("filout" (runtime file-output) + ("fileio" (runtime file-i/o-port) syntax-table/system-internal) ("fixart" () syntax-table/system-internal) @@ -68,9 +64,7 @@ syntax-table/system-internal) ("gdatab" (runtime global-database) syntax-table/system-internal) - ("genin" (runtime generic-input) - syntax-table/system-internal) - ("genout" (runtime generic-output) + ("genio" (runtime generic-i/o-port) syntax-table/system-internal) ("gensym" (runtime gensym) syntax-table/system-internal) @@ -124,6 +118,8 @@ syntax-table/system-internal) ("poplat" (runtime population) syntax-table/system-internal) + ("port" (runtime port) + syntax-table/system-internal) ("pp" (runtime pretty-printer) syntax-table/system-internal) ("prgcop" (runtime program-copier) @@ -182,9 +178,7 @@ syntax-table/system-internal) ("tscript" (runtime transcript) syntax-table/system-internal) - ("ttyin" (runtime console-input) - syntax-table/system-internal) - ("ttyout" (runtime console-output) + ("ttyio" (runtime console-i/o-port) syntax-table/system-internal) ("udata" () syntax-table/system-internal) @@ -196,8 +190,6 @@ syntax-table/system-internal) ("unsyn" (runtime unsyntaxer) syntax-table/system-internal) - ("unxcwd" (runtime working-directory) - syntax-table/system-internal) ("unxdir" (runtime directory) syntax-table/system-internal) ("unxprm" () @@ -208,6 +200,8 @@ syntax-table/system-internal) ("urtrap" (runtime reference-trap) syntax-table/system-internal) + ("usrint" (runtime user-interface) + syntax-table/system-internal) ("utabs" (runtime microcode-tables) syntax-table/system-internal) ("vector" () diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm index 59b80355b..9cf35aaa3 100644 --- a/v7/src/runtime/emacs.scm +++ b/v7/src/runtime/emacs.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.9 1991/11/04 20:28:37 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.10 1991/11/26 07:05:34 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -32,269 +32,260 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; GNU Emacs/Scheme Modeline Interface +;;;; GNU Emacs/Scheme Interface ;;; package: (runtime emacs-interface) (declare (usual-integrations)) -(define (transmit-signal type) - (write-char #\Altmode console-output-port) - (write-char type console-output-port)) - -(define (transmit-signal-without-gc type) - (with-absolutely-no-interrupts - (lambda () - (transmit-signal type)))) - -(define (transmit-signal-with-argument type string) - (with-absolutely-no-interrupts - (lambda () - (transmit-signal type) - (write-string string console-output-port) - (write-char #\Altmode console-output-port)))) - -(define (object->string object) - (with-output-to-string - (lambda () - (write object)))) - -(define (emacs/read-start) - (transmit-signal-without-gc #\s)) - -(define (emacs/read-finish) - (transmit-signal-without-gc #\f)) - -(define (emacs/gc-start) - (transmit-signal #\b) - (normal/gc-start)) - -(define (emacs/gc-finish start-value space-remaining) - (transmit-signal #\e) - (normal/gc-finish start-value space-remaining)) - -(define (emacs/repl-read repl) - (if (cmdl/io-to-console? repl) - (begin - (transmit-signal-without-gc #\R) - (let ((s-expression (read console-input-port))) - (repl-history/record! (repl/reader-history repl) s-expression) - s-expression)) - (normal/repl-read repl))) - -(define (emacs/repl-write repl object) - (if (cmdl/io-to-console? repl) - (begin - (repl-history/record! (repl/printer-history repl) object) - (cond ((undefined-value? object) - (transmit-signal-with-argument #\v "")) - ((repl-write/show-hash? object) - ;; The #\P command used to do something useful, but now - ;; it just sets the Emacs variable `xscheme-prompt' to - ;; its string argument. We use this to advantage here. - (transmit-signal-with-argument #\P (object->string object)) - (emacs-eval - "(xscheme-write-message-1 xscheme-prompt (format \";Value " - (number->string (object-hash object)) - ": %s\" xscheme-prompt))")) - (else - (transmit-signal-with-argument #\v (object->string object))))) - (normal/repl-write repl object))) - -(define (emacs/cmdl-message cmdl string) - (if (cmdl/io-to-console? cmdl) - (transmit-signal-with-argument #\m string) - (normal/cmdl-message cmdl string))) - -(define (emacs/cmdl-prompt cmdl prompt) +;;;; Prompting + +(define (emacs/prompt-for-command-expression port prompt) + (transmit-modeline-string port prompt) + (transmit-signal port #\R) + (read port)) + +(define (emacs/prompt-for-command-char port prompt) + (transmit-modeline-string port prompt) + (transmit-signal-with-argument port #\D "") + (transmit-signal port #\o) + (read-char-internal port)) + +(define (transmit-modeline-string port prompt) (transmit-signal-with-argument + port #\p - (string-append (object->string (cmdl/level cmdl)) - " " - (let ((entry (assoc prompt cmdl-prompt-alist))) - (if entry - (cdr entry) - "[Evaluator]"))))) + (with-values (lambda () (parse-repl-prompt prompt)) + (lambda (prefix prompt) + (if prefix + (string-append prefix + (let ((entry (assoc prompt cmdl-prompt-alist))) + (if entry + (cadr entry) + "[Evaluator]"))) + prompt))))) + +(define (parse-repl-prompt prompt) + ;; If the prompt is of the form "NNN foo", then it is a REP loop + ;; prompt and should be treated specially. + (let ((end (string-length prompt))) + (let ((index + (and (> end 0) + (char-numeric? (string-ref prompt 0)) + (let skip-digits ((index 1)) + (and (< index end) + (cond ((char-numeric? (string-ref prompt index)) + (skip-digits (+ index 1))) + ((char=? #\space (string-ref prompt index)) + (let ((index (+ index 1))) + (and (< index end) + index))) + (else + false))))))) + (if index + (values (string-head prompt index) (string-tail prompt index)) + (values false prompt))))) (define cmdl-prompt-alist - '(("Debug-->" . "[Debugger]") - ("Where-->" . "[Environment Inspector]") - ("Which-->" . "[Task Inspector]"))) + '(("debug>" "[Debugger]") + ("where>" "[Environment Inspector]") + ("which>" "[Task Inspector]"))) -(define (emacs/debugger-failure message) - (beep) - (emacs-typeout message)) +(define (emacs/prompt-for-expression port prompt) + (transmit-signal-with-argument port #\i (string-append prompt ": ")) + (read port)) -(define (emacs/debugger-message message) - (emacs-typeout message)) +(define (emacs/prompt-for-confirmation port prompt) + (transmit-signal-with-argument port #\n (string-append prompt "? ")) + (char=? #\y (read-char-internal port))) -(define (emacs/presentation thunk) - (newline) +(define (read-char-internal port) + (transmit-signal port #\s) + (let loop () + (let ((char (input-port/read-char port))) + (if (char=? char #\newline) + (loop) + (begin + (transmit-signal port #\f) + char))))) + +;;;; Debugger Support + +(define (emacs/debugger-failure port message) + (beep port) + (emacs-typeout port message)) + +(define (emacs/debugger-message port message) + (emacs-typeout port message)) + +(define (emacs/debugger-presentation port thunk) + (newline port) (if emacs-presentation-top-justify? (begin - (emacs-eval "(setq xscheme-temp-1 (point))") + (emacs-eval port "(setq xscheme-temp-1 (point))") (thunk) - (emacs-eval "(set-window-start (selected-window) xscheme-temp-1 nil)")) + (emacs-eval + port + "(set-window-start (selected-window) xscheme-temp-1 nil)")) (thunk))) -(define emacs-presentation-top-justify? false) +(define emacs-presentation-top-justify? + false) -(define (emacs-typeout message) - (emacs-eval "(message \"%s\" " (write-to-string message) ")")) +;;;; Interrupt Support -(define (emacs-eval . strings) - (transmit-signal-with-argument #\E (apply string-append strings))) - -(define (emacs/error-decision) - (transmit-signal-without-gc #\z) - (beep console-output-port) +(define (emacs/clean-input/flush-typeahead char) + char + (let loop () + (if (not (char=? #\NUL (input-port/read-char the-console-port))) + (loop))) + true) + +(define (emacs/^G-interrupt interrupt-mask) + interrupt-mask + (transmit-signal the-console-port #\g)) + +;;;; Miscellaneous Hooks + +(define (emacs/write-result port object hash-number) + (cond ((undefined-value? object) + (transmit-signal-with-argument port #\v "")) + (hash-number + ;; The #\P command used to do something useful, but now + ;; it just sets the Emacs variable `xscheme-prompt' to + ;; its string argument. We use this to advantage here. + (transmit-signal-with-argument port #\P (write-to-string object)) + (emacs-eval + port + "(xscheme-write-message-1 xscheme-prompt (format \";Value " + (number->string hash-number) + ": %s\" xscheme-prompt))")) + (else + (transmit-signal-with-argument port #\v (write-to-string object))))) + +(define (emacs/error-decision repl condition) + repl condition + (transmit-signal the-console-port #\z) + (beep the-console-port) (if paranoid-error-decision? (cmdl-interrupt/abort-previous))) (define paranoid-error-decision? false) -(define (emacs/^G-interrupt interrupt-enables) - (transmit-signal #\g) - (normal/^G-interrupt interrupt-enables)) - -(define (emacs/read-command-char cmdl prompt) - (if (cmdl/io-to-console? cmdl) - (begin - (transmit-signal-with-argument - #\D - (cond ((string=? "Debug-->" prompt) "Scheme-debug") - ((string=? "Where-->" prompt) "Scheme-where") - ((string=? "Which-->" prompt) "Scheme-which") - (else "Scheme"))) - (transmit-signal-without-gc #\o) - (read-char-internal)) - (normal/read-command-char cmdl prompt))) - -(define (emacs/prompt-for-confirmation cmdl prompt) - (if (cmdl/io-to-console? cmdl) - (begin - (transmit-signal-with-argument #\n (string-append prompt "? ")) - (char=? #\y (read-char-internal))) - (normal/prompt-for-confirmation cmdl prompt))) - -(define (emacs/prompt-for-expression cmdl prompt) - (if (cmdl/io-to-console? cmdl) - (begin - (transmit-signal-with-argument #\i (string-append prompt ": ")) - (read console-input-port)) - (normal/prompt-for-expression cmdl prompt))) +(define (emacs/set-default-directory port pathname) + (transmit-signal-with-argument port #\w (->namestring pathname))) -(define (read-char-internal) - (emacs/read-start) - (let loop () - (let ((char (input-port/read-char console-input-port))) - (if (char=? char char:newline) - (loop) - (begin - (emacs/read-finish) - char))))) +(define (emacs/read-start port) + (transmit-signal port #\s) + (port/read-start the-console-port)) -(define (cmdl/io-to-console? cmdl) - (and (eq? console-input-port (cmdl/input-port cmdl)) - (eq? console-output-port (cmdl/output-port cmdl)))) +(define (emacs/read-finish port) + (port/read-finish the-console-port) + (transmit-signal port #\f)) -(define (emacs/set-working-directory-pathname! pathname) - (transmit-signal-with-argument #\w (->namestring pathname))) - -(define (emacs/clean-input/flush-typeahead character) - character - (let loop () - (if (not (char=? #\NUL (input-port/read-char console-input-port))) - (loop))) - true) +(define (emacs/print-self state port) + port + (unparse-string state "for emacs")) + +;;;; Protocol Encoding + +;;; GC-light operations are special because they must not cons. +;;; On an interpreted system, they will cons a little anyway. + +(define (emacs/gc-start port) + (output-port/flush-output port) + (channel-write-block (port/output-channel port) "\033b" 0 2)) + +(define (emacs/gc-finish port) + (channel-write-block (port/output-channel port) "\033e" 0 2)) + +(define (transmit-signal port type) + (let ((channel (port/output-channel port)) + (buffer (string #\altmode type))) + (output-port/flush-output port) + (with-absolutely-no-interrupts + (lambda () + (channel-write-block channel buffer 0 2))))) + +(define (transmit-signal-with-argument port type string) + (let ((channel (port/output-channel port)) + (length (string-length string))) + (let ((buffer-length (+ length 3))) + (let ((buffer (make-string buffer-length))) + (string-set! buffer 0 #\altmode) + (string-set! buffer 1 type) + (substring-move-left! string 0 length buffer 2) + (string-set! buffer (- buffer-length 1) #\altmode) + (output-port/flush-output port) + (with-absolutely-no-interrupts + (lambda () + (channel-write-block channel buffer 0 buffer-length))))))) + +(define (emacs-typeout port message) + (emacs-eval port "(message \"%s\" " (write-to-string message) ")")) + +(define (emacs-eval port . strings) + (transmit-signal-with-argument port #\E (apply string-append strings))) -(define normal/gc-start) -(define normal/gc-finish) -(define normal/cmdl-message) -(define normal/cmdl-prompt) -(define normal/error-decision) -(define normal/repl-write) -(define normal/repl-read) -(define normal/read-start) -(define normal/read-finish) -(define normal/read-command-char) -(define normal/prompt-for-confirmation) -(define normal/prompt-for-expression) -(define normal/^G-interrupt) -(define normal/set-working-directory-pathname!) -(define normal/debugger-failure) -(define normal/debugger-message) -(define normal/presentation) -(define normal/clean-input/flush-typeahead) +;;;; Initialization + +(define emacs-console-port) +(define console-output-channel) (define (initialize-package!) - (set! normal/gc-start hook/gc-start) - (set! normal/gc-finish hook/gc-finish) - (set! normal/cmdl-message hook/cmdl-message) - (set! normal/cmdl-prompt hook/cmdl-prompt) - (set! normal/error-decision hook/error-decision) - (set! normal/repl-write hook/repl-write) - (set! normal/repl-read hook/repl-read) - (set! normal/read-start hook/read-start) - (set! normal/read-finish hook/read-finish) - (set! normal/read-command-char hook/read-command-char) - (set! normal/prompt-for-confirmation hook/prompt-for-confirmation) - (set! normal/prompt-for-expression hook/prompt-for-expression) - (set! normal/^G-interrupt hook/^G-interrupt) - (set! normal/set-working-directory-pathname! - hook/set-working-directory-pathname!) - (set! normal/debugger-failure hook/debugger-failure) - (set! normal/debugger-message hook/debugger-message) - (set! normal/presentation hook/presentation) - (set! normal/clean-input/flush-typeahead hook/clean-input/flush-typeahead) - (add-event-receiver! event:after-restore install!) - (install!)) - -(define (install!) - ((if ((ucode-primitive under-emacs? 0)) - install-emacs-hooks! - install-normal-hooks!))) - -(define (install-emacs-hooks!) - (set! hook/gc-start emacs/gc-start) - (set! hook/gc-finish emacs/gc-finish) - (set! hook/cmdl-message emacs/cmdl-message) - (set! hook/cmdl-prompt emacs/cmdl-prompt) - (set! hook/error-decision emacs/error-decision) - (set! hook/repl-write emacs/repl-write) - (set! hook/repl-read emacs/repl-read) - (set! hook/read-start emacs/read-start) - (set! hook/read-finish emacs/read-finish) - (set! hook/read-command-char emacs/read-command-char) - (set! hook/prompt-for-confirmation emacs/prompt-for-confirmation) - (set! hook/prompt-for-expression emacs/prompt-for-expression) - (set! hook/^G-interrupt emacs/^G-interrupt) - (set! hook/set-working-directory-pathname! - emacs/set-working-directory-pathname!) - (set! hook/debugger-failure emacs/debugger-failure) - (set! hook/debugger-message emacs/debugger-message) - (set! hook/presentation emacs/presentation) - (set! hook/clean-input/flush-typeahead emacs/clean-input/flush-typeahead) - unspecific) - -(define (install-normal-hooks!) - (set! hook/gc-start normal/gc-start) - (set! hook/gc-finish normal/gc-finish) - (set! hook/cmdl-message normal/cmdl-message) - (set! hook/cmdl-prompt normal/cmdl-prompt) - (set! hook/error-decision normal/error-decision) - (set! hook/repl-write normal/repl-write) - (set! hook/repl-read normal/repl-read) - (set! hook/read-start normal/read-start) - (set! hook/read-finish normal/read-finish) - (set! hook/read-command-char normal/read-command-char) - (set! hook/prompt-for-confirmation normal/prompt-for-confirmation) - (set! hook/prompt-for-expression normal/prompt-for-expression) - (set! hook/^G-interrupt normal/^G-interrupt) - (set! hook/set-working-directory-pathname! - normal/set-working-directory-pathname!) - (set! hook/debugger-failure normal/debugger-failure) - (set! hook/debugger-message normal/debugger-message) - (set! hook/presentation normal/presentation) - (set! hook/clean-input/flush-typeahead normal/clean-input/flush-typeahead) - unspecific) \ No newline at end of file + (set! emacs-console-port + (make-i/o-port + (let ((operations + `((PROMPT-FOR-EXPRESSION ,emacs/prompt-for-expression) + (PROMPT-FOR-COMMAND-CHAR ,emacs/prompt-for-command-char) + (PROMPT-FOR-COMMAND-EXPRESSION + ,emacs/prompt-for-command-expression) + (PROMPT-FOR-CONFIRMATION ,emacs/prompt-for-confirmation) + (DEBUGGER-FAILURE ,emacs/debugger-failure) + (DEBUGGER-MESSAGE ,emacs/debugger-message) + (DEBUGGER-PRESENTATION ,emacs/debugger-presentation) + (WRITE-RESULT ,emacs/write-result) + (SET-DEFAULT-DIRECTORY ,emacs/set-default-directory) + (READ-START ,emacs/read-start) + (READ-FINISH ,emacs/read-finish) + (GC-START ,emacs/gc-start) + (GC-FINISH ,emacs/gc-finish)))) + (append-map* operations + (lambda (name) + (if (assq name operations) + '() + `((,name + ,(port/operation the-console-port name))))) + (port/operation-names the-console-port))) + (port/state the-console-port))) + (set-console-i/o-port! (select-console-port)) + (add-event-receiver! event:after-restore reset-console-port!)) + +(define (reset-console-port!) + ;; This is a kludge. Maybe this method shouldn't be used. + (let ((new-port (select-console-port))) + (if (let ((port console-i/o-port)) + (or (eq? port the-console-port) + (eq? port emacs-console-port))) + (set-console-i/o-port! new-port)) + (do ((cmdl (nearest-cmdl) (cmdl/parent cmdl))) + ((not cmdl)) + (if (let ((port (cmdl/port cmdl))) + (or (eq? port the-console-port) + (eq? port emacs-console-port))) + (set-cmdl/port! cmdl new-port))))) + +(define (select-console-port) + (set! console-output-channel (port/output-channel the-console-port)) + (if ((ucode-primitive under-emacs? 0)) + (begin + (set! hook/clean-input/flush-typeahead + emacs/clean-input/flush-typeahead) + (set! hook/^G-interrupt emacs/^G-interrupt) + (set! hook/error-decision emacs/error-decision) + emacs-console-port) + (begin + (set! hook/clean-input/flush-typeahead false) + (set! hook/^G-interrupt false) + (set! hook/error-decision false) + the-console-port))) \ No newline at end of file diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index 815334874..57c5dffe9 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.28 1991/11/04 20:28:45 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.29 1991/11/26 07:05:41 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -328,25 +328,19 @@ MIT in each case. |# (define (invoke-restart restart . arguments) (guarantee-restart restart 'INVOKE-RESTART) - (apply (%restart/effector restart) arguments)) - -(define hook/before-restart) - -(define (default/before-restart) - '()) + (hook/invoke-restart (%restart/effector restart) arguments)) (define (invoke-restart-interactively restart) (guarantee-restart restart 'INVOKE-RESTART-INTERACTIVELY) - (let ((effector (%restart/effector restart)) - (interactive + (hook/invoke-restart + (%restart/effector restart) + (let ((interactive (1d-table/get (%restart/properties restart) 'INTERACTIVE false))) - (if (not interactive) - (begin (hook/before-restart) - (effector)) - (with-values interactive - (lambda vals - (hook/before-restart) - (apply effector vals)))))) + (if (not interactive) + '() + (with-values interactive list))))) + +(define hook/invoke-restart) (define (bound-restarts) (let loop ((restarts *bound-restarts*)) @@ -516,16 +510,16 @@ MIT in each case. |# (if hook (fluid-let ((standard-error-hook false)) (hook condition)))) - (push-repl false condition "Error->")) + (repl/start (push-repl 'INHERIT 'INHERIT condition '() "error>"))) (define (standard-warning-handler condition) (let ((hook standard-warning-hook)) (if hook (fluid-let ((standard-warning-hook false)) (hook condition)) - (let ((port (nearest-cmdl/output-port))) - (newline port) - (write-string "Warning: " port) + (let ((port (nearest-cmdl/port))) + (fresh-line port) + (write-string ";Warning: " port) (write-condition-report condition port))))) (define standard-error-hook false) @@ -654,7 +648,7 @@ MIT in each case. |# (define (initialize-package!) (set! hook/invoke-condition-handler default/invoke-condition-handler) - (set! hook/before-restart default/before-restart) + (set! hook/invoke-restart apply) (set! condition-type:serious-condition (make-condition-type 'SERIOUS-CONDITION false '() false)) (set! condition-type:warning diff --git a/v7/src/runtime/fileio.scm b/v7/src/runtime/fileio.scm index 7228ba795..19cac904e 100644 --- a/v7/src/runtime/fileio.scm +++ b/v7/src/runtime/fileio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/fileio.scm,v 1.1 1991/11/15 05:17:18 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/fileio.scm,v 1.2 1991/11/26 07:05:49 cph Exp $ Copyright (c) 1991 Massachusetts Institute of Technology @@ -45,8 +45,10 @@ MIT in each case. |# (DISCARD-CHAR ,operation/discard-char) (DISCARD-CHARS ,operation/discard-chars) (EOF? ,operation/eof?) + (INPUT-BLOCKING-MODE ,operation/input-blocking-mode) (INPUT-BUFFER-SIZE ,operation/input-buffer-size) (INPUT-CHANNEL ,operation/input-channel) + (INPUT-TERMINAL-MODE ,operation/input-terminal-mode) (LENGTH ,operation/length) (PEEK-CHAR ,operation/peek-char) (READ-CHAR ,operation/read-char) @@ -54,13 +56,19 @@ MIT in each case. |# (READ-STRING ,operation/read-string) (READ-SUBSTRING ,operation/read-substring) (REST->STRING ,operation/rest->string) - (SET-INPUT-BUFFER-SIZE ,operation/set-input-buffer-size))) + (SET-INPUT-BLOCKING-MODE ,operation/set-input-blocking-mode) + (SET-INPUT-BUFFER-SIZE ,operation/set-input-buffer-size) + (SET-INPUT-TERMINAL-MODE ,operation/set-input-terminal-mode))) (output-operations `((BUFFERED-OUTPUT-CHARS ,operation/buffered-output-chars) (FLUSH-OUTPUT ,operation/flush-output) + (OUTPUT-BLOCKING-MODE ,operation/output-blocking-mode) (OUTPUT-BUFFER-SIZE ,operation/output-buffer-size) (OUTPUT-CHANNEL ,operation/output-channel) + (OUTPUT-TERMINAL-MODE ,operation/output-terminal-mode) + (SET-OUTPUT-BLOCKING-MODE ,operation/set-output-blocking-mode) (SET-OUTPUT-BUFFER-SIZE ,operation/set-output-buffer-size) + (SET-OUTPUT-TERMINAL-MODE ,operation/set-output-terminal-mode) (WRITE-CHAR ,operation/write-char) (WRITE-STRING ,operation/write-string) (WRITE-SUBSTRING ,operation/write-substring))) diff --git a/v7/src/runtime/format.scm b/v7/src/runtime/format.scm index 10bfdab38..931a29b20 100644 --- a/v7/src/runtime/format.scm +++ b/v7/src/runtime/format.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/format.scm,v 14.4 1988/08/05 20:47:10 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/format.scm,v 14.5 1991/11/26 07:05:57 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -58,7 +58,7 @@ MIT in each case. |# ;;; where may be: ;;; A meaning the argument is printed using `display'. ;;; S meaning the argument is printed using `write'. - + ;;;; Top Level (define (format destination format-string . arguments) @@ -67,8 +67,7 @@ MIT in each case. |# (let ((start (lambda (port) (format-loop port format-string arguments) - (output-port/flush-output port) - unspecific))) + (output-port/discretionary-flush port)))) (cond ((not destination) (with-output-to-string (lambda () (start (current-output-port))))) ((eq? destination true) @@ -77,7 +76,7 @@ MIT in each case. |# (start destination)) (else (error "FORMAT: illegal destination" destination))))) - + (define (format-loop port string arguments) (let ((index (string-find-next-char string #\~))) (cond (index diff --git a/v7/src/runtime/gc.scm b/v7/src/runtime/gc.scm index 876aed4c8..4a456a4e6 100644 --- a/v7/src/runtime/gc.scm +++ b/v7/src/runtime/gc.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 14.6 1991/02/15 18:05:23 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 14.7 1991/11/26 07:06:03 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -54,13 +54,6 @@ MIT in each case. |# (vector-set! fixed-objects #x0C condition-handler/hardware-trap) ((ucode-primitive set-fixed-objects-vector!) fixed-objects))) -(define (reset-gc-after-restore!) - ;; This will be overridden by the Emacs-interface installation code - ;; after the rest of the runtime system is restored. - (set! hook/gc-start default/gc-start) - (set! hook/gc-finish default/gc-finish) - unspecific) - (define (condition-handler/gc interrupt-code interrupt-enables) interrupt-code interrupt-enables (hook/gc-flip default-safety-margin)) @@ -163,11 +156,11 @@ MIT in each case. |# (if (< space-remaining 4096) (abort->nearest (cmdl-message/append - (cmdl-message/standard "Aborting!: out of memory") + (cmdl-message/strings "Aborting!: out of memory") ;; Clean up whatever possible to avoid a reoccurrence. (cmdl-message/active - (lambda (cmdl) - cmdl + (lambda (port) + port (with-gc-notification! true gc-clean))))))) ;;;; User Primitives diff --git a/v7/src/runtime/gcstat.scm b/v7/src/runtime/gcstat.scm index bc4c04a6e..38c1d37a9 100644 --- a/v7/src/runtime/gcstat.scm +++ b/v7/src/runtime/gcstat.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcstat.scm,v 14.4 1991/09/07 05:30:57 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcstat.scm,v 14.5 1991/11/26 07:06:07 cph Exp $ Copyright (c) 1988-1991 Massachusetts Institute of Technology @@ -36,7 +36,7 @@ MIT in each case. |# ;;; package: (runtime gc-statistics) (declare (usual-integrations)) - + (define (initialize-package!) (set! hook/record-statistic! default/record-statistic!) (set! history-modes @@ -48,9 +48,11 @@ MIT in each case. |# (statistics-reset!) (add-event-receiver! event:after-restore statistics-reset!) (set! hook/gc-start recorder/gc-start) - (set! hook/gc-finish recorder/gc-finish)) + (set! hook/gc-finish recorder/gc-finish) + unspecific) (define (recorder/gc-start) + (port/gc-start (nearest-cmdl/port)) (set! this-gc-start-clock (real-time-clock)) (set! this-gc-start (process-time-clock)) unspecific) @@ -62,7 +64,8 @@ MIT in each case. |# (increment-non-runtime! (- end-time this-gc-start)) (statistics-flip this-gc-start end-time space-remaining - this-gc-start-clock end-time-clock))) + this-gc-start-clock end-time-clock)) + (port/gc-finish (nearest-cmdl/port))) (define timestamp) (define total-gc-time) diff --git a/v7/src/runtime/genio.scm b/v7/src/runtime/genio.scm index d36d1d800..a6aefbdf9 100644 --- a/v7/src/runtime/genio.scm +++ b/v7/src/runtime/genio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/genio.scm,v 1.1 1991/11/15 05:17:03 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/genio.scm,v 1.2 1991/11/26 07:06:12 cph Exp $ Copyright (c) 1991 Massachusetts Institute of Technology @@ -45,20 +45,28 @@ MIT in each case. |# (DISCARD-CHAR ,operation/discard-char) (DISCARD-CHARS ,operation/discard-chars) (EOF? ,operation/eof?) + (INPUT-BLOCKING-MODE ,operation/input-blocking-mode) (INPUT-BUFFER-SIZE ,operation/input-buffer-size) (INPUT-CHANNEL ,operation/input-channel) + (INPUT-TERMINAL-MODE ,operation/input-terminal-mode) (PEEK-CHAR ,operation/peek-char) (READ-CHAR ,operation/read-char) (READ-CHARS ,operation/read-chars) (READ-STRING ,operation/read-string) (READ-SUBSTRING ,operation/read-substring) - (SET-INPUT-BUFFER-SIZE ,operation/set-input-buffer-size))) + (SET-INPUT-BLOCKING-MODE ,operation/set-input-blocking-mode) + (SET-INPUT-BUFFER-SIZE ,operation/set-input-buffer-size) + (SET-INPUT-TERMINAL-MODE ,operation/set-input-terminal-mode))) (output-operations `((BUFFERED-OUTPUT-CHARS ,operation/buffered-output-chars) (FLUSH-OUTPUT ,operation/flush-output) + (OUTPUT-BLOCKING-MODE ,operation/output-blocking-mode) (OUTPUT-BUFFER-SIZE ,operation/output-buffer-size) (OUTPUT-CHANNEL ,operation/output-channel) + (OUTPUT-TERMINAL-MODE ,operation/output-terminal-mode) + (SET-OUTPUT-BLOCKING-MODE ,operation/set-output-blocking-mode) (SET-OUTPUT-BUFFER-SIZE ,operation/set-output-buffer-size) + (SET-OUTPUT-TERMINAL-MODE ,operation/set-output-terminal-mode) (WRITE-CHAR ,operation/write-char) (WRITE-STRING ,operation/write-string) (WRITE-SUBSTRING ,operation/write-substring))) @@ -174,6 +182,30 @@ MIT in each case. |# (define (operation/input-channel port) (input-buffer/channel (port/input-buffer port))) +(define (operation/input-blocking-mode port) + (if (channel-blocking? (operation/input-channel port)) + 'BLOCKING + 'NONBLOCKING)) + +(define (operation/set-input-blocking-mode port mode) + (case mode + ((BLOCKING) (channel-blocking (operation/input-channel port))) + ((NONBLOCKING) (channel-nonblocking (operation/input-channel port))) + (else (error:wrong-type-datum mode "blocking mode")))) + +(define (operation/input-terminal-mode port) + (let ((channel (operation/input-channel port))) + (cond ((not (channel-type=terminal? channel)) false) + ((terminal-cooked-input? channel) 'COOKED) + (else 'RAW)))) + +(define (operation/set-input-terminal-mode port mode) + (case mode + ((COOKED) (terminal-cooked-input (operation/input-channel port))) + ((RAW) (terminal-raw-input (operation/input-channel port))) + ((#F) unspecific) + (else (error:wrong-type-datum mode "terminal mode")))) + (define (operation/flush-output port) (output-buffer/drain-block (port/output-buffer port))) @@ -199,6 +231,30 @@ MIT in each case. |# (define (operation/output-channel port) (output-buffer/channel (port/output-buffer port))) +(define (operation/output-blocking-mode port) + (if (channel-blocking? (operation/output-channel port)) + 'BLOCKING + 'NONBLOCKING)) + +(define (operation/set-output-blocking-mode port mode) + (case mode + ((BLOCKING) (channel-blocking (operation/output-channel port))) + ((NONBLOCKING) (channel-nonblocking (operation/output-channel port))) + (else (error:wrong-type-datum mode "blocking mode")))) + +(define (operation/output-terminal-mode port) + (let ((channel (operation/output-channel port))) + (cond ((not (channel-type=terminal? channel)) false) + ((terminal-cooked-output? channel) 'COOKED) + (else 'RAW)))) + +(define (operation/set-output-terminal-mode port mode) + (case mode + ((COOKED) (terminal-cooked-output (operation/output-channel port))) + ((RAW) (terminal-raw-output (operation/output-channel port))) + ((#F) unspecific) + (else (error:wrong-type-datum mode "terminal mode")))) + (define (operation/close port) (let ((input-buffer (port/input-buffer port))) (if input-buffer (input-buffer/close input-buffer))) diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm index c70dfe78d..0143af997 100644 --- a/v7/src/runtime/global.scm +++ b/v7/src/runtime/global.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.33 1991/11/04 20:29:00 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.34 1991/11/26 07:06:16 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -218,9 +218,9 @@ MIT in each case. |# (define (fasdump object filename) (let ((filename (->namestring (merge-pathnames filename))) - (port (cmdl/output-port (nearest-cmdl)))) - (newline port) - (write-string "Dumping " port) + (port (nearest-cmdl/port))) + (fresh-line port) + (write-string ";Dumping " port) (write (enough-namestring filename) port) (if (not ((ucode-primitive primitive-fasdump) object filename false)) (error "FASDUMP: Object is too large to be dumped:" object)) diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm index f0a74048c..c61950ddd 100644 --- a/v7/src/runtime/input.scm +++ b/v7/src/runtime/input.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 14.13 1991/11/15 05:14:52 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 14.14 1991/11/26 07:06:21 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -150,19 +150,9 @@ MIT in each case. |# delimiters)) (define (read #!optional port parser-table) - (let ((port - (if (default-object? port) - (current-input-port) - (guarantee-input-port port))) - (parser-table - (if (default-object? parser-table) - (current-parser-table) - (guarantee-parser-table parser-table)))) - (let ((read-start! (port/operation port 'READ-START!))) - (if read-start! - (read-start! port))) - (let ((object (parse-object/internal port parser-table))) - (let ((read-finish! (port/operation port 'READ-FINISH!))) - (if read-finish! - (read-finish! port))) - object))) \ No newline at end of file + (parse-object (if (default-object? port) + (current-input-port) + (guarantee-input-port port)) + (if (default-object? parser-table) + (current-parser-table) + parser-table))) \ No newline at end of file diff --git a/v7/src/runtime/intrpt.scm b/v7/src/runtime/intrpt.scm index d40c7a4f7..6d087a90d 100644 --- a/v7/src/runtime/intrpt.scm +++ b/v7/src/runtime/intrpt.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 14.7 1991/11/04 20:29:09 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 14.8 1991/11/26 07:06:25 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -42,6 +42,12 @@ MIT in each case. |# (fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR)) (set! index:termination-vector (fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-PROCEDURES)) + (set! hook/clean-input/flush-typeahead false) + (set! hook/clean-input/keep-typeahead false) + (set! hook/^B-interrupt false) + (set! hook/^G-interrupt false) + (set! hook/^U-interrupt false) + (set! hook/^X-interrupt false) (set! timer-interrupt default/timer-interrupt) (set! external-interrupt default/external-interrupt) (set! keyboard-interrupts @@ -53,22 +59,8 @@ MIT in each case. |# `((#\B ,(keep-typeahead ^B-interrupt-handler)) (#\G ,(flush-typeahead ^G-interrupt-handler)) (#\U ,(flush-typeahead ^U-interrupt-handler)) - (#\X ,(flush-typeahead ^X-interrupt-handler)) - #| (#\S ,(keep-typeahead ^S-interrupt-handler)) |# - #| (#\Q ,(keep-typeahead ^Q-interrupt-handler)) |# - #| (#\P ,(flush-typeahead ^P-interrupt-handler)) |# - #| (#\Z ,(flush-typeahead ^Z-interrupt-handler)) |#)) + (#\X ,(flush-typeahead ^X-interrupt-handler)))) table)) - (set! hook/clean-input/flush-typeahead default/clean-input) - (set! hook/clean-input/keep-typeahead default/clean-input) - (set! hook/^B-interrupt default/^B-interrupt) - (set! hook/^G-interrupt default/^G-interrupt) - (set! hook/^U-interrupt default/^U-interrupt) - (set! hook/^X-interrupt default/^X-interrupt) - #| (set! hook/^S-interrupt default/^S-interrupt) |# - #| (set! hook/^Q-interrupt default/^Q-interrupt) |# - #| (set! hook/^P-interrupt default/^P-interrupt) |# - #| (set! hook/^Z-interrupt default/^Z-interrupt) |# (install)) (define-primitives @@ -150,104 +142,46 @@ MIT in each case. |# (define keyboard-interrupts) -(define ((flush-typeahead kernel) character interrupt-enables) - (if (hook/clean-input/flush-typeahead character) - (kernel character interrupt-enables))) - -(define ((keep-typeahead kernel) character interrupt-enables) - (if (hook/clean-input/keep-typeahead character) - (kernel character interrupt-enables))) - (define hook/clean-input/flush-typeahead) (define hook/clean-input/keep-typeahead) -(define (default/clean-input character) character true) - -(define (^B-interrupt-handler character interrupt-enables) - character - (hook/^B-interrupt interrupt-enables)) - -(define (^G-interrupt-handler character interrupt-enables) - character - (hook/^G-interrupt interrupt-enables)) - -(define (^U-interrupt-handler character interrupt-enables) - character - (hook/^U-interrupt interrupt-enables)) - -(define (^X-interrupt-handler character interrupt-enables) - character - (hook/^X-interrupt interrupt-enables)) - -#| -(define (^S-interrupt-handler character interrupt-enables) - character - (hook/^S-interrupt interrupt-enables)) - -(define (^Q-interrupt-handler character interrupt-enables) - character - (hook/^Q-interrupt interrupt-enables)) - -(define (^P-interrupt-handler character interrupt-enables) - character - (hook/^P-interrupt interrupt-enables)) - -(define (^Z-interrupt-handler character interrupt-enables) - character - (hook/^Z-interrupt interrupt-enables)) -|# - (define hook/^B-interrupt) (define hook/^G-interrupt) (define hook/^U-interrupt) (define hook/^X-interrupt) -#| (define hook/^S-interrupt) |# -#| (define hook/^Q-interrupt) |# -#| (define hook/^P-interrupt) |# -#| (define hook/^Z-interrupt) |# - -(define (default/^B-interrupt interrupt-enables) - interrupt-enables + +(define ((flush-typeahead kernel) char interrupt-enables) + (if (or (not hook/clean-input/flush-typeahead) + (hook/clean-input/flush-typeahead char)) + (kernel char interrupt-enables))) + +(define ((keep-typeahead kernel) char interrupt-enables) + (if (or (not hook/clean-input/keep-typeahead) + (hook/clean-input/keep-typeahead char)) + (kernel char interrupt-enables))) + +(define (^B-interrupt-handler char interrupt-mask) + char + (if hook/^B-interrupt + (hook/^B-interrupt interrupt-mask)) (cmdl-interrupt/breakpoint)) -(define (default/^G-interrupt interrupt-enables) - interrupt-enables +(define (^G-interrupt-handler char interrupt-mask) + char + (if hook/^G-interrupt + (hook/^G-interrupt interrupt-mask)) (cmdl-interrupt/abort-top-level)) -(define (default/^U-interrupt interrupt-enables) - interrupt-enables +(define (^U-interrupt-handler char interrupt-mask) + char + (if hook/^U-interrupt + (hook/^U-interrupt interrupt-mask)) (cmdl-interrupt/abort-previous)) -(define (default/^X-interrupt interrupt-enables) - interrupt-enables +(define (^X-interrupt-handler char interrupt-mask) + char + (if hook/^X-interrupt + (hook/^X-interrupt interrupt-mask)) (cmdl-interrupt/abort-nearest)) - -#| -(define (default/^S-interrupt interrupt-enables) - (if (not busy-wait-continuation) - (begin - (set-interrupt-enables! interrupt-enables) - (beep console-output-port) - (call-with-current-continuation - (lambda (continuation) - (fluid-let ((busy-wait-continuation continuation)) - (let busy-wait () (busy-wait)))))))) - -(define (default/^Q-interrupt interrupt-enables) - (if busy-wait-continuation - (begin (set-interrupt-enables! interrupt-enables) - (busy-wait-continuation false)))) - -(define busy-wait-continuation - false) - -(define (default/^P-interrupt interrupt-enables) - (set-interrupt-enables! interrupt-enables) - (proceed)) - -(define (default/^Z-interrupt interrupt-enables) - (set-interrupt-enables! interrupt-enables) - (edit)) -|# (define (install) (without-interrupts diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index 549126808..59d2f1c30 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.30 1991/11/04 20:29:20 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.31 1991/11/26 07:06:29 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -93,9 +93,9 @@ MIT in each case. |# (define (loading-message suppress-loading-message? pathname do-it) (if suppress-loading-message? (do-it) - (let ((port (cmdl/output-port (nearest-cmdl)))) - (newline port) - (write-string "Loading " port) + (let ((port (nearest-cmdl/port))) + (fresh-line port) + (write-string ";Loading " port) (write (enough-namestring pathname) port) (let ((value (do-it))) (write-string " -- done" port) @@ -264,8 +264,7 @@ MIT in each case. |# (repl/syntax-table repl) syntax-table)))) (lambda (s-expression) - (hook/repl-eval repl - s-expression + (hook/repl-eval s-expression environment syntax-table)))))) diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm index cfb6b9ef0..d07e52e20 100644 --- a/v7/src/runtime/output.scm +++ b/v7/src/runtime/output.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 14.11 1991/11/15 05:15:01 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 14.12 1991/11/26 07:06:35 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -59,6 +59,9 @@ MIT in each case. |# (define (output-port/flush-output port) ((output-port/operation/flush-output port) port)) +(define (output-port/discretionary-flush port) + ((output-port/operation/discretionary-flush port) port)) + (define (output-port/x-size port) (or (let ((operation (port/operation port 'X-SIZE))) (and operation @@ -104,7 +107,7 @@ MIT in each case. |# (current-output-port) (guarantee-output-port port)))) (output-port/write-char port #\newline) - (output-port/flush-output port))) + (output-port/discretionary-flush port))) (define (fresh-line #!optional port) (let ((port @@ -115,7 +118,7 @@ MIT in each case. |# (if operation (operation port) (output-port/write-char port #\newline))) - (output-port/flush-output port))) + (output-port/discretionary-flush port))) (define (write-char char #!optional port) (let ((port @@ -123,7 +126,7 @@ MIT in each case. |# (current-output-port) (guarantee-output-port port)))) (output-port/write-char port char) - (output-port/flush-output port))) + (output-port/discretionary-flush port))) (define (write-string string #!optional port) (let ((port @@ -131,7 +134,7 @@ MIT in each case. |# (current-output-port) (guarantee-output-port port)))) (output-port/write-string port string) - (output-port/flush-output port))) + (output-port/discretionary-flush port))) (define (wrap-custom-operation-0 operation-name) (lambda (#!optional port) @@ -143,7 +146,7 @@ MIT in each case. |# (if operation (begin (operation port) - (output-port/flush-output port))))))) + (output-port/discretionary-flush port))))))) (define beep (wrap-custom-operation-0 'BEEP)) @@ -163,7 +166,7 @@ MIT in each case. |# (if (string? object) (output-port/write-string port object) (unparse-object/internal object port 0 false unparser-table)) - (output-port/flush-output port))) + (output-port/discretionary-flush port))) (define (write object #!optional port unparser-table) (let ((port @@ -175,7 +178,7 @@ MIT in each case. |# (current-unparser-table) (guarantee-unparser-table unparser-table)))) (unparse-object/internal object port 0 true unparser-table) - (output-port/flush-output port))) + (output-port/discretionary-flush port))) (define (write-line object #!optional port unparser-table) (let ((port @@ -188,4 +191,10 @@ MIT in each case. |# (guarantee-unparser-table unparser-table)))) (output-port/write-char port #\Newline) (unparse-object/internal object port 0 true unparser-table) - (output-port/flush-output port))) \ No newline at end of file + (output-port/discretionary-flush port))) + +(define (flush-output #!optional port) + (output-port/flush-output + (if (default-object? port) + (current-output-port) + (guarantee-output-port port)))) \ No newline at end of file diff --git a/v7/src/runtime/parse.scm b/v7/src/runtime/parse.scm index ed4c80c89..8a2ccde6b 100644 --- a/v7/src/runtime/parse.scm +++ b/v7/src/runtime/parse.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 14.16 1991/09/18 20:00:17 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 14.17 1991/11/26 07:06:39 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -133,26 +133,30 @@ MIT in each case. |# ;;;; Top Level (define (parse-object port parser-table) - (if (not (parser-table? parser-table)) - (error "Not a valid parser table" parser-table)) - (parse-object/internal port parser-table)) + ((parsing-operation port) port parser-table)) (define (parse-objects port parser-table last-object?) - (if (not (parser-table? parser-table)) - (error "Not a valid parser table" parser-table)) - (parse-objects/internal port parser-table last-object?)) - -(define (parse-object/internal port parser-table) - (within-parser port parser-table parse-object/dispatch)) - -(define (parse-objects/internal port parser-table last-object?) - (let loop () - (let ((object (parse-object/internal port parser-table))) - (if (last-object? object) - '() - (cons-stream object (loop)))))) + (let ((operation (parsing-operation port))) + (let loop () + (let ((object (operation port parser-table))) + (if (last-object? object) + '() + (cons-stream object (loop))))))) + +(define (parsing-operation port) + (or (port/operation port 'READ) + (let ((read-start (port/operation port 'READ-START)) + (read-finish (port/operation port 'READ-FINISH))) + (lambda (port parser-table) + (if read-start (read-start port)) + (let ((object + (within-parser port parser-table parse-object/dispatch))) + (if read-finish (read-finish port)) + object))))) (define (within-parser port parser-table thunk) + (if (not (parser-table? parser-table)) + (error:wrong-type-argument parser-table "parser table" 'WITHIN-PARSER)) (fluid-let ((*parser-input-port* port) (*parser-parse-object-table* (parser-table/parse-object parser-table)) diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm index 25b7302da..6a79d7a75 100644 --- a/v7/src/runtime/port.scm +++ b/v7/src/runtime/port.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/port.scm,v 1.1 1991/11/15 05:19:03 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/port.scm,v 1.2 1991/11/26 07:06:43 cph Exp $ Copyright (c) 1991 Massachusetts Institute of Technology @@ -53,25 +53,15 @@ MIT in each case. |# WRITE-CHAR WRITE-STRING WRITE-SUBSTRING - FLUSH-OUTPUT))) + FLUSH-OUTPUT + DISCRETIONARY-FLUSH-OUTPUT))) -(define port? - (record-predicate port-rtd)) - -(define port/state - (record-accessor port-rtd 'STATE)) - -(define set-port/state! - (record-updater port-rtd 'STATE)) - -(define port/operation-names - (record-accessor port-rtd 'OPERATION-NAMES)) - -(define set-port/operation-names! - (record-updater port-rtd 'OPERATION-NAMES)) - -(define port/custom-operations - (record-accessor port-rtd 'CUSTOM-OPERATIONS)) +(define port? (record-predicate port-rtd)) +(define port/state (record-accessor port-rtd 'STATE)) +(define set-port/state! (record-updater port-rtd 'STATE)) +(define port/operation-names (record-accessor port-rtd 'OPERATION-NAMES)) +(define set-port/operation-names! (record-updater port-rtd 'OPERATION-NAMES)) +(define port/custom-operations (record-accessor port-rtd 'CUSTOM-OPERATIONS)) (define input-port/operation/char-ready? (record-accessor port-rtd 'CHAR-READY?)) @@ -103,6 +93,9 @@ MIT in each case. |# (define output-port/operation/flush-output (record-accessor port-rtd 'FLUSH-OUTPUT)) +(define output-port/operation/discretionary-flush + (record-accessor port-rtd 'DISCRETIONARY-FLUSH-OUTPUT)) + (set-record-type-unparser-method! port-rtd (lambda (state port) ((unparser/standard-method @@ -136,6 +129,8 @@ MIT in each case. |# ((WRITE-STRING) (output-port/operation/write-string port)) ((WRITE-SUBSTRING) (output-port/operation/write-substring port)) ((FLUSH-OUTPUT) (output-port/operation/flush-output port)) + ((DISCRETIONARY-FLUSH-OUTPUT) + (output-port/operation/discretionary-flush port)) (else false))))) (define (close-port port) @@ -190,6 +185,8 @@ MIT in each case. |# (define input-port/custom-operation input-port/operation) (define output-port/custom-operation output-port/operation) +;;;; Constructors + (define (input-port? object) (and (port? object) (input-port/operation/read-char object) @@ -255,6 +252,8 @@ MIT in each case. |# (updater port (delq! operation operations)) (cdr operation)))))))) +;;;; Input Operations + (define install-input-operations! (let ((operation-names '(CHAR-READY? PEEK-CHAR READ-CHAR @@ -277,7 +276,7 @@ MIT in each case. |# (error "Must specify operation:" name)))) updaters operations - (list false + (list default-operation/char-ready? false false (caddr operations) @@ -296,6 +295,10 @@ MIT in each case. |# (updater port false)) updaters))))))) +(define (default-operation/char-ready? port interval) + port interval + true) + (define (default-operation/read-string port delimiters) (let ((peek-char (input-port/operation/peek-char port)) (discard-char (input-port/operation/discard-char port))) @@ -326,8 +329,10 @@ MIT in each case. |# (discard-char port) (loop))))))) +;;;; Output Operations + (define (default-operation/write-char port char) - ((output-port/operation/write-substring port) port (char->string char) 0 1)) + ((output-port/operation/write-substring port) port (string char) 0 1)) (define (default-operation/write-string port string) ((output-port/operation/write-substring port) @@ -348,11 +353,13 @@ MIT in each case. |# (define install-output-operations! (let ((operation-names - '(WRITE-CHAR WRITE-SUBSTRING WRITE-STRING FLUSH-OUTPUT)) + '(WRITE-CHAR WRITE-SUBSTRING WRITE-STRING + FLUSH-OUTPUT DISCRETIONARY-FLUSH-OUTPUT)) (operation-defaults (list default-operation/write-char default-operation/write-substring default-operation/write-string + default-operation/flush-output default-operation/flush-output))) (let ((updaters (map (lambda (name) @@ -382,4 +389,76 @@ MIT in each case. |# operation-names) (for-each (lambda (updater) (updater port false)) - updaters))))))) \ No newline at end of file + updaters))))))) + +;;;; Special Operations + +(define (port/input-blocking-mode port) + (let ((operation (port/operation port 'INPUT-BLOCKING-MODE))) + (if operation + (operation port) + false))) + +(define (port/set-input-blocking-mode port mode) + (let ((operation (port/operation port 'SET-INPUT-BLOCKING-MODE))) + (if operation + (operation port mode)))) + +(define (port/with-input-blocking-mode port mode thunk) + (bind-mode port 'INPUT-BLOCKING-MODE 'SET-INPUT-BLOCKING-MODE mode thunk)) + +(define (port/output-blocking-mode port) + (let ((operation (port/operation port 'OUTPUT-BLOCKING-MODE))) + (if operation + (operation port) + false))) + +(define (port/set-output-blocking-mode port mode) + (let ((operation (port/operation port 'SET-OUTPUT-BLOCKING-MODE))) + (if operation + (operation port mode)))) + +(define (port/with-output-blocking-mode port mode thunk) + (bind-mode port 'OUTPUT-BLOCKING-MODE 'SET-OUTPUT-BLOCKING-MODE mode thunk)) + +(define (port/input-terminal-mode port) + (let ((operation (port/operation port 'INPUT-TERMINAL-MODE))) + (if operation + (operation port) + false))) + +(define (port/set-input-terminal-mode port mode) + (let ((operation (port/operation port 'SET-INPUT-TERMINAL-MODE))) + (if operation + (operation port mode)))) + +(define (port/with-input-terminal-mode port mode thunk) + (bind-mode port 'INPUT-TERMINAL-MODE 'SET-INPUT-TERMINAL-MODE mode thunk)) + +(define (port/output-terminal-mode port) + (let ((operation (port/operation port 'OUTPUT-TERMINAL-MODE))) + (if operation + (operation port) + false))) + +(define (port/set-output-terminal-mode port mode) + (let ((operation (port/operation port 'SET-OUTPUT-TERMINAL-MODE))) + (if operation + (operation port mode)))) + +(define (port/with-output-terminal-mode port mode thunk) + (bind-mode port 'OUTPUT-TERMINAL-MODE 'SET-OUTPUT-TERMINAL-MODE mode thunk)) + +(define (bind-mode port read-mode write-mode mode thunk) + (let ((read-mode (port/operation port read-mode)) + (write-mode (port/operation port write-mode))) + (if (and read-mode write-mode (read-mode port)) + (let ((outside-mode)) + (dynamic-wind (lambda () + (set! outside-mode (read-mode port)) + (write-mode port mode)) + thunk + (lambda () + (set! mode (read-mode port)) + (write-mode port outside-mode)))) + (thunk)))) \ No newline at end of file diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm index ccfacf5d0..e154b00de 100644 --- a/v7/src/runtime/pp.scm +++ b/v7/src/runtime/pp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.22 1991/10/30 19:47:47 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.23 1991/11/26 07:06:47 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -131,7 +131,7 @@ MIT in each case. |# (if as-code? (print-node node indentation list-depth) (print-non-code-node node indentation list-depth)) - (output-port/flush-output port)))) + (output-port/discretionary-flush port)))) (define x-size) (define output-port) diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index 2d8862079..41e594a17 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.21 1991/05/15 22:02:20 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.22 1991/11/26 07:06:53 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -36,151 +36,188 @@ MIT in each case. |# ;;; package: (runtime rep) (declare (usual-integrations)) - + (define repl:allow-restart-notifications? true) (define (initialize-package!) (set! *nearest-cmdl* false) - (set! with-cmdl/input-port - (object-component-binder cmdl/input-port set-cmdl/input-port!)) - (set! with-cmdl/output-port - (object-component-binder cmdl/output-port set-cmdl/output-port!)) - (set! hook/cmdl-prompt default/cmdl-prompt) - (set! hook/cmdl-message default/cmdl-message) - (set! hook/error-decision false) - (set! hook/repl-environment default/repl-environment) - (set! hook/repl-read default/repl-read) - (set! hook/repl-write default/repl-write) (set! hook/repl-eval default/repl-eval) - (set! hook/read-command-char default/read-command-char) - (set! hook/prompt-for-confirmation default/prompt-for-confirmation) - (set! hook/prompt-for-expression default/prompt-for-expression) + (set! hook/repl-write default/repl-write) + (set! hook/set-default-environment default/set-default-environment) + (set! hook/error-decision false) unspecific) (define (initial-top-level-repl) - (make-cmdl false - console-input-port - console-output-port - repl-driver - (make-repl-state user-initial-prompt - user-initial-environment - user-initial-syntax-table - false) - (cmdl-message/standard "Cold load finished") - make-cmdl)) + (call-with-current-continuation + (lambda (continuation) + (set! root-continuation continuation) + (repl/start (make-repl false + console-i/o-port + user-initial-environment + user-initial-syntax-table + false + '() + user-initial-prompt) + (cmdl-message/strings "Cold load finished"))))) + +(define root-continuation) ;;;; Command Loops -(define-structure (cmdl (conc-name cmdl/) (constructor %make-cmdl)) - (parent false read-only true) - (level false read-only true) - (driver false read-only true) - (spawn-child false read-only true) - input-port - output-port - state) - -(define (make-cmdl parent input-port output-port driver state message - spawn-child) - (if (not (or (false? parent) (cmdl? parent))) - (error:wrong-type-argument parent "cmdl or #f" 'MAKE-CMDL)) - (let ((level (if parent (+ (cmdl/level parent) 1) 1))) - (let ((cmdl - (%make-cmdl parent level driver spawn-child input-port output-port - state))) - (let loop ((message message)) - (loop - (call-with-current-continuation - (lambda (continuation) - (bind-restart 'ABORT - (string-append "Return to " - (if (repl? cmdl) "read-eval-print" "command") - " level " - (number->string level) - ".") - (lambda (#!optional message) - (continuation - (if (default-object? message) - (cmdl-message/standard "Abort!") - message))) - (lambda (restart) - (restart/put! restart make-cmdl cmdl) - (fluid-let ((*nearest-cmdl* cmdl) - (dynamic-handler-frames '())) - (with-interrupt-mask interrupt-mask/all - (lambda (interrupt-mask) - interrupt-mask - (message cmdl) - ((cmdl/driver cmdl) cmdl))))))))))))) - -(define *nearest-cmdl*) - -(define (nearest-cmdl) - (if (not *nearest-cmdl*) (error "NEAREST-CMDL: no cmdl")) - *nearest-cmdl*) - -(define (nearest-cmdl/input-port) - (cmdl/input-port (nearest-cmdl))) - -(define (nearest-cmdl/output-port) - (cmdl/output-port (nearest-cmdl))) - -(define (push-cmdl driver state message spawn-child) +(define cmdl-rtd + (make-record-type "cmdl" '(LEVEL PARENT PORT DRIVER STATE OPERATIONS))) + +(define cmdl? (record-predicate cmdl-rtd)) +(define cmdl/level (record-accessor cmdl-rtd 'LEVEL)) +(define cmdl/parent (record-accessor cmdl-rtd 'PARENT)) +(define cmdl/port (record-accessor cmdl-rtd 'PORT)) +(define set-cmdl/port! (record-updater cmdl-rtd 'PORT)) +(define cmdl/driver (record-accessor cmdl-rtd 'DRIVER)) +(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 make-cmdl + (let ((constructor + (record-constructor cmdl-rtd + '(LEVEL PARENT PORT DRIVER STATE OPERATIONS)))) + (lambda (parent port driver state operations) + (if (not (or (false? parent) (cmdl? parent))) + (error:wrong-type-argument parent "cmdl" 'MAKE-CMDL)) + (constructor (if parent (+ (cmdl/level parent) 1) 1) + parent + port + driver + state + (parse-operations-list operations 'MAKE-CMDL))))) + +(define (push-cmdl driver state operations) (let ((parent (nearest-cmdl))) - ((cmdl/spawn-child parent) parent - (cmdl/input-port parent) - (cmdl/output-port parent) - driver - state - message - spawn-child))) + (make-cmdl parent (cmdl/port parent) driver state operations))) (define (cmdl/base cmdl) (let ((parent (cmdl/parent cmdl))) (if parent (cmdl/base parent) cmdl))) + +(define (cmdl/start cmdl message) + (let ((operation + (let ((parent (cmdl/parent cmdl))) + (and parent + (cmdl/local-operation parent 'START-CHILD)))) + (thunk + (lambda () + (fluid-let ((*nearest-cmdl* cmdl) + (dynamic-handler-frames '()) + (*bound-restarts* + (if (cmdl/parent cmdl) *bound-restarts* '()))) + (let loop ((message message)) + (loop + (call-with-current-continuation + (lambda (continuation) + (bind-restart 'ABORT + (string-append "Return to " + (if (repl? cmdl) + "read-eval-print" + "command") + " level " + (number->string (cmdl/level cmdl)) + ".") + (lambda (#!optional message) + (continuation + (if (default-object? message) + (cmdl-message/strings "Abort!") + message))) + (lambda (restart) + (restart/put! restart make-cmdl cmdl) + (with-interrupt-mask interrupt-mask/all + (lambda (interrupt-mask) + interrupt-mask + (message cmdl) + ((cmdl/driver cmdl) cmdl))))))))))))) + (if operation + (operation cmdl thunk) + (thunk)))) + +(define *nearest-cmdl*) -(define with-cmdl/input-port) -(define with-cmdl/output-port) +(define (nearest-cmdl) + (if (not *nearest-cmdl*) (error "NEAREST-CMDL: no cmdl")) + *nearest-cmdl*) + +(define (nearest-cmdl/port) + (let ((cmdl *nearest-cmdl*)) + (if cmdl + (cmdl/port cmdl) + console-i/o-port))) + +(define (nearest-cmdl/level) + (let ((cmdl *nearest-cmdl*)) + (if cmdl + (cmdl/level cmdl) + 0))) + +;;;; Operations + +(define (parse-operations-list operations procedure) + (if (not (list? operations)) + (error:wrong-type-argument operations "list" procedure)) + (map (lambda (operation) + (if (not (and (pair? operation) + (symbol? (car operation)) + (pair? (cdr operation)) + (procedure? (cadr operation)) + (null? (cddr operation)))) + (error:wrong-type-argument operation + "operation binding" + procedure)) + (cons (car operation) (cadr operation))) + operations)) + +(define (cmdl/local-operation cmdl name) + (let ((binding (assq name (cmdl/operations cmdl)))) + (and binding + (cdr binding)))) + +(define (cmdl/operation cmdl name) + (let loop ((cmdl cmdl)) + (or (cmdl/local-operation cmdl name) + (let ((parent (cmdl/parent cmdl))) + (and parent + (loop parent)))))) + +(define (cmdl/operation-names cmdl) + (let cmdl-loop ((cmdl cmdl) (names '())) + (let loop ((bindings (cmdl/operations cmdl)) (names names)) + (if (null? bindings) + (let ((parent (cmdl/parent cmdl))) + (if parent + (cmdl-loop parent names) + names)) + (loop (cdr bindings) + (if (memq (caar bindings) names) + names + (cons (caar bindings) names))))))) ;;;; Messages -(define hook/cmdl-prompt) -(define (default/cmdl-prompt cmdl prompt) - (with-output-port-cooked cmdl - (lambda (output-port) - (write-string - (string-append "\n\n" - (number->string (cmdl/level cmdl)) - " " - prompt - " ") - output-port)))) - -(define ((cmdl-message/standard string) cmdl) - (hook/cmdl-message cmdl string)) - -(define hook/cmdl-message) -(define (default/cmdl-message cmdl string) - (with-output-port-cooked cmdl - (lambda (output-port) - (write-string (string-append "\n" string) output-port)))) - (define ((cmdl-message/strings . strings) cmdl) - (with-output-port-cooked cmdl - (lambda (output-port) - (for-each (lambda (string) - (write-string (string-append "\n" string) output-port)) - strings)))) + (let ((port (cmdl/port cmdl))) + (port/with-output-terminal-mode port 'COOKED + (lambda () + (for-each (lambda (string) + (fresh-line port) + (write-string ";" port) + (write-string string port)) + strings))))) (define ((cmdl-message/active actor) cmdl) - (with-output-port-cooked cmdl - (lambda (output-port) - (with-output-to-port output-port - (lambda () - (actor cmdl)))))) + (let ((port (cmdl/port cmdl))) + (port/with-output-terminal-mode port 'COOKED + (lambda () + (actor port))))) (define (cmdl-message/append . messages) (let ((messages (delq! %cmdl-message/null messages))) @@ -201,37 +238,44 @@ MIT in each case. |# ;;;; Interrupts +(define (cmdl-interrupt/breakpoint) + ((or (cmdl/operation (nearest-cmdl) 'INTERRUPT/BREAKPOINT) + breakpoint))) + (define (cmdl-interrupt/abort-nearest) - (abort->nearest "Abort!")) + ((or (cmdl/operation (nearest-cmdl) 'INTERRUPT/ABORT-NEAREST) + abort->nearest))) (define (cmdl-interrupt/abort-previous) - (abort->previous "Up!")) + ((or (cmdl/operation (nearest-cmdl) 'INTERRUPT/ABORT-PREVIOUS) + abort->previous))) (define (cmdl-interrupt/abort-top-level) - (abort->top-level "Quit!")) + ((or (cmdl/operation (nearest-cmdl) 'INTERRUPT/ABORT-TOP-LEVEL) + abort->top-level))) -(define (abort->nearest message) +(define (abort->nearest #!optional message) (invoke-abort (let ((restart (find-restart 'ABORT))) (if (not restart) (error:no-such-restart 'ABORT)) restart) - message)) + (if (default-object? message) "Abort!" message))) -(define (abort->previous message) +(define (abort->previous #!optional message) (invoke-abort (let ((restarts (find-restarts 'ABORT (bound-restarts)))) (let ((next (find-restarts 'ABORT (cdr restarts)))) (cond ((not (null? next)) (car next)) ((not (null? restarts)) (car restarts)) (else (error:no-such-restart 'ABORT))))) - message)) + (if (default-object? message) "Up!" message))) -(define (abort->top-level message) +(define (abort->top-level #!optional message) (invoke-abort (let loop ((restarts (find-restarts 'ABORT (bound-restarts)))) (let ((next (find-restarts 'ABORT (cdr restarts)))) (cond ((not (null? next)) (loop next)) ((not (null? restarts)) (car restarts)) (else (error:no-such-restart 'ABORT))))) - message)) + (if (default-object? message) "Quit!" message))) (define (find-restarts name restarts) (let loop ((restarts restarts)) @@ -244,105 +288,165 @@ MIT in each case. |# (let ((effector (restart/effector restart))) (if (restart/get restart make-cmdl) (effector - (if (string? message) (cmdl-message/standard message) message)) + (if (string? message) (cmdl-message/strings message) message)) (effector)))) - -(define (cmdl-interrupt/breakpoint) - (with-simple-restart 'CONTINUE "Continue from ^B interrupt." - (lambda () - (push-repl "^B interrupt" false "^B>")))) ;;;; REP Loops -(define-structure (repl-state - (conc-name repl-state/) - (constructor make-repl-state - (prompt environment syntax-table condition))) - prompt - environment - syntax-table - (condition false read-only true) - (reader-history (make-repl-history reader-history-size)) - (printer-history (make-repl-history printer-history-size))) +(define (make-repl parent port environment syntax-table + #!optional condition operations prompt) + (make-cmdl parent + port + repl-driver + (let ((inherit + (let ((repl (and parent (skip-non-repls parent)))) + (lambda (argument default name) + (if (eq? 'INHERIT argument) + (begin + (if (not repl) + (error "Can't inherit -- no REPL ancestor:" + name)) + (default repl)) + argument))))) + (make-repl-state + (inherit (if (default-object? prompt) 'INHERIT prompt) + repl/prompt + 'PROMPT) + (inherit environment repl/environment 'ENVIRONMENT) + (inherit syntax-table repl/syntax-table 'SYNTAX-TABLE) + (if (default-object? condition) false condition))) + (append (if (default-object? operations) '() operations) + default-repl-operations))) + +(define (push-repl environment syntax-table + #!optional condition operations prompt) + (let ((parent (nearest-cmdl))) + (make-repl parent + (cmdl/port parent) + environment + syntax-table + (if (default-object? condition) false condition) + (if (default-object? operations) '() operations) + (if (default-object? prompt) 'INHERIT prompt)))) -(define (push-repl message condition - #!optional prompt environment syntax-table) - (let ((environment (if (default-object? environment) 'INHERIT environment))) - (push-cmdl repl-driver - (let ((repl (nearest-repl))) - (make-repl-state (if (or (default-object? prompt) - (eq? 'INHERIT prompt)) - (repl/prompt repl) - prompt) - (if (eq? 'INHERIT environment) - (repl/environment repl) - environment) - (if (or (default-object? syntax-table) - (eq? 'INHERIT syntax-table)) - (repl/syntax-table repl) - syntax-table) - condition)) - (cmdl-message/append - (cond ((not message) - (if condition - (cmdl-message/strings - (with-string-output-port - (lambda (port) - (write-string ";" port) - (write-condition-report condition - port)))) - (cmdl-message/null))) - ((string? message) - (cmdl-message/standard message)) - (else - message)) - (if condition - (cmdl-message/append - (if (and hook/error-decision (condition/error? condition)) - (cmdl-message/active - (lambda (cmdl) - cmdl - (hook/error-decision))) - (cmdl-message/null)) - (if repl:allow-restart-notifications? - (condition-restarts-message condition) - (cmdl-message/null))) - (cmdl-message/null)) - (if (eq? 'INHERIT environment) - (cmdl-message/null) - (cmdl-message/active - (lambda (cmdl) - cmdl - (repl-environment (nearest-repl) environment))))) - (lambda args - (with-history-disabled - (lambda () - (apply make-cmdl args))))))) +(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 + (prompt-for-command-expression + (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-eval) +(define (default/repl-eval s-expression environment syntax-table) + (let ((scode (syntax s-expression syntax-table))) + (with-new-history (lambda () (extended-scode-eval scode environment))))) + +(define hook/repl-write) +(define (default/repl-write repl object) + (port/write-result (cmdl/port repl) + object + (and (object-pointer? object) + (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 + (make-repl-message repl + (if (default-object? message) + false + message)))) + +(define (make-repl-message repl message) + (let ((condition (repl/condition repl))) + (cmdl-message/append + (cond ((not message) + (if condition + (cmdl-message/strings (condition/report-string condition)) + (cmdl-message/null))) + ((string? message) + (cmdl-message/strings message)) + (else + message)) + (if condition + (cmdl-message/append + (if (condition/error? condition) + (lambda (repl) + (cond ((cmdl/operation repl 'ERROR-DECISION) + => (lambda (operation) + (operation repl condition))) + (hook/error-decision + (hook/error-decision repl condition)))) + (cmdl-message/null)) + (if repl:allow-restart-notifications? + (condition-restarts-message condition) + (cmdl-message/null))) + (cmdl-message/null)) + repl/set-default-environment))) (define hook/error-decision) -(define (repl-driver repl) - (fluid-let ((standard-error-hook false) - (standard-warning-hook false)) - (hook/cmdl-prompt repl (repl/prompt repl)) - (let ((s-expression (hook/repl-read repl))) - (cmdl-message/value - (hook/repl-eval repl - s-expression - (repl/environment repl) - (repl/syntax-table repl)))))) +(define (repl/set-default-environment repl) + (let ((parent (cmdl/parent repl)) + (environment (repl/environment repl))) + (if (not (and parent + (repl? parent) + (eq? (repl/environment parent) environment))) + (let ((operation (cmdl/operation repl 'SET-DEFAULT-ENVIRONMENT))) + (if operation + (operation repl environment) + (hook/set-default-environment repl environment)))))) + +(define hook/set-default-environment) +(define (default/set-default-environment port environment) + (let ((port (cmdl/port port))) + (port/with-output-terminal-mode port 'COOKED + (lambda () + (if (not (interpreter-environment? environment)) + (begin + (fresh-line port) + (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))) + (let ((package (environment->package environment))) + (if package + (begin + (fresh-line port) + (write-string ";Package: " port) + (write (package/name package) port)))))))) (define (condition-restarts-message condition) (cmdl-message/active - (lambda (cmdl) - (let ((port (cmdl/output-port cmdl))) - (write-string " -;To continue, call RESTART with an option number:" port) - (write-restarts (filter-restarts (condition/restarts condition)) port - (lambda (index port) - (write-string "; (RESTART " port) - (write index port) - (write-string ") =>" port))))))) + (lambda (port) + (fresh-line port) + (write-string ";To continue, call RESTART with an option number:" port) + (write-restarts (filter-restarts (condition/restarts condition)) port + (lambda (index port) + (write-string "; (RESTART " port) + (write index port) + (write-string ") =>" port)))))) (define (restart #!optional n) (let ((restarts @@ -359,8 +463,8 @@ MIT in each case. |# restarts (- n-restarts (if (default-object? n) - (let ((port (nearest-cmdl/output-port))) - (newline port) + (let ((port (nearest-cmdl/port))) + (fresh-line port) (write-string ";Choose an option by number:" port) (write-restarts restarts port (lambda (index port) @@ -370,12 +474,15 @@ MIT in each case. |# (write-string ":" port))) (let loop () (let ((n - (prompt-for-evaluated-expression "Option number"))) + (prompt-for-evaluated-expression + "Option number" + (nearest-repl/environment) + port))) (if (and (exact-integer? n) (<= 1 n n-restarts)) n (begin (beep port) - (newline port) + (fresh-line port) (write-string ";Option must be an integer between 1 and " port) @@ -410,6 +517,17 @@ MIT in each case. |# (restart/get restart make-cmdl))) (loop (cdr restarts))))))) +(define-structure (repl-state + (conc-name repl-state/) + (constructor make-repl-state + (prompt environment syntax-table condition))) + prompt + environment + syntax-table + (condition false read-only true) + (reader-history (make-repl-history reader-history-size)) + (printer-history (make-repl-history printer-history-size))) + (define (repl? object) (and (cmdl? object) (repl-state? (cmdl/state object)))) @@ -425,13 +543,15 @@ MIT in each case. |# (define (set-repl/environment! repl environment) (set-repl-state/environment! (cmdl/state repl) environment) - (repl-environment repl environment)) + (repl/set-default-environment repl) + (port/set-default-environment (cmdl/port repl) environment)) (define-integrable (repl/syntax-table repl) (repl-state/syntax-table (cmdl/state repl))) -(define-integrable (set-repl/syntax-table! repl syntax-table) - (set-repl-state/syntax-table! (cmdl/state repl) syntax-table)) +(define (set-repl/syntax-table! repl syntax-table) + (set-repl-state/syntax-table! (cmdl/state repl) syntax-table) + (port/set-default-syntax-table (cmdl/port repl) syntax-table)) (define-integrable (repl/condition repl) (repl-state/condition (cmdl/state repl))) @@ -476,66 +596,6 @@ MIT in each case. |# (define (nearest-repl/condition) (repl/condition (nearest-repl))) -;;;; Hooks - -(define hook/repl-environment) -(define hook/repl-read) -(define hook/repl-eval) -(define hook/repl-write) - -(define (repl-environment repl environment) - (with-output-port-cooked repl - (lambda (output-port) - output-port - (hook/repl-environment repl environment)))) - -(define (default/repl-environment repl environment) - (let ((port (cmdl/output-port repl))) - (if (not (interpreter-environment? environment)) - (begin - (write-string " -;Warning! this environment is a compiled-code environment: -; Assignments to most compiled-code bindings are prohibited, -; as are certain other environment operations."))) - (let ((package (environment->package environment))) - (if package - (begin - (write-string "\n;Package: " port) - (write (package/name package) port)))))) - -(define (default/repl-read repl) - (let ((s-expression (read-internal (cmdl/input-port repl)))) - (repl-history/record! (repl/reader-history repl) s-expression) - s-expression)) - -(define (default/repl-eval repl s-expression environment syntax-table) - repl ;ignore - (let ((scode (syntax s-expression syntax-table))) - (with-new-history (lambda () (extended-scode-eval scode environment))))) - -(define ((cmdl-message/value value) repl) - (hook/repl-write repl value)) - -(define (default/repl-write repl object) - (repl-history/record! (repl/printer-history repl) object) - (with-output-port-cooked repl - (lambda (output-port) - (if (undefined-value? object) - (write-string "\n;No value" output-port) - (begin - (write-string "\n;Value" output-port) - (if (repl-write/show-hash? object) - (begin - (write-string " " output-port) - (write (object-hash object) output-port))) - (write-string ": " output-port) - (write object output-port)))))) - -(define (repl-write/show-hash? object) - (and (object-pointer? object) - (not (interned-symbol? object)) - (not (number? object)))) - ;;;; History (define reader-history-size 5) @@ -602,13 +662,11 @@ MIT in each case. |# (define (gst syntax-table) (guarantee-syntax-table syntax-table) - (set-repl-state/syntax-table! (cmdl/state (nearest-repl)) syntax-table) - unspecific) + (set-repl/syntax-table! (nearest-repl) syntax-table)) (define (re #!optional index) (let ((repl (nearest-repl))) - (hook/repl-eval repl - (let ((history (repl/reader-history repl))) + (hook/repl-eval (let ((history (repl/reader-history repl))) (let ((s-expression (repl-history/read history (if (default-object? index) @@ -628,12 +686,14 @@ MIT in each case. |# (- (if (default-object? index) 1 index) 1))) (define (read-eval-print environment message prompt) - (push-repl message false prompt environment)) + (repl/start (push-repl environment 'INHERIT false '() prompt) message)) -(define (breakpoint message environment) +(define (breakpoint #!optional message environment) (with-simple-restart 'CONTINUE "Continue from breakpoint." (lambda () - (read-eval-print environment message "Breakpoint->")))) + (read-eval-print (if (default-object? environment) 'INHERIT environment) + (if (default-object? message) "Break!" message) + "break>")))) (define (bkpt datum . arguments) (apply breakpoint-procedure 'INHERIT datum arguments)) @@ -644,11 +704,10 @@ MIT in each case. |# (lambda () (read-eval-print environment (cmdl-message/active - (lambda (cmdl) - (let ((port (cmdl/output-port cmdl))) - (newline port) - (format-error-message datum arguments port)))) - "Bkpt->")))) + (lambda (port) + (newline port) + (format-error-message datum arguments port))) + "break>")))) (define (ve environment) (read-eval-print (->environment environment) false 'INHERIT)) @@ -657,109 +716,6 @@ MIT in each case. |# (if (default-object? value) (continue) (use-value value)) - (write-string "\n;Unable to PROCEED" (nearest-cmdl/output-port))) - -;;;; Prompting - -(define (prompt-for-command-char prompt #!optional cmdl) - (let ((cmdl (if (default-object? cmdl) (nearest-cmdl) cmdl))) - (hook/cmdl-prompt cmdl prompt) - (hook/read-command-char cmdl prompt))) - -(define (prompt-for-confirmation prompt #!optional cmdl) - (hook/prompt-for-confirmation (if (default-object? cmdl) (nearest-cmdl) cmdl) - prompt)) - -(define (prompt-for-expression prompt #!optional cmdl) - (hook/prompt-for-expression (if (default-object? cmdl) (nearest-cmdl) cmdl) - prompt)) - -(define (prompt-for-evaluated-expression prompt #!optional - environment syntax-table) - (let ((repl (nearest-repl))) - (hook/repl-eval repl - (prompt-for-expression prompt) - (if (default-object? environment) - (repl/environment repl) - environment) - (if (default-object? syntax-table) - (repl/syntax-table repl) - syntax-table)))) - -(define hook/read-command-char) -(define hook/prompt-for-confirmation) -(define hook/prompt-for-expression) - -(define (default/read-command-char cmdl prompt) - ;; Prompt argument is random. Emacs interface needs it right now. - prompt - (read-char-internal (cmdl/input-port cmdl))) - -(define (default/prompt-for-confirmation cmdl prompt) - (let ((input-port (cmdl/input-port cmdl)) - (prompt (string-append "\n" prompt " (y or n)? "))) - (with-output-port-cooked cmdl - (lambda (output-port) - (let loop () - (write-string prompt output-port) - (let ((char (read-char-internal input-port))) - (cond ((or (char-ci=? #\Y char) - (char-ci=? #\Space char)) - (write-string "Yes" output-port) - true) - ((or (char-ci=? #\N char) - (char-ci=? #\Rubout char)) - (write-string "No" output-port) - false) - (else - (write char output-port) - (beep output-port) - (loop))))))))) - -(define (default/prompt-for-expression cmdl prompt) - (with-output-port-cooked cmdl - (lambda (output-port) - (write-string (string-append "\n" prompt ": ") output-port))) - (read-internal (cmdl/input-port cmdl))) - -(define (with-output-port-cooked cmdl user) - (let ((output-port (cmdl/output-port cmdl))) - (terminal-bind terminal-cooked-output (output-port/channel output-port) - (lambda () - (user output-port))))) - -(define (read-internal input-port) - (terminal-bind terminal-cooked-input (input-port/channel input-port) - (lambda () - (read input-port)))) - -(define (read-char-internal input-port) - (terminal-bind terminal-raw-input (input-port/channel input-port) - (lambda () - (let loop () - (let ((char (read-char input-port))) - (if (char=? char char:newline) - (loop) - char)))))) - -(define (terminal-bind operation terminal thunk) - (if (and terminal - (channel-type=terminal? terminal)) - (let ((outside-state) - (inside-state false)) - (dynamic-wind - (lambda () - (set! outside-state (terminal-get-state terminal)) - (if inside-state - (begin - (terminal-set-state terminal inside-state) - (set! inside-state) - unspecific) - (operation terminal))) - thunk - (lambda () - (set! inside-state (terminal-get-state terminal)) - (terminal-set-state terminal outside-state) - (set! outside-state) - unspecific))) - (thunk))) \ No newline at end of file + (let ((port (nearest-cmdl/port))) + (fresh-line port) + (write-string ";Unable to PROCEED" port))) \ No newline at end of file diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 9ab27ea05..e7f63df3c 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.127 1991/11/15 05:15:17 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.128 1991/11/26 07:07:00 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -274,10 +274,10 @@ MIT in each case. |# (export () console-i/o-port console-input-port - console-output-port) + console-output-port + set-console-i/o-port!) (export (runtime emacs-interface) - hook/read-finish - hook/read-start) + the-console-port) (initialization (initialize-package!))) (define-package (runtime continuation) @@ -397,8 +397,8 @@ MIT in each case. |# debug/read-eval-print-1 debugger-failure debugger-message + debugger-presentation output-to-string - presentation print-user-friendly-name show-environment-bindings show-environment-name @@ -406,10 +406,6 @@ MIT in each case. |# show-frame show-frames write-dbg-name) - (export (runtime emacs-interface) - hook/debugger-failure - hook/debugger-message - hook/presentation) (initialization (initialize-package!))) (define-package (runtime debugging-info) @@ -620,6 +616,7 @@ MIT in each case. |# (export (runtime microcode-errors) write-operator) (export (runtime rep) + *bound-restarts* dynamic-handler-frames) (initialization (initialize-package!))) @@ -682,13 +679,8 @@ MIT in each case. |# (export (runtime gc-statistics) hook/gc-finish hook/gc-start) - (export (runtime emacs-interface) - hook/gc-finish - hook/gc-start) (export (runtime error-handler) hook/hardware-trap) - (export (runtime save/restore) - reset-gc-after-restore!) (initialization (initialize-package!))) (define-package (runtime gc-daemons) @@ -744,12 +736,20 @@ MIT in each case. |# operation/buffered-input-chars operation/buffered-output-chars operation/char-ready? + operation/input-blocking-mode operation/input-buffer-size operation/input-channel + operation/input-terminal-mode + operation/output-blocking-mode operation/output-buffer-size operation/output-channel + operation/output-terminal-mode + operation/set-input-blocking-mode operation/set-input-buffer-size - operation/set-output-buffer-size) + operation/set-input-terminal-mode + operation/set-output-blocking-mode + operation/set-output-buffer-size + operation/set-output-terminal-mode) (export (runtime file-i/o-port) operation/buffered-input-chars operation/buffered-output-chars @@ -760,17 +760,25 @@ MIT in each case. |# operation/discard-chars operation/eof? operation/flush-output + operation/input-blocking-mode operation/input-buffer-size operation/input-channel + operation/input-terminal-mode + operation/output-blocking-mode operation/output-buffer-size operation/output-channel + operation/output-terminal-mode operation/peek-char operation/read-char operation/read-chars operation/read-string operation/read-substring + operation/set-input-blocking-mode operation/set-input-buffer-size + operation/set-input-terminal-mode + operation/set-output-blocking-mode operation/set-output-buffer-size + operation/set-output-terminal-mode operation/write-char operation/write-string operation/write-substring) @@ -889,6 +897,7 @@ MIT in each case. |# output-port/custom-operation output-port/operation output-port/operation-names + output-port/operation/discretionary-flush output-port/operation/flush-output output-port/operation/write-char output-port/operation/write-string @@ -896,11 +905,23 @@ MIT in each case. |# output-port/state output-port? port/copy + port/input-blocking-mode port/input-channel - port/output-channel + port/input-terminal-mode port/operation port/operation-names + port/output-blocking-mode + port/output-channel + port/output-terminal-mode + port/set-input-blocking-mode + port/set-input-terminal-mode + port/set-output-blocking-mode + port/set-output-terminal-mode port/state + port/with-input-blocking-mode + port/with-input-terminal-mode + port/with-output-blocking-mode + port/with-output-terminal-mode port? set-input-port/state! set-output-port/state! @@ -942,9 +963,11 @@ MIT in each case. |# clear current-output-port display + flush-output fresh-line guarantee-output-port newline + output-port/discretionary-flush output-port/flush-output output-port/write-char output-port/write-object @@ -967,7 +990,7 @@ MIT in each case. |# timer-interrupt with-external-interrupts-handler) (export (runtime emacs-interface) - hook/^g-interrupt + hook/^G-interrupt hook/clean-input/flush-typeahead) (initialization (initialize-package!))) @@ -1333,8 +1356,6 @@ MIT in each case. |# system-global-parser-table) (export (runtime character) char-set/atom-delimiters) - (export (runtime input-port) - parse-object/internal) (export (runtime syntaxer) lambda-optional-tag lambda-rest-tag) @@ -1580,6 +1601,7 @@ MIT in each case. |# output-buffer/size output-buffer/write-char-block output-buffer/write-string-block + output-buffer/write-substring-block set-channel-port!) (export (runtime microcode-errors) port-error-test) @@ -1608,6 +1630,7 @@ MIT in each case. |# record-accessor record-constructor record-copy + record-modifier record-predicate record-type-descriptor record-type-field-names @@ -1650,15 +1673,15 @@ MIT in each case. |# cmdl-message/active cmdl-message/append cmdl-message/null - cmdl-message/standard cmdl-message/strings - cmdl-message/value cmdl/base cmdl/driver - cmdl/input-port + cmdl/operation + cmdl/operation-names + cmdl/port cmdl/level - cmdl/output-port cmdl/parent + cmdl/start cmdl/state cmdl? ge @@ -1666,9 +1689,11 @@ MIT in each case. |# in initial-top-level-repl make-cmdl + make-repl + make-repl-message nearest-cmdl - nearest-cmdl/input-port - nearest-cmdl/output-port + nearest-cmdl/level + nearest-cmdl/port nearest-repl nearest-repl/condition nearest-repl/environment @@ -1676,10 +1701,6 @@ MIT in each case. |# out pe proceed - prompt-for-command-char - prompt-for-confirmation - prompt-for-expression - prompt-for-evaluated-expression push-cmdl push-repl re @@ -1688,42 +1709,32 @@ MIT in each case. |# repl-history/record! repl-history/size repl/base + repl/condition repl/environment repl/parent repl/printer-history repl/prompt repl/reader-history + repl/start repl/syntax-table repl:allow-restart-notifications? repl? restart - set-cmdl/input-port! - set-cmdl/output-port! set-cmdl/state! set-repl/environment! set-repl/printer-history! set-repl/prompt! set-repl/reader-history! set-repl/syntax-table! - ve - with-cmdl/input-port - with-cmdl/output-port) + ve) (export (runtime load) hook/repl-eval hook/repl-write) (export (runtime emacs-interface) - hook/cmdl-message - hook/cmdl-prompt hook/error-decision - hook/prompt-for-confirmation - hook/prompt-for-expression - hook/read-command-char - hook/repl-environment - hook/repl-read - hook/repl-write - repl-write/show-hash?) - (export (runtime debugger-command-loop) - hook/repl-environment) + set-cmdl/port!) + (export (runtime user-interface) + hook/repl-eval) (export (runtime debugger) write-restarts) (initialization (initialize-package!))) @@ -2237,6 +2248,30 @@ MIT in each case. |# set-working-directory-pathname! with-working-directory-pathname working-directory-pathname) + (initialization (initialize-package!))) + +(define-package (runtime user-interface) + (files "usrint") + (parent ()) + (export () + prompt-for-command-char + prompt-for-command-expression + prompt-for-confirmation + prompt-for-evaluated-expression + prompt-for-expression) + (export (runtime rep) + port/set-default-environment + port/set-default-syntax-table + port/write-result) + (export (runtime working-directory) + port/set-default-directory) + (export (runtime debugger-command-loop) + port/debugger-failure + port/debugger-message + port/debugger-presentation) + (export (runtime gc-statistics) + port/gc-finish + port/gc-start) (export (runtime emacs-interface) - hook/set-working-directory-pathname!) - (initialization (initialize-package!))) \ No newline at end of file + port/read-finish + port/read-start)) \ No newline at end of file diff --git a/v7/src/runtime/savres.scm b/v7/src/runtime/savres.scm index ca9f2d71e..817abf988 100644 --- a/v7/src/runtime/savres.scm +++ b/v7/src/runtime/savres.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.22 1991/11/04 20:29:54 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.23 1991/11/26 07:07:07 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -69,14 +69,13 @@ MIT in each case. |# (if (string? identify) unspecific false)) (lambda () (set! time-world-saved time) - (reset-gc-after-restore!) (event-distributor/invoke! event:after-restore) (cond ((string? identify) (set! world-identification identify) (clear console-output-port) (abort->top-level (lambda (cmdl) - (identify-world (cmdl/output-port cmdl)) + (identify-world (cmdl/port cmdl)) (event-distributor/invoke! event:after-restart)))) ((not identify) true) @@ -147,7 +146,7 @@ MIT in each case. |# (if (default-object? port) (current-output-port) (guarantee-output-port port)))) - (newline port) + (fresh-line port) (write-string world-identification port) (if time-world-saved (begin diff --git a/v7/src/runtime/ttyio.scm b/v7/src/runtime/ttyio.scm index b0d00b9c5..5e11b0439 100644 --- a/v7/src/runtime/ttyio.scm +++ b/v7/src/runtime/ttyio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/ttyio.scm,v 1.1 1991/11/15 05:17:32 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/ttyio.scm,v 1.2 1991/11/26 07:07:11 cph Exp $ Copyright (c) 1991 Massachusetts Institute of Technology @@ -38,75 +38,103 @@ MIT in each case. |# (declare (usual-integrations)) (define (initialize-package!) - (set! hook/read-start default/read-start) - (set! hook/read-finish default/read-finish) - (set! console-i/o-port - (make-i/o-port - `((BEEP ,operation/beep) - (BUFFERED-INPUT-CHARS ,operation/buffered-input-chars) - (BUFFERED-OUTPUT-CHARS ,operation/buffered-output-chars) - (CHAR-READY? ,operation/char-ready?) - (CLEAR ,operation/clear) - (DISCARD-CHAR ,operation/read-char) - (FLUSH-OUTPUT ,operation/flush-output) - (INPUT-BUFFER-SIZE ,operation/input-buffer-size) - (INPUT-CHANNEL ,operation/input-channel) - (OUTPUT-BUFFER-SIZE ,operation/output-buffer-size) - (OUTPUT-CHANNEL ,operation/output-channel) - (PEEK-CHAR ,operation/peek-char) - (PRINT-SELF ,operation/print-self) - (READ-CHAR ,operation/read-char) - (READ-FINISH! ,operation/read-finish!) - (READ-START! ,operation/read-start!) - (SET-INPUT-BUFFER-SIZE ,operation/set-input-buffer-size) - (SET-OUTPUT-BUFFER-SIZE ,operation/set-output-buffer-size) - (WRITE-CHAR ,operation/write-char) - (WRITE-STRING ,operation/write-string) - (X-SIZE ,operation/x-size) - (Y-SIZE ,operation/y-size)) - false)) - (set! console-input-port console-i/o-port) - (set! console-output-port console-i/o-port) - (reset-console) - (add-event-receiver! event:after-restore reset-console) + (let ((input-channel (tty-input-channel)) + (output-channel (tty-output-channel))) + (set! the-console-port + (make-i/o-port + `((BEEP ,operation/beep) + (BUFFERED-INPUT-CHARS ,operation/buffered-input-chars) + (BUFFERED-OUTPUT-CHARS ,operation/buffered-output-chars) + (CHAR-READY? ,operation/char-ready?) + (CLEAR ,operation/clear) + (DISCARD-CHAR ,operation/read-char) + (DISCRETIONARY-FLUSH-OUTPUT ,operation/discretionary-flush-output) + (FLUSH-OUTPUT ,operation/flush-output) + (INPUT-BLOCKING-MODE ,operation/input-blocking-mode) + (INPUT-BUFFER-SIZE ,operation/input-buffer-size) + (INPUT-CHANNEL ,operation/input-channel) + (INPUT-TERMINAL-MODE ,operation/input-terminal-mode) + (OUTPUT-BLOCKING-MODE ,operation/output-blocking-mode) + (OUTPUT-BUFFER-SIZE ,operation/output-buffer-size) + (OUTPUT-CHANNEL ,operation/output-channel) + (OUTPUT-TERMINAL-MODE ,operation/output-terminal-mode) + (PEEK-CHAR ,operation/peek-char) + (PRINT-SELF ,operation/print-self) + (READ-CHAR ,operation/read-char) + (READ-FINISH ,operation/read-finish) + (SET-INPUT-BLOCKING-MODE ,operation/set-input-blocking-mode) + (SET-INPUT-BUFFER-SIZE ,operation/set-input-buffer-size) + (SET-INPUT-TERMINAL-MODE ,operation/set-input-terminal-mode) + (SET-OUTPUT-BLOCKING-MODE ,operation/set-output-blocking-mode) + (SET-OUTPUT-BUFFER-SIZE ,operation/set-output-buffer-size) + (SET-OUTPUT-TERMINAL-MODE ,operation/set-output-terminal-mode) + (WRITE-CHAR ,operation/write-char) + (WRITE-SUBSTRING ,operation/write-substring) + (X-SIZE ,operation/x-size) + (Y-SIZE ,operation/y-size)) + (make-console-port-state + (make-input-buffer input-channel input-buffer-size) + (make-output-buffer output-channel output-buffer-size) + (channel-type=file? input-channel)))) + (set-channel-port! input-channel the-console-port) + (set-channel-port! output-channel the-console-port)) (add-event-receiver! event:before-exit save-console-input) - (set-current-input-port! console-i/o-port) - (set-current-output-port! console-i/o-port)) - -(define console-i/o-port) -(define console-input-port) -(define console-output-port) + (add-event-receiver! event:after-restore reset-console) + (set-console-i/o-port! the-console-port) + (set-current-input-port! the-console-port) + (set-current-output-port! the-console-port)) +(define the-console-port) +(define input-buffer-size 512) +(define output-buffer-size 512) + (define (save-console-input) ((ucode-primitive reload-save-string 1) (input-buffer/buffer-contents (port/input-buffer console-input-port)))) (define (reset-console) - (set-port/state! - console-i/o-port - (let ((input-channel (tty-input-channel)) - (output-channel (tty-output-channel))) - (set-channel-port! input-channel console-i/o-port) - (set-channel-port! output-channel console-i/o-port) - (make-console-port-state - (let ((buffer (make-input-buffer input-channel input-buffer-size))) - (let ((contents ((ucode-primitive reload-retrieve-string 0)))) - (if contents - (input-buffer/set-buffer-contents buffer contents))) - buffer) - (make-output-buffer output-channel output-buffer-size) - (channel-type=file? input-channel))))) + (let ((input-channel (tty-input-channel)) + (output-channel (tty-output-channel)) + (state (port/state the-console-port))) + (set-channel-port! input-channel the-console-port) + (set-channel-port! output-channel the-console-port) + (set-console-port-state/input-buffer! + state + (let ((buffer + (make-input-buffer + input-channel + (input-buffer/size (console-port-state/input-buffer state))))) + (let ((contents ((ucode-primitive reload-retrieve-string 0)))) + (if contents + (input-buffer/set-buffer-contents buffer contents))) + buffer)) + (set-console-port-state/output-buffer! + state + (make-output-buffer + output-channel + (output-buffer/size (console-port-state/output-buffer state)))) + (set-console-port-state/echo-input?! state + (channel-type=file? input-channel)))) + +(define (set-console-i/o-port! port) + (if (not (i/o-port? port)) + (error:wrong-type-argument port "I/O port" 'SET-CONSOLE-I/O-PORT!)) + (set! console-i/o-port port) + (set! console-input-port port) + (set! console-output-port port) + unspecific) -(define input-buffer-size 512) -(define output-buffer-size 512) +(define console-i/o-port) +(define console-input-port) +(define console-output-port) (define-structure (console-port-state (type vector) (conc-name console-port-state/)) ;; First two elements of this vector are required by the generic ;; I/O port operations. - (input-buffer false read-only true) - (output-buffer false read-only true) - (echo-input? false read-only true)) + input-buffer + output-buffer + echo-input?) (define-integrable (port/input-buffer port) (console-port-state/input-buffer (port/state port))) @@ -117,34 +145,27 @@ MIT in each case. |# (define (operation/peek-char port) (let ((char (input-buffer/peek-char (port/input-buffer port)))) (if (eof-object? char) - (signal-end-of-input)) + (signal-end-of-input port)) char)) (define (operation/read-char port) (let ((char (input-buffer/read-char (port/input-buffer port)))) (if (eof-object? char) - (signal-end-of-input)) + (signal-end-of-input port)) (if char (cond ((console-port-state/echo-input? (port/state port)) - (output-port/write-char console-output-port char) - (output-port/flush-output console-output-port)) + (output-port/write-char port char)) (transcript-port (output-port/write-char transcript-port char) - (output-port/flush-output transcript-port)))) + (output-port/discretionary-flush transcript-port)))) char)) -(define (signal-end-of-input) - (write-string "\nEnd of input stream reached" console-output-port) +(define (signal-end-of-input port) + (fresh-line port) + (write-string "End of input stream reached" port) (%exit)) -(define (operation/read-start! port) - port - (hook/read-start)) - -(define hook/read-start) -(define (default/read-start) false) - -(define (operation/read-finish! port) +(define (operation/read-finish port) (let ((buffer (port/input-buffer port))) (let loop () (if (input-buffer/char-ready? buffer 0) @@ -153,28 +174,32 @@ MIT in each case. |# (begin (operation/read-char port) (loop))))))) - (hook/read-finish)) - -(define hook/read-finish) -(define (default/read-finish) false) + (output-port/discretionary-flush port)) (define (operation/write-char port char) (output-buffer/write-char-block (port/output-buffer port) char) (if transcript-port (output-port/write-char transcript-port char))) -(define (operation/write-string port string) - (output-buffer/write-string-block (port/output-buffer port) string) - (if transcript-port (output-port/write-string transcript-port string))) +(define (operation/write-substring port string start end) + (output-buffer/write-substring-block (port/output-buffer port) + string start end) + (if transcript-port + (output-port/write-substring transcript-port string start end))) (define (operation/flush-output port) (output-buffer/drain-block (port/output-buffer port)) (if transcript-port (output-port/flush-output transcript-port))) +(define (operation/discretionary-flush-output port) + (output-buffer/drain-block (port/output-buffer port)) + (if transcript-port + (output-port/discretionary-flush transcript-port))) + (define (operation/clear port) - (operation/write-string port ((ucode-primitive tty-command-clear 0)))) + (output-port/write-string port ((ucode-primitive tty-command-clear 0)))) (define (operation/beep port) - (operation/write-string port ((ucode-primitive tty-command-beep 0)))) + (output-port/write-string port ((ucode-primitive tty-command-beep 0)))) (define (operation/x-size port) port diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 80175be75..c19651b2c 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.141 1991/11/04 20:30:34 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.142 1991/11/26 07:07:15 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -45,7 +45,7 @@ MIT in each case. |# '())) (add-system! microcode-system) (add-event-receiver! event:after-restore snarf-microcode-version!) - (add-identification! "Runtime" 14 141)) + (add-identification! "Runtime" 14 142)) (define microcode-system) diff --git a/v7/src/runtime/where.scm b/v7/src/runtime/where.scm index 7ea61b499..35bd8b315 100644 --- a/v7/src/runtime/where.scm +++ b/v7/src/runtime/where.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 14.9 1991/02/15 18:07:46 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 14.10 1991/11/26 07:07:26 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -49,12 +49,12 @@ MIT in each case. |# (letter-commands command-set (cmdl-message/active - (lambda (cmdl) - cmdl - (show-current-frame wstate true) + (lambda (port) + (show-current-frame wstate true port) (debugger-message + port "You are now in the environment inspector. Type q to quit, ? for commands."))) - "Where-->" + "where>" wstate))))) (define-structure (wstate @@ -91,52 +91,54 @@ MIT in each case. |# (define command-set) -(define (show wstate) - (show-current-frame wstate false)) +(define (show wstate port) + (show-current-frame wstate false port)) -(define (show-current-frame wstate brief?) - (presentation - (lambda () - (let ((frame-list (wstate/frame-list wstate))) - (show-frame (car frame-list) - (length (cdr frame-list)) - brief?))))) +(define (show-current-frame wstate brief? port) + (debugger-presentation port + (lambda () + (let ((frame-list (wstate/frame-list wstate))) + (show-frame (car frame-list) + (length (cdr frame-list)) + brief? + port))))) -(define (show-all wstate) - (show-frames (car (last-pair (wstate/frame-list wstate))) 0)) +(define (show-all wstate port) + (show-frames (car (last-pair (wstate/frame-list wstate))) 0 port)) -(define (parent wstate) +(define (parent wstate port) (let ((frame-list (wstate/frame-list wstate))) (if (eq? true (environment-has-parent? (car frame-list))) (begin (set-wstate/frame-list! wstate (cons (environment-parent (car frame-list)) frame-list)) - (show-current-frame wstate true)) - (debugger-failure "The current frame has no parent")))) + (show-current-frame wstate true port)) + (debugger-failure port "The current frame has no parent")))) -(define (son wstate) +(define (son wstate port) (let ((frames (wstate/frame-list wstate))) (if (null? (cdr frames)) (debugger-failure + port "This is the original frame; its children cannot be found") (begin (set-wstate/frame-list! wstate (cdr frames)) - (show-current-frame wstate true))))) + (show-current-frame wstate true port))))) -(define (command/print-environment-procedure wstate) - (show-environment-procedure (car (wstate/frame-list wstate)))) +(define (command/print-environment-procedure wstate port) + (show-environment-procedure (car (wstate/frame-list wstate)) port)) -(define (recursive-where wstate) - (let ((inp (prompt-for-expression "Object to evaluate and examine"))) - (debugger-message "New where!") +(define (recursive-where wstate port) + (let ((inp (prompt-for-expression "Object to evaluate and examine" port))) + (debugger-message port "New where!") (debug/where (debug/eval inp (car (wstate/frame-list wstate)))))) -(define (enter wstate) +(define (enter wstate port) + port (debug/read-eval-print (car (wstate/frame-list wstate)) "the environment inspector" - "the desired environment" - "Eval-in-env-->")) + "the environment for this frame")) -(define (show-object wstate) - (debug/read-eval-print-1 (car (wstate/frame-list wstate)))) \ No newline at end of file +(define (show-object wstate port) + (debug/read-eval-print-1 (car (wstate/frame-list wstate)) port)) \ No newline at end of file diff --git a/v7/src/runtime/wrkdir.scm b/v7/src/runtime/wrkdir.scm index 815519741..db5fde9ab 100644 --- a/v7/src/runtime/wrkdir.scm +++ b/v7/src/runtime/wrkdir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wrkdir.scm,v 14.4 1991/11/05 20:37:28 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wrkdir.scm,v 14.5 1991/11/26 07:07:31 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -48,8 +48,6 @@ MIT in each case. |# ((ucode-primitive working-directory-pathname)))))) (set! *working-directory-pathname* pathname) (set! *default-pathname-defaults* pathname)) - (set! hook/set-working-directory-pathname! - default/set-working-directory-pathname!) unspecific) (define *working-directory-pathname*) @@ -57,7 +55,7 @@ MIT in each case. |# (define (working-directory-pathname) *working-directory-pathname*) -(define (set-working-directory-pathname! name) +(define (%set-working-directory-pathname! name) (let ((pathname (pathname-as-directory (merge-pathnames name *working-directory-pathname*)))) @@ -69,20 +67,19 @@ MIT in each case. |# (set! *working-directory-pathname* pathname) ((ucode-primitive set-working-directory-pathname! 1) (->namestring pathname)) - (hook/set-working-directory-pathname! pathname) pathname))) -(define hook/set-working-directory-pathname!) -(define (default/set-working-directory-pathname! pathname) - pathname - false) +(define (set-working-directory-pathname! name) + (let ((pathname (%set-working-directory-pathname! name))) + (port/set-default-directory (nearest-cmdl/port) pathname) + pathname)) (define (with-working-directory-pathname name thunk) (let ((old-pathname)) (dynamic-wind (lambda () (set! old-pathname (working-directory-pathname)) - (set-working-directory-pathname! name)) + (%set-working-directory-pathname! name)) thunk (lambda () (set! name (working-directory-pathname)) - (set-working-directory-pathname! old-pathname))))) \ No newline at end of file + (%set-working-directory-pathname! old-pathname))))) \ No newline at end of file diff --git a/v8/src/runtime/dbgutl.scm b/v8/src/runtime/dbgutl.scm index 31ac06c5a..3c377831c 100644 --- a/v8/src/runtime/dbgutl.scm +++ b/v8/src/runtime/dbgutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.13 1991/07/15 23:40:42 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.14 1991/11/26 07:05:11 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -37,41 +37,45 @@ MIT in each case. |# (declare (usual-integrations)) -(define (print-user-friendly-name environment) +(define (print-user-friendly-name environment port) (let ((name (environment-procedure-name environment))) (if name (let ((rename (special-form-procedure-name? name))) (if rename - (begin (write-string "a ") - (write-string (string-upcase rename)) - (write-string " special form")) - (begin (write-string "the procedure: ") - (write-dbg-upcase-name name)))) - (write-string "an unknown procedure")))) - -(define (show-environment-procedure environment) + (begin + (write-string "a " port) + (write-string (string-upcase rename) port) + (write-string " special form") port) + (begin + (write-string "the procedure: " port) + (write-dbg-upcase-name name port)))) + (write-string "an unknown procedure" port)))) + +(define (show-environment-procedure environment port) (let ((scode-lambda (environment-lambda environment))) (if scode-lambda - (presentation (lambda () (pretty-print scode-lambda))) - (debugger-failure "No procedure for this environment.")))) + (debugger-presentation port + (lambda () + (pretty-print scode-lambda port))) + (debugger-failure port "No procedure for this environment.")))) -(define (write-dbg-name name) - (if (string? name) (write-string name) (write name))) +(define (write-dbg-name name port) + (if (string? name) (write-string name port) (write name port))) -(define (write-dbg-upcase-name name) +(define (write-dbg-upcase-name name port) (let ((string (if (string? name) name (with-output-to-string (lambda () (write name)))))) - (write-string (string-upcase string)))) + (write-string (string-upcase string) port))) -(define (debug/read-eval-print-1 environment) +(define (debug/read-eval-print-1 environment port) (let ((value - (debug/eval (prompt-for-expression "Evaluate expression") + (debug/eval (prompt-for-expression "Evaluate expression" port) environment))) (if (undefined-value? value) - (debugger-message "No value") - (debugger-message "Value: " value)))) + (debugger-message port "No value") + (debugger-message port "Value: " value)))) (define (output-to-string length thunk) (let ((x (with-output-to-truncated-string length thunk))) @@ -79,75 +83,77 @@ MIT in each case. |# (substring-move-right! " ..." 0 4 (cdr x) (- length 4))) (cdr x))) -(define (show-frames environment depth) - (presentation - (lambda () - (let loop ((environment environment) (depth depth)) - (write-string "----------------------------------------") - (newline) - (show-frame environment depth true) - (if (eq? true (environment-has-parent? environment)) - (begin - (newline) - (newline) - (loop (environment-parent environment) (1+ depth)))))))) - -(define (show-frame environment depth brief?) - (show-environment-name environment) +(define (show-frames environment depth port) + (debugger-presentation port + (lambda () + (let loop ((environment environment) (depth depth)) + (write-string "----------------------------------------" port) + (newline port) + (show-frame environment depth true port) + (if (eq? true (environment-has-parent? environment)) + (begin + (newline port) + (newline port) + (loop (environment-parent environment) (1+ depth)))))))) + +(define (show-frame environment depth brief? port) + (show-environment-name environment port) (if (not (negative? depth)) - (begin (newline) - (write-string "Depth (relative to initial environment): ") - (write depth))) + (begin + (newline port) + (write-string "Depth (relative to initial environment): " port) + (write depth port))) (if (not (and (environment->package environment) brief?)) (begin - (newline) - (show-environment-bindings environment brief?)))) + (newline port) + (show-environment-bindings environment brief? port)))) -(define (show-environment-name environment) - (write-string "Environment ") +(define (show-environment-name environment port) + (write-string "Environment " port) (let ((package (environment->package environment))) (if package (begin - (write-string "named: ") - (write (package/name package))) + (write-string "named: " port) + (write (package/name package) port)) (begin - (write-string "created by ") - (print-user-friendly-name environment))))) + (write-string "created by " port) + (print-user-friendly-name environment port))))) -(define (show-environment-bindings environment brief?) +(define (show-environment-bindings environment brief? port) (let ((names (environment-bound-names environment))) (let ((n-bindings (length names)) (finish (lambda (names) - (newline) + (newline port) (for-each (lambda (name) (print-binding name - (environment-lookup environment name))) + (environment-lookup environment name) + port)) names)))) (cond ((zero? n-bindings) - (write-string " has no bindings")) + (write-string " has no bindings" port)) ((and brief? (> n-bindings brief-bindings-limit)) - (write-string " has ") - (write n-bindings) - (write-string " bindings (first ") - (write brief-bindings-limit) - (write-string " shown):") + (write-string " has " port) + (write n-bindings port) + (write-string " bindings (first " port) + (write brief-bindings-limit port) + (write-string " shown):" port) (finish (list-head names brief-bindings-limit))) (else - (write-string " has bindings:") + (write-string " has bindings:" port) (finish names)))))) (define brief-bindings-limit 16) -(define (print-binding name value) - (let ((x-size (output-port/x-size (current-output-port)))) - (newline) +(define (print-binding name value port) + (let ((x-size (output-port/x-size port))) + (newline port) (write-string (let ((name (output-to-string (quotient x-size 2) (lambda () - (write-dbg-name name))))) + (write-dbg-name name (current-output-port)))))) (if (unassigned-reference-trap? value) (string-append name " is unassigned") (let ((s (string-append name " = "))) @@ -155,40 +161,19 @@ MIT in each case. |# s (output-to-string (max (- x-size (string-length s)) 0) (lambda () - (write value)))))))))) - -(define hook/debugger-failure) -(define hook/debugger-message) -(define hook/presentation) - -(define (initialize-package!) - (set! hook/debugger-failure default/debugger-failure) - (set! hook/debugger-message default/debugger-message) - (set! hook/presentation default/presentation) - unspecific) + (write value))))))) + port))) -(define (debugger-failure . objects) - (hook/debugger-failure (message-arguments->string objects))) +(define (debugger-failure port . objects) + (port/debugger-failure port (message-arguments->string objects))) -(define (default/debugger-failure message) - (beep) - (default/debugger-message message)) - -(define (debugger-message . objects) - (hook/debugger-message (message-arguments->string objects))) - -(define (default/debugger-message message) - (newline) - (write-string message)) +(define (debugger-message port . objects) + (port/debugger-message port (message-arguments->string objects))) (define (message-arguments->string objects) (apply string-append (map (lambda (x) (if (string? x) x (write-to-string x))) objects))) -(define (presentation thunk) - (hook/presentation thunk)) - -(define (default/presentation thunk) - (newline) - (thunk)) \ No newline at end of file +(define (debugger-presentation port thunk) + (port/debugger-presentation port thunk)) \ No newline at end of file diff --git a/v8/src/runtime/global.scm b/v8/src/runtime/global.scm index c66fef185..99752fbd0 100644 --- a/v8/src/runtime/global.scm +++ b/v8/src/runtime/global.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.33 1991/11/04 20:29:00 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.34 1991/11/26 07:06:16 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -218,9 +218,9 @@ MIT in each case. |# (define (fasdump object filename) (let ((filename (->namestring (merge-pathnames filename))) - (port (cmdl/output-port (nearest-cmdl)))) - (newline port) - (write-string "Dumping " port) + (port (nearest-cmdl/port))) + (fresh-line port) + (write-string ";Dumping " port) (write (enough-namestring filename) port) (if (not ((ucode-primitive primitive-fasdump) object filename false)) (error "FASDUMP: Object is too large to be dumped:" object)) diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm index 55c108e6b..f4dfa0f42 100644 --- a/v8/src/runtime/load.scm +++ b/v8/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.30 1991/11/04 20:29:20 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.31 1991/11/26 07:06:29 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -93,9 +93,9 @@ MIT in each case. |# (define (loading-message suppress-loading-message? pathname do-it) (if suppress-loading-message? (do-it) - (let ((port (cmdl/output-port (nearest-cmdl)))) - (newline port) - (write-string "Loading " port) + (let ((port (nearest-cmdl/port))) + (fresh-line port) + (write-string ";Loading " port) (write (enough-namestring pathname) port) (let ((value (do-it))) (write-string " -- done" port) @@ -264,8 +264,7 @@ MIT in each case. |# (repl/syntax-table repl) syntax-table)))) (lambda (s-expression) - (hook/repl-eval repl - s-expression + (hook/repl-eval s-expression environment syntax-table)))))) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 088339a9f..89f04e741 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.127 1991/11/15 05:15:17 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.128 1991/11/26 07:07:00 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -274,10 +274,10 @@ MIT in each case. |# (export () console-i/o-port console-input-port - console-output-port) + console-output-port + set-console-i/o-port!) (export (runtime emacs-interface) - hook/read-finish - hook/read-start) + the-console-port) (initialization (initialize-package!))) (define-package (runtime continuation) @@ -397,8 +397,8 @@ MIT in each case. |# debug/read-eval-print-1 debugger-failure debugger-message + debugger-presentation output-to-string - presentation print-user-friendly-name show-environment-bindings show-environment-name @@ -406,10 +406,6 @@ MIT in each case. |# show-frame show-frames write-dbg-name) - (export (runtime emacs-interface) - hook/debugger-failure - hook/debugger-message - hook/presentation) (initialization (initialize-package!))) (define-package (runtime debugging-info) @@ -620,6 +616,7 @@ MIT in each case. |# (export (runtime microcode-errors) write-operator) (export (runtime rep) + *bound-restarts* dynamic-handler-frames) (initialization (initialize-package!))) @@ -682,13 +679,8 @@ MIT in each case. |# (export (runtime gc-statistics) hook/gc-finish hook/gc-start) - (export (runtime emacs-interface) - hook/gc-finish - hook/gc-start) (export (runtime error-handler) hook/hardware-trap) - (export (runtime save/restore) - reset-gc-after-restore!) (initialization (initialize-package!))) (define-package (runtime gc-daemons) @@ -744,12 +736,20 @@ MIT in each case. |# operation/buffered-input-chars operation/buffered-output-chars operation/char-ready? + operation/input-blocking-mode operation/input-buffer-size operation/input-channel + operation/input-terminal-mode + operation/output-blocking-mode operation/output-buffer-size operation/output-channel + operation/output-terminal-mode + operation/set-input-blocking-mode operation/set-input-buffer-size - operation/set-output-buffer-size) + operation/set-input-terminal-mode + operation/set-output-blocking-mode + operation/set-output-buffer-size + operation/set-output-terminal-mode) (export (runtime file-i/o-port) operation/buffered-input-chars operation/buffered-output-chars @@ -760,17 +760,25 @@ MIT in each case. |# operation/discard-chars operation/eof? operation/flush-output + operation/input-blocking-mode operation/input-buffer-size operation/input-channel + operation/input-terminal-mode + operation/output-blocking-mode operation/output-buffer-size operation/output-channel + operation/output-terminal-mode operation/peek-char operation/read-char operation/read-chars operation/read-string operation/read-substring + operation/set-input-blocking-mode operation/set-input-buffer-size + operation/set-input-terminal-mode + operation/set-output-blocking-mode operation/set-output-buffer-size + operation/set-output-terminal-mode operation/write-char operation/write-string operation/write-substring) @@ -889,6 +897,7 @@ MIT in each case. |# output-port/custom-operation output-port/operation output-port/operation-names + output-port/operation/discretionary-flush output-port/operation/flush-output output-port/operation/write-char output-port/operation/write-string @@ -896,11 +905,23 @@ MIT in each case. |# output-port/state output-port? port/copy + port/input-blocking-mode port/input-channel - port/output-channel + port/input-terminal-mode port/operation port/operation-names + port/output-blocking-mode + port/output-channel + port/output-terminal-mode + port/set-input-blocking-mode + port/set-input-terminal-mode + port/set-output-blocking-mode + port/set-output-terminal-mode port/state + port/with-input-blocking-mode + port/with-input-terminal-mode + port/with-output-blocking-mode + port/with-output-terminal-mode port? set-input-port/state! set-output-port/state! @@ -942,9 +963,11 @@ MIT in each case. |# clear current-output-port display + flush-output fresh-line guarantee-output-port newline + output-port/discretionary-flush output-port/flush-output output-port/write-char output-port/write-object @@ -967,7 +990,7 @@ MIT in each case. |# timer-interrupt with-external-interrupts-handler) (export (runtime emacs-interface) - hook/^g-interrupt + hook/^G-interrupt hook/clean-input/flush-typeahead) (initialization (initialize-package!))) @@ -1333,8 +1356,6 @@ MIT in each case. |# system-global-parser-table) (export (runtime character) char-set/atom-delimiters) - (export (runtime input-port) - parse-object/internal) (export (runtime syntaxer) lambda-optional-tag lambda-rest-tag) @@ -1580,6 +1601,7 @@ MIT in each case. |# output-buffer/size output-buffer/write-char-block output-buffer/write-string-block + output-buffer/write-substring-block set-channel-port!) (export (runtime microcode-errors) port-error-test) @@ -1608,6 +1630,7 @@ MIT in each case. |# record-accessor record-constructor record-copy + record-modifier record-predicate record-type-descriptor record-type-field-names @@ -1650,15 +1673,15 @@ MIT in each case. |# cmdl-message/active cmdl-message/append cmdl-message/null - cmdl-message/standard cmdl-message/strings - cmdl-message/value cmdl/base cmdl/driver - cmdl/input-port + cmdl/operation + cmdl/operation-names + cmdl/port cmdl/level - cmdl/output-port cmdl/parent + cmdl/start cmdl/state cmdl? ge @@ -1666,9 +1689,11 @@ MIT in each case. |# in initial-top-level-repl make-cmdl + make-repl + make-repl-message nearest-cmdl - nearest-cmdl/input-port - nearest-cmdl/output-port + nearest-cmdl/level + nearest-cmdl/port nearest-repl nearest-repl/condition nearest-repl/environment @@ -1676,10 +1701,6 @@ MIT in each case. |# out pe proceed - prompt-for-command-char - prompt-for-confirmation - prompt-for-expression - prompt-for-evaluated-expression push-cmdl push-repl re @@ -1688,42 +1709,32 @@ MIT in each case. |# repl-history/record! repl-history/size repl/base + repl/condition repl/environment repl/parent repl/printer-history repl/prompt repl/reader-history + repl/start repl/syntax-table repl:allow-restart-notifications? repl? restart - set-cmdl/input-port! - set-cmdl/output-port! set-cmdl/state! set-repl/environment! set-repl/printer-history! set-repl/prompt! set-repl/reader-history! set-repl/syntax-table! - ve - with-cmdl/input-port - with-cmdl/output-port) + ve) (export (runtime load) hook/repl-eval hook/repl-write) (export (runtime emacs-interface) - hook/cmdl-message - hook/cmdl-prompt hook/error-decision - hook/prompt-for-confirmation - hook/prompt-for-expression - hook/read-command-char - hook/repl-environment - hook/repl-read - hook/repl-write - repl-write/show-hash?) - (export (runtime debugger-command-loop) - hook/repl-environment) + set-cmdl/port!) + (export (runtime user-interface) + hook/repl-eval) (export (runtime debugger) write-restarts) (initialization (initialize-package!))) @@ -2237,6 +2248,30 @@ MIT in each case. |# set-working-directory-pathname! with-working-directory-pathname working-directory-pathname) + (initialization (initialize-package!))) + +(define-package (runtime user-interface) + (files "usrint") + (parent ()) + (export () + prompt-for-command-char + prompt-for-command-expression + prompt-for-confirmation + prompt-for-evaluated-expression + prompt-for-expression) + (export (runtime rep) + port/set-default-environment + port/set-default-syntax-table + port/write-result) + (export (runtime working-directory) + port/set-default-directory) + (export (runtime debugger-command-loop) + port/debugger-failure + port/debugger-message + port/debugger-presentation) + (export (runtime gc-statistics) + port/gc-finish + port/gc-start) (export (runtime emacs-interface) - hook/set-working-directory-pathname!) - (initialization (initialize-package!))) \ No newline at end of file + port/read-finish + port/read-start)) \ No newline at end of file -- 2.25.1