* 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.
#| -*-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
(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."))
\f
(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
(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
#| -*-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
(declare (usual-integrations))
\f
-(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)))
(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))))
\f
-(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 " = ")))
s
(output-to-string (max (- x-size (string-length s)) 0)
(lambda ()
- (write value))))))))))
-\f
-(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
#| -*-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
(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)))))
\f
(define (make-initial-dstate object)
((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)
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))))
\f
-(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))))
+\f
+(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 "###"))
-\f
-(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)))))
+\f
+(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)))))))
\f
-;;;; 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
(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")
(lambda ()
(write-string ((debugging-info/noise expression) false)))))
(else
- ";undefined expression"))))
+ ";undefined expression"))
+ port))
\f
;;;; 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
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)))
(loop next (cons subproblem subproblems) (-1+ delta))
(begin
(debugger-failure
+ port
"Subproblem number too large (limit is "
(length subproblems)
" inclusive).")
(top-level-loop))))))))))
\f
-(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)))))
-\f
;;;; 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))
(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)
+\f
+(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."))
(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
\f
;;;; 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))
\f
;;;; 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)
(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)))))))))))
\f
;;;; 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)
"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)
(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))))))
\f
;;;; 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)
'()
(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))
(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)
+\f
+(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
(standard-scheme-find-file-initialization
'#(
- ("Sgraph" (runtime starbase-graphics)
- syntax-table/system-internal)
("advice" (runtime advice)
syntax-table/system-internal)
("arith" (runtime number)
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)
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)
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)
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)
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" ()
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" ()
#| -*-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
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))
\f
-(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))
-\f
-(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)))))
+\f
+;;;; 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)))
-\f
-(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"))
+\f
+;;;; 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)))
\f
-(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!))
-\f
-(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
#| -*-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
\f
(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*))
(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)
\f
(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
#| -*-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
(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)
(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)))
#| -*-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
;;; where <c> may be:
;;; A meaning the argument is printed using `display'.
;;; S meaning the argument is printed using `write'.
-\f
+
;;;; Top Level
(define (format destination format-string . arguments)
(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)
(start destination))
(else
(error "FORMAT: illegal destination" destination)))))
-\f
+
(define (format-loop port string arguments)
(let ((index (string-find-next-char string #\~)))
(cond (index
#| -*-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
(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))
(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)))))))
\f
;;;; User Primitives
#| -*-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
;;; package: (runtime gc-statistics)
(declare (usual-integrations))
-\f
+
(define (initialize-package!)
(set! hook/record-statistic! default/record-statistic!)
(set! history-modes
(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)
(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)))
\f
(define timestamp)
(define total-gc-time)
#| -*-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
(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)))
(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"))))
+\f
(define (operation/flush-output port)
(output-buffer/drain-block (port/output-buffer port)))
(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)))
#| -*-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
(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))
#| -*-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
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
#| -*-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
(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
`((#\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
(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)
-\f
-(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) |#
-\f
-(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))
-|#
\f
(define (install)
(without-interrupts
#| -*-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
(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)
(repl/syntax-table repl)
syntax-table))))
(lambda (s-expression)
- (hook/repl-eval repl
- s-expression
+ (hook/repl-eval s-expression
environment
syntax-table))))))
#| -*-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
(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
(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
(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
(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
(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)
(if operation
(begin
(operation port)
- (output-port/flush-output port)))))))
+ (output-port/discretionary-flush port)))))))
(define beep
(wrap-custom-operation-0 'BEEP))
(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
(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
(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
#| -*-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
;;;; 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))
#| -*-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
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?))
(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
((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)
(define input-port/custom-operation input-port/operation)
(define output-port/custom-operation output-port/operation)
\f
+;;;; Constructors
+
(define (input-port? object)
(and (port? object)
(input-port/operation/read-char object)
(updater port (delq! operation operations))
(cdr operation))))))))
\f
+;;;; Input Operations
+
(define install-input-operations!
(let ((operation-names
'(CHAR-READY? PEEK-CHAR READ-CHAR
(error "Must specify operation:" name))))
updaters
operations
- (list false
+ (list default-operation/char-ready?
false
false
(caddr operations)
(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)))
(discard-char port)
(loop)))))))
\f
+;;;; 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)
(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)
operation-names)
(for-each (lambda (updater)
(updater port false))
- updaters)))))))
\ No newline at end of file
+ updaters)))))))
+\f
+;;;; 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
#| -*-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
(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)
#| -*-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
;;; package: (runtime rep)
(declare (usual-integrations))
-\f
+
(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)
\f
;;;; 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)))
+\f
+(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)))
+\f
+;;;; 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)))))))
\f
;;;; 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)))
\f
;;;; 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))
(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>"))))
\f
;;;; 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)))))
+\f
+(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))))))))
\f
(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
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)
(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)
(restart/get restart make-cmdl)))
(loop (cdr restarts)))))))
\f
+(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))))
(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)))
(define (nearest-repl/condition)
(repl/condition (nearest-repl)))
\f
-;;;; 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))))
-\f
;;;; History
(define reader-history-size 5)
(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)
(- (if (default-object? index) 1 index) 1)))
\f
(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))
(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))
(if (default-object? value)
(continue)
(use-value value))
- (write-string "\n;Unable to PROCEED" (nearest-cmdl/output-port)))
-\f
-;;;; 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)))
-\f
-(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
#| -*-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
(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)
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
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)
(export (runtime microcode-errors)
write-operator)
(export (runtime rep)
+ *bound-restarts*
dynamic-handler-frames)
(initialization (initialize-package!)))
(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)
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
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)
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
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!
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
timer-interrupt
with-external-interrupts-handler)
(export (runtime emacs-interface)
- hook/^g-interrupt
+ hook/^G-interrupt
hook/clean-input/flush-typeahead)
(initialization (initialize-package!)))
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)
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)
record-accessor
record-constructor
record-copy
+ record-modifier
record-predicate
record-type-descriptor
record-type-field-names
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
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
out
pe
proceed
- prompt-for-command-char
- prompt-for-confirmation
- prompt-for-expression
- prompt-for-evaluated-expression
push-cmdl
push-repl
re
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!)))
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
#| -*-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
(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)
(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
#| -*-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
(declare (usual-integrations))
\f
(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)
+\f
(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)))
(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)
(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
#| -*-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
'()))
(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)
#| -*-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
(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
(define command-set)
\f
-(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
#| -*-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
((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*)
(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*))))
(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
#| -*-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
(declare (usual-integrations))
\f
-(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)))
(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))))
\f
-(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 " = ")))
s
(output-to-string (max (- x-size (string-length s)) 0)
(lambda ()
- (write value))))))))))
-\f
-(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
#| -*-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
(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))
#| -*-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
(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)
(repl/syntax-table repl)
syntax-table))))
(lambda (s-expression)
- (hook/repl-eval repl
- s-expression
+ (hook/repl-eval s-expression
environment
syntax-table))))))
#| -*-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
(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)
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
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)
(export (runtime microcode-errors)
write-operator)
(export (runtime rep)
+ *bound-restarts*
dynamic-handler-frames)
(initialization (initialize-package!)))
(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)
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
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)
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
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!
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
timer-interrupt
with-external-interrupts-handler)
(export (runtime emacs-interface)
- hook/^g-interrupt
+ hook/^G-interrupt
hook/clean-input/flush-typeahead)
(initialization (initialize-package!)))
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)
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)
record-accessor
record-constructor
record-copy
+ record-modifier
record-predicate
record-type-descriptor
record-type-field-names
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
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
out
pe
proceed
- prompt-for-command-char
- prompt-for-confirmation
- prompt-for-expression
- prompt-for-evaluated-expression
push-cmdl
push-repl
re
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!)))
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
projects / mit-scheme.git / commitdiff