From ae9dc3a90af4164cbc82d672e77dd6154ecd29af Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 7 Aug 1989 07:37:09 +0000 Subject: [PATCH] * Major rewrite of `debug' and `where' to allow their code to be used as a presentation mechanism for the editor. The basic new design has these features: ** All commands now accept a state argument, which they manipulate, allowing the entire debugger state to be passed around easily. ** All output from the commands is wrapped by the procedure `presentation', which can be grabbed to control the presentation characteristics. For example, the editor uses this hook to clear the debugger buffer, change current-output-port to go to that buffer, and then reset the modified flag after the presentation is complete. ** "Failure" conditions generated by the debugger are signalled through the new procedure `debugger-failure', which can be grabbed. The editor grabs this and binds it to `editor-failure'. ** Advisory messages generated by the debugger are signalled through the new procedure `debugger-message', which can be grabbed. The editor grabs this and binds it to `editor-message'. * The contracts for `prompt-for-confirmation?' and `prompt-for-expression' have been changed to make them compatible with the editor's versions of these procedures. * The package loader no longer offers the "load interpreted?" option. This is controlled by a flag which can be set should this option be desired. Similarly, the cold-loader no longer offers this option -- in that case you must move or delete the ".com" files to get an interpreted cold-load. * A new operation `pretty-print' is similar to `pp' except that it doesn't print a prefix newline and it does nothing special about hash numbers or named structures. --- v7/src/runtime/dbgcmd.scm | 20 +- v7/src/runtime/dbgutl.scm | 66 ++- v7/src/runtime/debug.scm | 1047 ++++++++++++++++++------------------ v7/src/runtime/emacs.scm | 19 +- v7/src/runtime/global.scm | 5 +- v7/src/runtime/make.scm | 29 +- v7/src/runtime/packag.scm | 11 +- v7/src/runtime/pp.scm | 48 +- v7/src/runtime/rep.scm | 8 +- v7/src/runtime/runtime.pkg | 23 +- v7/src/runtime/system.scm | 7 +- v7/src/runtime/version.scm | 4 +- v7/src/runtime/where.scm | 117 ++-- v8/src/runtime/dbgutl.scm | 66 ++- v8/src/runtime/global.scm | 5 +- v8/src/runtime/make.scm | 29 +- v8/src/runtime/runtime.pkg | 23 +- 17 files changed, 800 insertions(+), 727 deletions(-) diff --git a/v7/src/runtime/dbgcmd.scm b/v7/src/runtime/dbgcmd.scm index eddca8479..2013f7838 100644 --- a/v7/src/runtime/dbgcmd.scm +++ b/v7/src/runtime/dbgcmd.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.5 1989/08/03 23:03:34 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.6 1989/08/07 07:36:22 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -61,23 +61,24 @@ MIT in each case. |# (cdr command-set))) (loop (cdr command-set))))))) -(define (letter-commands command-set message prompt) +(define (letter-commands command-set message prompt state) (with-standard-proceed-point (lambda () (push-cmdl letter-commands/driver - (cons command-set prompt) + (vector command-set prompt state) message)))) (define (letter-commands/driver cmdl) - (let ((command-set (car (cmdl/state cmdl))) - (prompt (cdr (cmdl/state cmdl)))) + (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)) + ((cadr entry) state) (begin (beep) (newline) @@ -86,7 +87,8 @@ MIT in each case. |# (loop))))))))) (cmdl-message/null)) -(define ((standard-help-command command-set)) +(define ((standard-help-command command-set) state) + state ;ignore (for-each (lambda (entry) (newline) (write-string " ") @@ -96,7 +98,9 @@ MIT in each case. |# (cdr command-set)) unspecific) -(define (standard-exit-command) (proceed)) +(define (standard-exit-command state) + state ;ignore + (proceed)) (define (initialize-package!) (set! hook/leaving-command-loop default/leaving-command-loop)) diff --git a/v7/src/runtime/dbgutl.scm b/v7/src/runtime/dbgutl.scm index 2cf12eaf7..d7c4825ca 100644 --- a/v7/src/runtime/dbgutl.scm +++ b/v7/src/runtime/dbgutl.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgutl.scm,v 14.7 1989/01/06 20:59:45 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgutl.scm,v 14.8 1989/08/07 07:36:25 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -53,9 +53,8 @@ MIT in each case. |# (if (string? name) (write-string name) (write name))) (define (debug/read-eval-print-1 environment) - (let ((value (debug/eval (prompt-for-expression "Eval--> ") environment))) - (newline) - (write value))) + (debugger-message + (debug/eval (prompt-for-expression "Evaluate expression") environment))) (define (output-to-string length thunk) (let ((x (with-output-to-truncated-string length thunk))) @@ -64,14 +63,16 @@ MIT in each case. |# (cdr x))) (define (show-frames environment depth) - (let loop ((environment environment) (depth depth)) - (newline) - (write-string "----------------------------------------") - (show-frame environment depth true) - (if (environment-has-parent? environment) - (begin - (newline) - (loop (environment-parent environment) (1+ depth)))))) + (presentation + (lambda () + (let loop ((environment environment) (depth depth)) + (write-string "----------------------------------------") + (show-frame environment depth true) + (if (environment-has-parent? environment) + (begin + (newline) + (newline) + (loop (environment-parent environment) (1+ depth)))))))) (define (show-frame environment depth brief?) (show-environment-name environment) @@ -137,4 +138,41 @@ MIT in each case. |# s (output-to-string (max (- x-size (string-length s)) 0) (lambda () - (write value)))))))))) \ No newline at end of file + (write value)))))))))) + +(define hook/debugger-failure) +(define hook/debugger-message) +(define hook/presentation) + +(define (initialize-package!) + (set! hook/debugger-failure default/debugger-failure) + (set! hook/debugger-message default/debugger-message) + (set! hook/presentation default/presentation) + unspecific) + +(define (debugger-failure . objects) + (hook/debugger-failure (message-arguments->string objects))) + +(define (default/debugger-failure message) + (beep) + (write-string message) + (newline)) + +(define (debugger-message . objects) + (hook/debugger-message (message-arguments->string objects))) + +(define (default/debugger-message message) + (write-string message) + (newline)) + +(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 diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index 69e1be904..4001026aa 100644 --- a/v7/src/runtime/debug.scm +++ b/v7/src/runtime/debug.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.14 1989/08/03 23:02:11 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.15 1989/08/07 07:36:30 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -37,6 +37,56 @@ MIT in each case. |# (declare (usual-integrations)) +(define student-walk? false) +(define print-return-values? false) + +(define (debug #!optional object) + (let ((dstate + (make-initial-dstate + (if (default-object? object) + (or (error-continuation) + (current-proceed-continuation)) + object)))) + (letter-commands command-set + (cmdl-message/append + (cmdl-message/active + (lambda () + (command/print-reduction dstate))) + (cmdl-message/standard "Debugger")) + "Debug-->" + dstate))) + +(define (make-initial-dstate object) + (let ((dstate (allocate-dstate))) + (set-current-subproblem! + dstate + (or (coerce-to-stack-frame object) + (error "DEBUG: null continuation" object)) + '() + first-reduction-number) + dstate)) + +(define (coerce-to-stack-frame object) + (cond ((stack-frame? object) + (stack-frame/skip-non-subproblems object)) + ((continuation? object) + (coerce-to-stack-frame (continuation->stack-frame object))) + (else + (error "DEBUG: illegal argument" object)))) + +(define-structure (dstate + (conc-name dstate/) + (constructor allocate-dstate ())) + subproblem + previous-subproblems + subproblem-number + reduction-number + reductions + number-of-reductions + reduction + expression + environment-list) + (define (initialize-package!) (set! command-set @@ -44,257 +94,190 @@ MIT in each case. |# 'DEBUG-COMMANDS `((#\? ,standard-help-command "Help, list command letters") - (#\A ,show-all-frames + (#\A ,command/show-all-frames "Show bindings in current environment and its ancestors") - (#\B ,earlier-reduction-command + (#\B ,command/earlier-reduction "Earlier reduction (Back in time)") - (#\C ,show-current-frame + (#\C ,command/show-current-frame "Show bindings of identifiers in the current environment") - (#\D ,later-subproblem-command + (#\D ,command/later-subproblem "Move (Down) to the next (later) subproblem") - (#\E ,enter-read-eval-print-loop + (#\E ,command/enter-read-eval-print-loop "Enter a read-eval-print loop in the current environment") - (#\F ,later-reduction-command + (#\F ,command/later-reduction "Later reduction (Forward in time)") - (#\G ,goto-command + (#\G ,command/goto "Go to a particular Subproblem/Reduction level") - (#\H ,summarize-history-command + (#\H ,command/summarize-history "Prints a summary of the entire history") - (#\I ,error-info-command + (#\I ,command/error-info "Redisplay the error message") - (#\L ,pretty-print-current-expression + (#\L ,command/print-expression "(list expression) Pretty-print the current expression") - (#\O ,pretty-print-environment-procedure + (#\O ,command/print-environment-procedure "Pretty print the procedure that created the current environment") - (#\P ,move-to-parent-environment + (#\P ,command/move-to-parent-environment "Move to environment which is parent of current environment") (#\Q ,standard-exit-command "Quit (exit DEBUG)") - (#\R ,reductions-command + (#\R ,command/print-reductions "Print the reductions of the current subproblem level") - (#\S ,move-to-child-environment + (#\S ,command/move-to-child-environment "Move to child of current environment (in current chain)") - (#\T ,print-current-reduction + (#\T ,command/print-reduction "Print the current subproblem/reduction") - (#\U ,earlier-subproblem-command + (#\U ,command/earlier-subproblem "Move (Up) to the previous (earlier) subproblem") - (#\V ,eval-in-current-environment + (#\V ,command/eval-in-current-environment "Evaluate expression in current environment") - (#\W ,enter-where-command + (#\W ,command/enter-where "Enter WHERE on the current environment") - (#\X ,internal-command + (#\X ,command/internal "Create a read eval print loop in the debugger environment") - (#\Y ,frame-command + (#\Y ,command/frame "Display the current stack frame") - (#\Z ,return-command + (#\Z ,command/return "Return (continue with) an expression after evaluating it") ))) unspecific) (define command-set) -(define current-subproblem) -(define previous-subproblems) -(define current-subproblem-number) -(define current-reduction-number) -(define current-reductions) -(define current-number-of-reductions) -(define current-reduction) -(define current-expression) -(define environment-list) - -(define reduction-wrap-around-tag 'WRAP-AROUND) -(define student-walk? false) -(define print-return-values? false) -(define environment-arguments-truncation 68) - -(define (debug #!optional object) - (fluid-let ((current-subproblem) - (previous-subproblems) - (current-subproblem-number) - (current-reduction-number) - (current-reductions) - (current-number-of-reductions) - (current-reduction) - (current-expression) - (environment-list)) - (set-current-subproblem! - (let ((object - (if (default-object? object) - (or (error-continuation) - (current-proceed-continuation)) - object))) - (or (coerce-to-stack-frame object) - (error "DEBUG: null continuation" object))) - '() - (lambda () 0)) - (letter-commands command-set - (cmdl-message/append - (cmdl-message/active print-current-reduction) - (cmdl-message/standard "Debugger")) - "Debug-->"))) - -(define (coerce-to-stack-frame object) - (cond ((stack-frame? object) - (stack-frame/skip-non-subproblems object)) - ((continuation? object) - (coerce-to-stack-frame (continuation->stack-frame object))) - (else - (error "DEBUG: illegal argument" object)))) - -;;;; Display commands - -(define (print-current-reduction) - (print-current-expression) - (print-current-environment)) - -(define (print-current-expression) - (newline) - (write-string "Subproblem level: ") - (write current-subproblem-number) - (if current-reduction - (begin - (write-string " Reduction number: ") - (write current-reduction-number) - (newline) - (write-string "Expression (from execution history):") - (print-expression current-expression)) - (begin - (newline) - (cond ((not (invalid-expression? current-expression)) - (write-string - (if (stack-frame/compiled-code? current-subproblem) - "Compiled code expression (from stack):" - "Expression (from stack):")) - (print-expression current-expression)) - ((or (not (debugging-info/undefined-expression? - current-expression)) - (not (debugging-info/noise? current-expression))) - (write-string - (if (stack-frame/compiled-code? current-subproblem) - "Compiled code expression unknown" - "Expression unknown"))) - (else - (write-string - ((debugging-info/noise current-expression) true))))))) - -(define (stack-frame/compiled-code? frame) - (compiled-return-address? (stack-frame/return-address frame))) - -(define (print-current-environment) - (if (pair? environment-list) - (let ((environment (car environment-list))) - (show-environment-name environment) - (show-environment-arguments environment)) - (begin - (newline) - (write-string "There is no current environment")))) - -(define (show-environment-arguments environment) - (if (not (environment->package environment)) - (begin - (newline) - (let ((arguments (environment-arguments environment))) - (if (eq? arguments 'UNKNOWN) - (show-environment-bindings environment true) - (begin - (write-string "applied to ") - (write-string - (cdr - (write-to-string arguments - environment-arguments-truncation))))))))) - -(define (show-environment-arguments environment) - (if (not (environment->package environment)) - (begin - (newline) - (let ((arguments (environment-arguments environment))) - (if (eq? arguments 'UNKNOWN) - (show-environment-bindings environment true) - (begin - (write-string "applied to ") - (write-string - (cdr - (write-to-string arguments - environment-arguments-truncation))))))))) - -(define (pretty-print-current-expression) - (cond ((debugging-info/compiled-code? current-expression) - (newline) - (write-string ";compiled code")) - ((not (debugging-info/undefined-expression? current-expression)) - (print-expression current-expression)) - ((debugging-info/noise? current-expression) - (newline) - (write-string ";") - (write-string ((debugging-info/noise current-expression) false))) - (else - (newline) - (write-string ";undefined expression")))) - -(define (pretty-print-environment-procedure) - (with-current-environment - (lambda (environment) - (let ((scode-lambda (environment-lambda environment))) - (if scode-lambda - (print-expression scode-lambda) +(define (command/print-reduction dstate) + (presentation + (lambda () + (write-string "Subproblem level: ") + (write (dstate/subproblem-number dstate)) + (let ((expression (dstate/expression dstate))) + (if (dstate/reduction dstate) (begin + (write-string " Reduction number: ") + (write (dstate/reduction-number dstate)) (newline) - (write-string - "Unable to get procedure for this environment"))))))) - -(define (reductions-command) - (let loop ((reductions current-reductions)) - (cond ((pair? reductions) - (print-expression (reduction-expression (car reductions))) - (loop (cdr reductions))) - ((wrap-around-in-reductions? reductions) - (newline) - (write-string "Wrap around in the reductions at this level"))))) - -(define (print-expression expression) - (pp expression)) + (write-string "Expression (from execution history):") + (newline) + (pretty-print expression)) + (let ((subproblem (dstate/subproblem dstate))) + (newline) + (cond ((not (invalid-expression? expression)) + (write-string + (if (stack-frame/compiled-code? subproblem) + "Compiled code expression (from stack):" + "Expression (from stack):")) + (newline) + (pretty-print expression)) + ((or (not (debugging-info/undefined-expression? expression)) + (not (debugging-info/noise? expression))) + (write-string + (if (stack-frame/compiled-code? subproblem) + "Compiled code expression unknown" + "Expression unknown"))) + (else + (write-string + ((debugging-info/noise expression) true))))))) + (let ((environment-list (dstate/environment-list dstate))) + (if (pair? environment-list) + (let ((environment (car environment-list))) + (show-environment-name environment) + (if (not (environment->package environment)) + (begin + (newline) + (let ((arguments (environment-arguments environment))) + (if (eq? arguments 'UNKNOWN) + (show-environment-bindings environment true) + (begin + (write-string "applied to ") + (write-string + (cdr + (write-to-string + arguments + (- (output-port/x-size (current-output-port)) + 11)))))))))) + (begin + (newline) + (write-string "There is no current environment"))))))) + +(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)) + ((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 + (lambda (environment) + (let ((scode-lambda (environment-lambda environment))) + (if scode-lambda + (presentation (lambda () (pretty-print scode-lambda))) + (debugger-failure "No procedure for this environment")))))) + +(define (command/print-reductions dstate) + (let ((reductions (dstate/reductions dstate))) + (if (pair? reductions) + (presentation + (lambda () + (pretty-print (reduction-expression (car reductions))) + (let loop ((reductions (cdr reductions))) + (cond ((pair? reductions) + (newline) + (pretty-print (reduction-expression (car reductions))) + (loop (cdr reductions))) + ((eq? 'WRAP-AROUND reductions) + (newline) + (write-string + "Wrap around in the reductions at this level")))))) + (debugger-failure "No reductions at this level")))) ;;;; Short history display -(define (summarize-history-command) +(define (command/summarize-history dstate) (let ((top-subproblem - (if (null? previous-subproblems) - current-subproblem - (car (last-pair previous-subproblems))))) - (newline) - (write-string "SL# Procedure Name Expression") - (newline) - (let loop ((frame top-subproblem) (level 0)) - (if frame - (begin - (let ((reductions (stack-frame/reductions frame))) - (if (pair? reductions) - (let ((print-reduction - (lambda (reduction) - (terse-print-expression - level - (reduction-expression reduction) - (reduction-environment reduction))))) - (print-reduction (car reductions)) - (if (= level 0) - (let loop ((reductions (cdr reductions))) - (if (pair? reductions) - (begin (print-reduction (car reductions)) - (loop (cdr reductions))))))) - (with-values - (lambda () (stack-frame/debugging-info frame)) - (lambda (expression environment) - (terse-print-expression level - expression - environment))))) - (loop (stack-frame/next-subproblem frame) (1+ level))))))) + (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 + (let ((reductions (stack-frame/reductions frame))) + (if (pair? reductions) + (let ((print-reduction + (lambda (reduction) + (terse-print-expression + level + (reduction-expression reduction) + (reduction-environment reduction))))) + (print-reduction (car reductions)) + (if (= level 0) + (let loop ((reductions (cdr reductions))) + (if (pair? reductions) + (begin + (print-reduction (car reductions)) + (loop (cdr reductions))))))) + (with-values + (lambda () (stack-frame/debugging-info frame)) + (lambda (expression environment) + (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 " ") - ;;; procedure name (write-string (string-pad-right (let ((name @@ -310,8 +293,11 @@ MIT in each case. |# (cond ((debugging-info/compiled-code? expression) ";compiled code") ((not (debugging-info/undefined-expression? expression)) - (output-to-string 50 - (lambda () (write-sexp (unsyntax expression))))) + (output-to-string + 50 + (lambda () + (fluid-let ((*unparse-primitives-by-name?* true)) + (write (unsyntax expression)))))) ((debugging-info/noise? expression) (output-to-string 50 @@ -319,257 +305,233 @@ MIT in each case. |# (write-string ((debugging-info/noise expression) false))))) (else ";undefined expression")))) - -(define (write-sexp sexp) - (fluid-let ((*unparse-primitives-by-name?* true)) - (write sexp))) ;;;; Subproblem/reduction motion -(define (earlier-subproblem-command) - (if (stack-frame/next-subproblem current-subproblem) - (begin - (earlier-subproblem) - (print-current-reduction)) - (begin - (beep) - (newline) - (write-string "There are only ") - (write current-subproblem-number) - (write-string " subproblem levels; already at earliest level")))) - -(define (earlier-reduction-command) - (cond ((and student-walk? - (> current-subproblem-number 0) - (= current-reduction-number 0)) - (earlier-subproblem-command)) - ((< current-reduction-number (-1+ current-number-of-reductions)) - (set-current-reduction! (1+ current-reduction-number)) - (print-current-reduction)) - (else - (newline) - (write-string - (if (wrap-around-in-reductions? current-reductions) - "Wrap around in reductions at this level" - "No more reductions at this level")) - (newline) - (write-string "Going to the previous (earlier) subproblem") - (newline) - (earlier-subproblem-command)))) - -(define (earlier-subproblem) - ;; Assumption: (not (not (stack-frame/next-subproblem current-subproblem))) - (set-current-subproblem! (stack-frame/next-subproblem current-subproblem) - (cons current-subproblem previous-subproblems) - normal-reduction-number)) - -(define (later-subproblem-command) - (later-subproblem normal-reduction-number)) - -(define (later-reduction-command) - (if (positive? current-reduction-number) - (begin - (set-current-reduction! (-1+ current-reduction-number)) - (print-current-reduction)) - (later-subproblem - (if (or (not student-walk?) - (= current-subproblem-number 1)) - last-reduction-number - normal-reduction-number)))) - -(define (later-subproblem select-reduction-number) - (if (null? previous-subproblems) - (begin - (beep) - (newline) - (write-string "Already at latest subproblem level")) - (begin - (set-current-subproblem! (car previous-subproblems) - (cdr previous-subproblems) - select-reduction-number) - (print-current-reduction)))) +(define (command/earlier-subproblem dstate) + (if (stack-frame/next-subproblem (dstate/subproblem dstate)) + (let ((subproblem (dstate/subproblem dstate))) + (move-to-subproblem! dstate + (stack-frame/next-subproblem subproblem) + (cons subproblem + (dstate/previous-subproblems dstate)) + normal-reduction-number)) + (debugger-failure "There are only " + (1+ (dstate/subproblem-number dstate)) + " subproblem levels; already at earliest level"))) + +(define (command/earlier-reduction dstate) + (let ((reduction-number (dstate/reduction-number dstate))) + (cond ((and student-walk? + (> (dstate/subproblem-number dstate) 0) + (= reduction-number 0)) + (command/earlier-subproblem dstate)) + ((< reduction-number + (-1+ (dstate/number-of-reductions dstate))) + (move-to-reduction! dstate (1+ reduction-number))) + (else + (debugger-message + (if (wrap-around-in-reductions? (dstate/reductions dstate)) + "Wrap around in" + "No more") + " reductions; going to the previous (earlier) subproblem") + (command/earlier-subproblem dstate))))) + +(define (command/later-subproblem dstate) + (later-subproblem dstate normal-reduction-number)) + +(define (command/later-reduction dstate) + (if (positive? (dstate/reduction-number dstate)) + (move-to-reduction! dstate (-1+ (dstate/reduction-number dstate))) + (later-subproblem dstate + (if (or (not student-walk?) + (= (dstate/subproblem-number dstate) 1)) + last-reduction-number + normal-reduction-number)))) + +(define (later-subproblem dstate select-reduction-number) + (if (null? (dstate/previous-subproblems dstate)) + (debugger-failure "Already at latest subproblem level") + (let ((previous-subproblems (dstate/previous-subproblems dstate))) + (move-to-subproblem! dstate + (car previous-subproblems) + (cdr previous-subproblems) + select-reduction-number)))) ;;;; General motion command -(define (goto-command) - (if (select-subproblem) - (begin - (select-reduction) - (print-current-reduction)))) +(define (command/goto dstate) + (let* ((subproblems (select-subproblem dstate)) + (subproblem (car subproblems)) + (reduction-number + (select-reduction + (improper-list-length (stack-frame/reductions subproblem))))) + (move-to-subproblem! dstate + subproblem + (cdr subproblems) + (lambda (number-of-reductions) + number-of-reductions ;ignore + reduction-number)))) + +(define (select-subproblem dstate) + (let top-level-loop () + (let ((delta + (- (prompt-for-nonnegative-integer "Subproblem number" false) + (dstate/subproblem-number dstate)))) + (if (negative? delta) + (list-tail (dstate/previous-subproblems dstate) (-1+ (- delta))) + (let loop + ((subproblem (dstate/subproblem dstate)) + (subproblems (dstate/previous-subproblems dstate)) + (delta delta)) + (if (zero? delta) + (cons subproblem subproblems) + (let ((next (stack-frame/next-subproblem subproblem))) + (if next + (loop next (cons subproblem subproblems) (-1+ delta)) + (begin + (debugger-failure + "Subproblem number too large (limit is " + (length subproblems) + " inclusive)") + (top-level-loop)))))))))) + +(define (select-reduction number-of-reductions) + (cond ((> number-of-reductions 1) + (prompt-for-nonnegative-integer "Reduction number" + number-of-reductions)) + ((= number-of-reductions 1) + (debugger-message "Exactly one reduction for this subproblem") + 0) + (else + (debugger-message "No reductions for this subproblem") + -1))) -(define (select-subproblem) +(define (prompt-for-nonnegative-integer prompt limit) (let loop () - (let ((subproblem-number (prompt-for-expression "Subproblem number: "))) - (if (not (and (integer? subproblem-number) - (not (negative? subproblem-number)))) - (begin - (beep) - (newline) - (write-string "Subproblem level must be nonnegative integer!") - (loop)) - (let ((delta (- subproblem-number current-subproblem-number))) - (cond ((negative? delta) - (let ((tail - (list-tail previous-subproblems (-1+ (- delta))))) - (set-current-subproblem! (car tail) - (cdr tail) - normal-reduction-number)) - true) - ((positive? delta) - (let loop - ((subproblem current-subproblem) - (subproblems previous-subproblems) - (delta delta)) - (let ((next (stack-frame/next-subproblem subproblem))) - (cond ((not next) - (beep) - (newline) - (write-string "There is no such subproblem") - false) - ((= delta 1) - (set-current-subproblem! - next - (cons subproblem subproblems) - normal-reduction-number) - true) - (else - (loop next - (cons subproblem subproblems) - (-1+ delta))))))) - (else - (newline) - (write-string "Already at subproblem ") - (write subproblem-number) - false))))))) - -(define (select-reduction) - (set-current-reduction! - (cond ((> current-number-of-reductions 1) - (let get-reduction-number () - (let ((reduction-number - (prompt-for-expression - (string-append - "Reduction Number (0 through " - (number->string (-1+ current-number-of-reductions)) - " inclusive): ")))) - (cond ((not (and (integer? reduction-number) - (not (negative? reduction-number)))) - (beep) - (newline) - (write-string - "Reduction number must be nonnegative integer!") - (get-reduction-number)) - ((not (< reduction-number - current-number-of-reductions)) - (beep) - (newline) - (write-string "Reduction number too large!") - (get-reduction-number)) - (else - reduction-number))))) - ((= current-number-of-reductions 1) - (newline) - (write-string "There is only one reduction for this subproblem") - (newline) - 0) - (else - (newline) - (write-string "There are no reductions for this subproblem") - (newline) - -1)))) + (let ((expression + (prompt-for-expression + (string-append prompt + (if limit + (string-append " (0 through " + (number->string (-1+ limit)) + " inclusive)") + ""))))) + (cond ((not (and (integer? expression) + (not (negative? expression)))) (debugger-failure prompt " must be nonnegative integer") + (loop)) + ((and limit (>= expression limit)) + (debugger-failure prompt " too large") + (loop)) + (else + expression))))) ;;;; Environment motion and display -(define (show-current-frame) - (if (pair? environment-list) - (show-current-frame-1 false) - (print-undefined-environment))) - -(define (show-current-frame-1 brief?) - (show-frame (car environment-list) (length (cdr environment-list)) brief?)) - -(define (show-all-frames) - (if (pair? environment-list) - (show-frames (car (last-pair environment-list)) 0) - (print-undefined-environment))) - -(define (move-to-parent-environment) - (cond ((not (pair? environment-list)) - (print-undefined-environment)) - ((environment-has-parent? (car environment-list)) - (set! environment-list - (cons (environment-parent (car environment-list)) - environment-list)) - (show-current-frame-1 true)) - (else - (beep) - (newline) - (write-string "The current environment has no parent")))) - -(define (move-to-child-environment) - (cond ((not (pair? environment-list)) - (print-undefined-environment)) - ((not (pair? (cdr environment-list))) - (beep) - (newline) - (write-string "This is the initial environment; can't move to child")) - (else - (set! environment-list (cdr environment-list)) - (show-current-frame-1 true)))) - -(define (enter-read-eval-print-loop) - (debug/read-eval-print (get-evaluation-environment) +(define (command/show-current-frame dstate) + (if (pair? (dstate/environment-list dstate)) + (show-current-frame dstate false) + (undefined-environment))) + +(define (command/show-all-frames dstate) + (let ((environment-list (dstate/environment-list dstate))) + (if (pair? environment-list) + (show-frames (car (last-pair environment-list)) 0) + (undefined-environment)))) + +(define (command/move-to-parent-environment dstate) + (let ((environment-list (dstate/environment-list dstate))) + (cond ((not (pair? environment-list)) + (undefined-environment)) + ((environment-has-parent? (car environment-list)) + (set-dstate/environment-list! + dstate + (cons (environment-parent (car environment-list)) + environment-list)) + (show-current-frame dstate true)) + (else + (debugger-failure "The current environment has no parent"))))) + +(define (command/move-to-child-environment dstate) + (let ((environment-list (dstate/environment-list dstate))) + (cond ((not (pair? (dstate/environment-list dstate))) + (undefined-environment)) + ((not (pair? (cdr environment-list))) + (debugger-failure + "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) "You are now in the desired environment" "Eval-in-env-->")) -(define (eval-in-current-environment) - (debug/read-eval-print-1 (get-evaluation-environment))) +(define (command/eval-in-current-environment dstate) + (debug/read-eval-print-1 (get-evaluation-environment dstate))) -(define (enter-where-command) - (with-current-environment debug/where)) +(define (command/enter-where dstate) + (with-current-environment dstate debug/where)) ;;;; Error info -(define (error-info-command) - (let ((message (error-message)) - (irritants (error-irritants)) - (port (current-output-port))) - (newline) - (write-string " Message: ") - (write-string message) - (newline) - (if (null? irritants) - (write-string " No irritants") - (begin - (write-string " Irritants: ") - (for-each - (let ((n (- (output-port/x-size port) 4))) - (lambda (irritant) - (newline) - (write-string " ") - (if (error-irritant/noise? irritant) - (begin - (write-string "noise: ") - (write (error-irritant/noise-value irritant))) - (write-string - (let ((result (write-to-string irritant n))) - (if (car result) - (substring-move-right! "..." 0 3 - (cdr result) (- n 3))) - (cdr result)))))) - irritants))) - (newline) - (write-string " Formatted output:") - (newline) - (format-error-message message irritants port))) +(define (command/error-info dstate) + dstate ;ignore + (show-error-info (error-condition))) + +(define (show-error-info condition) + (if condition + (presentation + (lambda () + (let ((message (condition/message condition)) + (irritants (condition/irritants condition)) + (port (current-output-port))) + (write-string " Message: ") + (write-string message) + (newline) + (if (null? irritants) + (write-string " No irritants") + (begin + (write-string " Irritants: ") + (for-each + (let ((n (- (output-port/x-size port) 4))) + (lambda (irritant) + (newline) + (write-string " ") + (if (error-irritant/noise? irritant) + (begin + (write-string "noise: ") + (write (error-irritant/noise-value irritant))) + (write-string + (let ((result (write-to-string irritant n))) + (if (car result) + (substring-move-right! "..." 0 3 + (cdr result) (- n 3))) + (cdr result)))))) + irritants))) + (newline) + (write-string " Formatted output:") + (newline) + ((condition/reporter condition) condition port)))) + (debugger-failure "No error to report"))) ;;;; Advanced hacking commands -(define (return-command) - (let ((next (stack-frame/next-subproblem current-subproblem))) +(define (command/return dstate) + (let ((next (stack-frame/next-subproblem (dstate/subproblem dstate)))) (if next - (let ((invalid-expression? (invalid-expression? current-expression)) - (environment (get-evaluation-environment)) + (let ((invalid-expression? + (invalid-expression? (dstate/expression dstate))) + (environment (get-evaluation-environment dstate)) (return (lambda (value) ((stack-frame->continuation next) value)))) @@ -581,11 +543,10 @@ MIT in each case. |# "Expression to EVALUATE and CONTINUE with" (if invalid-expression? "" - " ($ to retry)") - ": ")))) + " ($ to retry)"))))) (if (and (not invalid-expression?) (eq? expression '$)) - (unsyntax current-expression) + (unsyntax (dstate/expression dstate)) expression)) environment))) (if print-return-values? @@ -594,72 +555,108 @@ MIT in each case. |# (write-string "That evaluates to:") (newline) (write value) - (if (prompt-for-confirmation "Confirm: ") (return value))) + (if (prompt-for-confirmation "Confirm") (return value))) (return value)))) - (begin - (beep) - (newline) - (write-string "Can't continue!!!"))))) + (debugger-failure "Can't continue!!!")))) -(define (internal-command) - (debug/read-eval-print (->environment '(runtime debugger)) +(define (command/internal dstate) + dstate ;ignore + (debug/read-eval-print (->environment '(RUNTIME DEBUGGER)) "You are now in the debugger environment" "Debugger-->")) -(define (frame-command) - (write-string "Stack frame ") - (write current-subproblem) - (write-string " :") - (newline) - (for-each pp (named-structure/description current-subproblem))) +(define (command/frame dstate) + (presentation + (lambda () + (write-string "Stack frame ") + (write (dstate/subproblem dstate)) + (write-string " :") + (newline) + (for-each (lambda (element) + (newline) + (pretty-print element)) + (named-structure/description (dstate/subproblem dstate)))))) -;;;; Reduction and subproblem motion low-level - -(define (set-current-subproblem! stack-frame previous-frames +;;;; Low-level Side-effects + +(define (move-to-subproblem! dstate + stack-frame + previous-frames + select-reduction-number) + (dynamic-wind + (lambda () + unspecific) + (lambda () + (set-current-subproblem! dstate + stack-frame + previous-frames + select-reduction-number)) + (lambda () + (command/print-reduction dstate)))) + +(define (move-to-reduction! dstate reduction-number) + (dynamic-wind (lambda () unspecific) + (lambda () (set-current-reduction! dstate reduction-number)) + (lambda () (command/print-reduction dstate)))) + +(define (set-current-subproblem! dstate + stack-frame + previous-frames select-reduction-number) - (set! current-subproblem stack-frame) - (set! previous-subproblems previous-frames) - (set! current-subproblem-number (length previous-subproblems)) - (set! current-reductions - (if stack-frame (stack-frame/reductions current-subproblem) '())) - (set! current-number-of-reductions (dotted-list-length current-reductions)) - (set-current-reduction! (select-reduction-number))) - -(define (last-reduction-number) - (-1+ current-number-of-reductions)) - -(define (normal-reduction-number) - (min (-1+ current-number-of-reductions) 0)) - -(define (set-current-reduction! number) - (set! current-reduction-number number) - (set! current-reduction - (and (not (null? current-reductions)) - (>= number 0) - (list-ref current-reductions number))) - (if current-reduction - (begin - (set! current-expression (reduction-expression current-reduction)) - (set! environment-list - (list (reduction-environment current-reduction)))) - (with-values (lambda () (stack-frame/debugging-info current-subproblem)) - (lambda (expression environment) - (set! current-expression expression) - (set! environment-list - (if (debugging-info/undefined-environment? environment) - '() - (list environment))))))) + (set-dstate/subproblem! dstate stack-frame) + (set-dstate/previous-subproblems! dstate previous-frames) + (set-dstate/subproblem-number! dstate (length previous-frames)) + (let* ((reductions (if stack-frame (stack-frame/reductions stack-frame) '())) + (number-of-reductions (improper-list-length reductions))) + (set-dstate/reductions! dstate reductions) + (set-dstate/number-of-reductions! dstate number-of-reductions) + (set-current-reduction! dstate + (select-reduction-number number-of-reductions)))) + +(define (normal-reduction-number number-of-reductions) + (min (-1+ number-of-reductions) 0)) + +(define (first-reduction-number number-of-reductions) + number-of-reductions ;ignore + 0) + +(define (last-reduction-number number-of-reductions) + (-1+ number-of-reductions)) + +(define (set-current-reduction! dstate number) + (set-dstate/reduction-number! dstate number) + (let ((reduction + (and (>= number 0) + (let loop + ((reductions (dstate/reductions dstate)) + (number number)) + (and (pair? reductions) + (if (zero? number) + (car reductions) + (loop (cdr reductions) (-1+ number)))))))) + (set-dstate/reduction! dstate reduction) + (if reduction + (begin + (set-dstate/expression! dstate (reduction-expression reduction)) + (set-dstate/environment-list! + dstate + (list (reduction-environment reduction)))) + (with-values + (lambda () + (stack-frame/debugging-info (dstate/subproblem dstate))) + (lambda (expression environment) + (set-dstate/expression! dstate expression) + (set-dstate/environment-list! + dstate + (if (debugging-info/undefined-environment? environment) + '() + (list environment)))))))) ;;;; Utilities -(define (repeat f n) - (if (> n 0) - (begin (f) - (repeat f (-1+ n))))) - -(define (dotted-list-length l) - (let count ((n 0) (L L)) +(define (improper-list-length l) + (let count ((n 0) (l l)) (if (pair? l) - (count (1+ n) (CDR L)) + (count (1+ n) (cdr l)) n))) (define-integrable (reduction-expression reduction) @@ -669,31 +666,29 @@ MIT in each case. |# (cadr reduction)) (define (wrap-around-in-reductions? reductions) - (eq? (list-tail reductions (dotted-list-length reductions)) - reduction-wrap-around-tag)) + (or (eq? 'WRAP-AROUND reductions) + (and (pair? reductions) + (eq? 'WRAP-AROUND (cdr (last-pair reductions)))))) (define (invalid-expression? expression) (or (debugging-info/undefined-expression? expression) (debugging-info/compiled-code? expression))) -(define (with-current-environment receiver) - (if (pair? environment-list) - (receiver (car environment-list)) - (print-undefined-environment))) - -(define (get-evaluation-environment) - (if (and (pair? environment-list) - (environment? (car environment-list))) - (car environment-list) - (begin - (newline) - (write-string "Cannot evaluate in current environment") - (newline) - (write-string "Using the read-eval-print environment instead") - (newline) - (nearest-repl/environment)))) - -(define (print-undefined-environment) - (beep) - (newline) - (write-string "There is no current environment")) \ No newline at end of file +(define (get-evaluation-environment dstate) + (let ((environment-list (dstate/environment-list dstate))) + (if (and (pair? environment-list) + (environment? (car environment-list))) + (car environment-list) + (begin + (debugger-message + "Cannot evaluate in current environment;\nusing the read-eval-print environment instead") + (nearest-repl/environment))))) + +(define (with-current-environment dstate receiver) + (let ((environment-list (dstate/environment-list dstate))) + (if (pair? environment-list) + (receiver (car environment-list)) + (undefined-environment)))) + +(define (undefined-environment) + (debugger-failure "There is no current environment")) \ No newline at end of file diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm index 9e2ad93fe..2daf7686b 100644 --- a/v7/src/runtime/emacs.scm +++ b/v7/src/runtime/emacs.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.2 1988/07/13 20:09:56 hal Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.3 1989/08/07 07:36:34 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -160,14 +160,15 @@ MIT in each case. |# (define (emacs/prompt-for-confirmation cmdl prompt) (if (cmdl/io-to-console? cmdl) (begin - (transmit-signal-with-argument #\n prompt) + (transmit-signal-with-argument #\n + (string-append prompt " (y or n)? ")) (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 prompt) + (transmit-signal-with-argument #\i (string-append prompt ": ")) (read console-input-port)) (normal/prompt-for-expression cmdl prompt))) @@ -199,6 +200,7 @@ MIT in each case. |# (define normal/prompt-for-expression) (define normal/^G-interrupt) (define normal/set-working-directory-pathname!) +(define normal/presentation) (define (initialize-package!) (set! normal/gc-start hook/gc-start) @@ -217,6 +219,7 @@ MIT in each case. |# (set! normal/^G-interrupt hook/^G-interrupt) (set! normal/set-working-directory-pathname! hook/set-working-directory-pathname!) + ;;(set! normal/presentation hook/presentation) (add-event-receiver! event:after-restore install!) (install!)) @@ -241,7 +244,9 @@ MIT in each case. |# (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!)) + emacs/set-working-directory-pathname!) + ;;(set! hook/presentation (lambda (thunk) (thunk))) + unspecific) (define (install-normal-hooks!) (set! hook/gc-start normal/gc-start) @@ -259,4 +264,6 @@ MIT in each case. |# (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!)) \ No newline at end of file + normal/set-working-directory-pathname!) + ;;(set! hook/presentation normal/presentation) + unspecific) \ No newline at end of file diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm index f744c1b21..90636276f 100644 --- a/v7/src/runtime/global.scm +++ b/v7/src/runtime/global.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.10 1989/08/03 23:03:58 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.11 1989/08/07 07:36:38 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -171,7 +171,8 @@ MIT in each case. |# ((ucode-primitive primitive-type? 2) (ucode-type future) object)) (define (exit) - (if (prompt-for-confirmation "Kill Scheme? ") (%exit))) + (if (prompt-for-confirmation "Kill Scheme") + (%exit))) (define (%exit) (event-distributor/invoke! event:before-exit) diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index a45990969..9e2dd5dc7 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.14 1989/08/03 23:07:40 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.15 1989/08/07 07:36:42 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -63,9 +63,7 @@ MIT in each case. |# substring=? substring-move-right! substring-downcase! - tty-beep tty-flush-output - tty-read-char-immediate tty-write-char tty-write-string vector-ref @@ -87,27 +85,6 @@ MIT in each case. |# (tty-write-char newline-char) (tty-flush-output) (exit)) - -(define (prompt-for-confirmation prompt) - (let loop () - (tty-write-char newline-char) - (tty-write-string prompt) - (tty-write-string "(y or n) ") - (tty-flush-output) - (let ((char (tty-read-char-immediate))) - (cond ((or (eq? #\y char) - (eq? #\Y char)) - (tty-write-string "Yes") - (tty-flush-output) - true) - ((or (eq? #\n char) - (eq? #\N char)) - (tty-write-string "No") - (tty-flush-output) - false) - (else - (tty-beep) - (loop)))))) ;;;; GC, Interrupts, Errors @@ -196,8 +173,8 @@ MIT in each case. |# false)) (define map-filename - (if (and (implemented-primitive-procedure? file-exists?) - (not (prompt-for-confirmation "Load interpreted? "))) (lambda (filename) + (if (implemented-primitive-procedure? file-exists?) + (lambda (filename) (let ((com-file (string-append filename ".com"))) (if (file-exists? com-file) com-file diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm index 5d39c0dc9..8849c53bc 100644 --- a/v7/src/runtime/packag.scm +++ b/v7/src/runtime/packag.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/packag.scm,v 14.7 1989/05/21 17:13:47 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/packag.scm,v 14.8 1989/08/07 07:36:45 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -107,13 +107,18 @@ MIT in each case. |# (define system-global-package) +(define system-loader/enable-query? + false) + (define (package/system-loader filename options load-interpreted?) (let ((pathname (->pathname filename))) (with-working-directory-pathname (pathname-directory-path pathname) (lambda () (fluid-let ((load/default-types (if (if (eq? load-interpreted? 'QUERY) - (prompt-for-confirmation "Load interpreted? ") load-interpreted?) + (and system-loader/enable-query? + (prompt-for-confirmation "Load interpreted")) + load-interpreted?) '("bin" "scm") load/default-types))) (let ((syntax-table (nearest-repl/syntax-table))) diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm index 3c2ffbc7a..11cea9f2f 100644 --- a/v7/src/runtime/pp.scm +++ b/v7/src/runtime/pp.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.6 1989/02/22 07:16:34 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.7 1989/08/07 07:36:48 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -60,41 +60,47 @@ MIT in each case. |# (define *pp-uninterned-symbols-by-name* true) (define *forced-x-size* false) -(define (pp object #!optional port as-code?) +(define (pp object #!optional port . rest) (let ((object (or (and (integer? object) (not (negative? object)) (unhash object)) object)) - (port (if (default-object? port) (current-output-port) port)) - (as-code? (if (default-object? as-code?) false as-code?))) - (cond ((or (not (scode-constant? object)) - (compound-procedure? object)) - (pp-top-level port - (let ((sexp (unsyntax object))) - (if (and *named-lambda->define?* - (pair? sexp) - (eq? (car sexp) 'NAMED-LAMBDA)) - `(DEFINE ,@(cdr sexp)) - sexp)) - true)) - ((named-structure? object) - (pp-top-level port object false) + (port (if (default-object? port) (current-output-port) port))) (newline port) + (cond ((named-structure? object) + (pretty-print object port) (for-each (lambda (element) - (pp-top-level port element false)) + (newline port) + (pretty-print element port)) (named-structure/description object))) + ((compound-procedure? object) + (pretty-print (procedure-lambda object) port)) (else - (pp-top-level port object as-code?)))) + (apply pretty-print object port rest))))) +(define (pretty-print object #!optional port as-code?) + (let ((port (if (default-object? port) (current-output-port) port))) + (if (scode-constant? object) + (pp-top-level object + port + (if (default-object? as-code?) false as-code?)) + (pp-top-level (let ((sexp (unsyntax object))) + (if (and *named-lambda->define?* + (pair? sexp) + (eq? (car sexp) 'NAMED-LAMBDA)) + `(DEFINE ,@(cdr sexp)) + sexp)) + port + true))) unspecific) -(define (pp-top-level port expression as-code?) +(define (pp-top-level expression port as-code?) (fluid-let ((x-size (get-x-size port)) (output-port port) (operation/write-char (output-port/operation/write-char port)) (operation/write-string (output-port/operation/write-string port))) (let ((node (numerical-walk expression))) - (*unparse-newline) ((if as-code? print-node print-non-code-node) node 0 0) + ((if as-code? print-node print-non-code-node) node 0 0) (output-port/flush-output port)))) (define (stepper-pp expression port p-wrapper table nc relink! sc! offset) diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index 4eb089455..6180b78f1 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.10 1989/08/03 23:03:04 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.11 1989/08/07 07:36:52 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -564,7 +564,7 @@ MIT in each case. |# (let loop () (newline output-port) (write-string prompt output-port) - (write-string "(y or n) " output-port) + (write-string " (y or n)? " output-port) (let ((char (char-upcase (read-char-internal input-port)))) (cond ((or (char=? #\Y char) (char=? #\Space char)) @@ -581,7 +581,9 @@ MIT in each case. |# (define (default/prompt-for-expression cmdl prompt) (let ((output-port (cmdl/output-port cmdl))) (newline output-port) - (write-string prompt output-port) (read (cmdl/input-port cmdl)))) + (write-string prompt output-port) + (write-string ": " output-port) + (read (cmdl/input-port cmdl)))) (define (read-char-internal input-port) (let loop () diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index a293a3f0e..3bcde19cd 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.43 1989/08/03 23:08:55 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.44 1989/08/07 07:36:56 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -288,6 +288,9 @@ MIT in each case. |# (export () continuation->stack-frame continuation/first-subproblem + hardware-trap-frame/describe + hardware-trap-frame/print-registers + hardware-trap-frame/print-stack microcode-return/code->type stack-frame->continuation stack-frame-type/code @@ -312,12 +315,9 @@ MIT in each case. |# stack-frame/skip-non-subproblems stack-frame/subproblem? stack-frame/type - stack-frame? - hardware-trap-frame/describe - hardware-trap-frame/print-stack - hardware-trap-frame/print-registers - ) - (initialization (initialize-package!))) + stack-frame?) + (export (runtime debugger) + stack-frame/compiled-code?) (initialization (initialize-package!))) (define-package (runtime control-point) (files "cpoint") @@ -366,13 +366,18 @@ MIT in each case. |# (parent (runtime debugger-command-loop)) (export (runtime debugger-command-loop) debug/read-eval-print-1 + debugger-failure + debugger-message 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/presentation) (initialization (initialize-package!))) (define-package (runtime debugging-info) @@ -1164,7 +1169,9 @@ MIT in each case. |# (files "pp") (parent ()) (export () - pp) (initialization (initialize-package!))) + pp + pretty-print) + (initialization (initialize-package!))) (define-package (runtime primitive-io) (files "io") diff --git a/v7/src/runtime/system.scm b/v7/src/runtime/system.scm index ccfdd5a46..9d23f4b62 100644 --- a/v7/src/runtime/system.scm +++ b/v7/src/runtime/system.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 14.5 1988/09/15 03:00:25 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 14.6 1989/08/07 07:37:02 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -102,7 +102,8 @@ MIT in each case. |# (let ((files (format-files-list (system/files-lists system) (if (default-object? compiled?) - (prompt-for-confirmation "Load compiled? ") compiled?)))) + (prompt-for-confirmation "Load compiled") + compiled?)))) (set-system/files! system (map (lambda (file) (pathname->string (car file))) files)) diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index bc3edbee2..6df9f4f33 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.48 1989/08/03 23:13:14 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.49 1989/08/07 07:37:05 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -45,7 +45,7 @@ MIT in each case. |# '())) (add-system! microcode-system) (add-event-receiver! event:after-restore snarf-microcode-version!) - (add-identification! "Runtime" 14 48)) + (add-identification! "Runtime" 14 49)) (define microcode-system) (define (snarf-microcode-version!) diff --git a/v7/src/runtime/where.scm b/v7/src/runtime/where.scm index d05699d48..dc9b4186e 100644 --- a/v7/src/runtime/where.scm +++ b/v7/src/runtime/where.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 14.6 1989/08/03 23:02:37 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 14.7 1989/08/07 07:37:09 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -37,6 +37,21 @@ MIT in each case. |# (declare (usual-integrations)) +(define (where #!optional environment) + (let ((environment + (if (default-object? environment) + (nearest-repl/environment) + (->environment environment)))) + (hook/repl-environment (nearest-repl) environment) + (letter-commands command-set + (cmdl-message/standard "Environment Inspector") + "Where-->" + (make-wstate (list environment))))) + +(define-structure (wstate + (conc-name wstate/)) + frame-list) + (define (initialize-package!) (set! command-set (make-command-set @@ -65,63 +80,55 @@ MIT in each case. |# unspecific) (define command-set) -(define frame-list) - -(define (where #!optional environment) - (let ((environment - (if (default-object? environment) - (nearest-repl/environment) - (->environment environment)))) - (hook/repl-environment (nearest-repl) environment) - (fluid-let ((frame-list (list environment))) - (letter-commands command-set - (cmdl-message/standard "Environment Inspector") - "Where-->")))) -(define (show) - (show-current-frame false)) - -(define (show-current-frame brief?) - (show-frame (car frame-list) (length (cdr frame-list)) brief?)) - -(define (show-all) - (show-frames (car (last-pair frame-list)) 0)) - -(define (parent) - (if (environment-has-parent? (car frame-list)) - (begin - (set! frame-list - (cons (environment-parent (car frame-list)) frame-list)) - (show-current-frame true)) - (begin - (newline) - (write-string "The current frame has no parent.")))) - -(define (son) - (let ((frames frame-list)) - (if (null? (cdr frames)) +(define (show wstate) + (show-current-frame wstate false)) + +(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-all wstate) + (show-frames (car (last-pair (wstate/frame-list wstate))) 0)) + +(define (parent wstate) + (let ((frame-list (wstate/frame-list wstate))) + (if (environment-has-parent? (car frame-list)) (begin - (newline) - (write-string - "This is the original frame. Its children cannot be found.")) + (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")))) + +(define (son wstate) + (let ((frames (wstate/frame-list wstate))) + (if (null? (cdr frames)) + (debugger-failure + "This is the original frame; its children cannot be found") (begin - (set! frame-list (cdr frames)) - (show-current-frame true))))) - -(define (name) - (newline) - (write-string "This frame was created by ") - (print-user-friendly-name (car frame-list))) - -(define (recursive-where) - (let ((inp (prompt-for-expression "Object to eval and examine-> "))) - (write-string "New where!") - (debug/where (debug/eval inp (car frame-list))))) - -(define (enter) - (debug/read-eval-print (car frame-list) + (set-wstate/frame-list! wstate (cdr frames)) + (show-current-frame wstate true))))) + +(define (name wstate) + (presentation + (lambda () + (write-string "This frame was created by ") + (print-user-friendly-name (car (wstate/frame-list wstate)))))) + +(define (recursive-where wstate) + (let ((inp (prompt-for-expression "Object to evaluate and examine"))) + (debugger-message "New where!") + (debug/where (debug/eval inp (car (wstate/frame-list wstate)))))) + +(define (enter wstate) + (debug/read-eval-print (car (wstate/frame-list wstate)) "You are now in the desired environment" "Eval-in-env-->")) -(define (show-object) - (debug/read-eval-print-1 (car frame-list))) \ No newline at end of file +(define (show-object wstate) + (debug/read-eval-print-1 (car (wstate/frame-list wstate)))) \ No newline at end of file diff --git a/v8/src/runtime/dbgutl.scm b/v8/src/runtime/dbgutl.scm index bdccf57a8..a337a1c00 100644 --- a/v8/src/runtime/dbgutl.scm +++ b/v8/src/runtime/dbgutl.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.7 1989/01/06 20:59:45 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.8 1989/08/07 07:36:25 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -53,9 +53,8 @@ MIT in each case. |# (if (string? name) (write-string name) (write name))) (define (debug/read-eval-print-1 environment) - (let ((value (debug/eval (prompt-for-expression "Eval--> ") environment))) - (newline) - (write value))) + (debugger-message + (debug/eval (prompt-for-expression "Evaluate expression") environment))) (define (output-to-string length thunk) (let ((x (with-output-to-truncated-string length thunk))) @@ -64,14 +63,16 @@ MIT in each case. |# (cdr x))) (define (show-frames environment depth) - (let loop ((environment environment) (depth depth)) - (newline) - (write-string "----------------------------------------") - (show-frame environment depth true) - (if (environment-has-parent? environment) - (begin - (newline) - (loop (environment-parent environment) (1+ depth)))))) + (presentation + (lambda () + (let loop ((environment environment) (depth depth)) + (write-string "----------------------------------------") + (show-frame environment depth true) + (if (environment-has-parent? environment) + (begin + (newline) + (newline) + (loop (environment-parent environment) (1+ depth)))))))) (define (show-frame environment depth brief?) (show-environment-name environment) @@ -137,4 +138,41 @@ MIT in each case. |# s (output-to-string (max (- x-size (string-length s)) 0) (lambda () - (write value)))))))))) \ No newline at end of file + (write value)))))))))) + +(define hook/debugger-failure) +(define hook/debugger-message) +(define hook/presentation) + +(define (initialize-package!) + (set! hook/debugger-failure default/debugger-failure) + (set! hook/debugger-message default/debugger-message) + (set! hook/presentation default/presentation) + unspecific) + +(define (debugger-failure . objects) + (hook/debugger-failure (message-arguments->string objects))) + +(define (default/debugger-failure message) + (beep) + (write-string message) + (newline)) + +(define (debugger-message . objects) + (hook/debugger-message (message-arguments->string objects))) + +(define (default/debugger-message message) + (write-string message) + (newline)) + +(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 diff --git a/v8/src/runtime/global.scm b/v8/src/runtime/global.scm index 28ad02cd3..a9fc34d18 100644 --- a/v8/src/runtime/global.scm +++ b/v8/src/runtime/global.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.10 1989/08/03 23:03:58 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.11 1989/08/07 07:36:38 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -171,7 +171,8 @@ MIT in each case. |# ((ucode-primitive primitive-type? 2) (ucode-type future) object)) (define (exit) - (if (prompt-for-confirmation "Kill Scheme? ") (%exit))) + (if (prompt-for-confirmation "Kill Scheme") + (%exit))) (define (%exit) (event-distributor/invoke! event:before-exit) diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm index f3313bf06..e92a6ee64 100644 --- a/v8/src/runtime/make.scm +++ b/v8/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.14 1989/08/03 23:07:40 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.15 1989/08/07 07:36:42 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -63,9 +63,7 @@ MIT in each case. |# substring=? substring-move-right! substring-downcase! - tty-beep tty-flush-output - tty-read-char-immediate tty-write-char tty-write-string vector-ref @@ -87,27 +85,6 @@ MIT in each case. |# (tty-write-char newline-char) (tty-flush-output) (exit)) - -(define (prompt-for-confirmation prompt) - (let loop () - (tty-write-char newline-char) - (tty-write-string prompt) - (tty-write-string "(y or n) ") - (tty-flush-output) - (let ((char (tty-read-char-immediate))) - (cond ((or (eq? #\y char) - (eq? #\Y char)) - (tty-write-string "Yes") - (tty-flush-output) - true) - ((or (eq? #\n char) - (eq? #\N char)) - (tty-write-string "No") - (tty-flush-output) - false) - (else - (tty-beep) - (loop)))))) ;;;; GC, Interrupts, Errors @@ -196,8 +173,8 @@ MIT in each case. |# false)) (define map-filename - (if (and (implemented-primitive-procedure? file-exists?) - (not (prompt-for-confirmation "Load interpreted? "))) (lambda (filename) + (if (implemented-primitive-procedure? file-exists?) + (lambda (filename) (let ((com-file (string-append filename ".com"))) (if (file-exists? com-file) com-file diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index b40674910..acf82be4c 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.43 1989/08/03 23:08:55 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.44 1989/08/07 07:36:56 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -288,6 +288,9 @@ MIT in each case. |# (export () continuation->stack-frame continuation/first-subproblem + hardware-trap-frame/describe + hardware-trap-frame/print-registers + hardware-trap-frame/print-stack microcode-return/code->type stack-frame->continuation stack-frame-type/code @@ -312,12 +315,9 @@ MIT in each case. |# stack-frame/skip-non-subproblems stack-frame/subproblem? stack-frame/type - stack-frame? - hardware-trap-frame/describe - hardware-trap-frame/print-stack - hardware-trap-frame/print-registers - ) - (initialization (initialize-package!))) + stack-frame?) + (export (runtime debugger) + stack-frame/compiled-code?) (initialization (initialize-package!))) (define-package (runtime control-point) (files "cpoint") @@ -366,13 +366,18 @@ MIT in each case. |# (parent (runtime debugger-command-loop)) (export (runtime debugger-command-loop) debug/read-eval-print-1 + debugger-failure + debugger-message 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/presentation) (initialization (initialize-package!))) (define-package (runtime debugging-info) @@ -1164,7 +1169,9 @@ MIT in each case. |# (files "pp") (parent ()) (export () - pp) (initialization (initialize-package!))) + pp + pretty-print) + (initialization (initialize-package!))) (define-package (runtime primitive-io) (files "io") -- 2.25.1