From: Chris Hanson Date: Fri, 6 Jan 1989 21:00:48 +0000 (+0000) Subject: Change handling of debugging information to match changes in compiler X-Git-Tag: 20090517-FFI~12301 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f3912bf41dbf3cdcb11c9b344bf2871d9d01a892;p=mit-scheme.git Change handling of debugging information to match changes in compiler version 4.37. Add facilities for accessing source code from debugging info. Add where commands `p' and `s' to debugger, moving the old commands bound to those keys. Change debugger display formats a bit. --- diff --git a/v7/src/runtime/dbgutl.scm b/v7/src/runtime/dbgutl.scm index 7b382f521..2cf12eaf7 100644 --- a/v7/src/runtime/dbgutl.scm +++ b/v7/src/runtime/dbgutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgutl.scm,v 14.6 1988/12/31 06:38:40 cph Exp $ +$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 $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -49,14 +49,6 @@ MIT in each case. |# (write-dbg-name name)))) (write-string "an unknown procedure")))) -(define (show-frames environment depth) - (let loop ((environment environment) (depth depth)) - (show-frame environment depth true) - (if (environment-has-parent? environment) - (begin - (newline) - (loop (environment-parent environment) (1+ depth)))))) - (define (write-dbg-name name) (if (string? name) (write-string name) (write name))) @@ -70,29 +62,39 @@ MIT in each case. |# (if (and (car x) (> length 4)) (substring-move-right! " ..." 0 4 (cdr x) (- length 4))) (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)))))) + (define (show-frame environment depth brief?) + (show-environment-name environment) + (if (not (negative? depth)) + (begin (newline) + (write-string "Depth (relative to initial environment): ") + (write depth))) + (if (not (and (environment->package environment) brief?)) + (begin + (newline) + (show-environment-bindings environment brief?)))) + +(define (show-environment-name environment) (newline) (write-string "Environment ") - (let ((show-bindings? - (let ((package (environment->package environment))) - (if package - (begin - (write-string "named ") - (write (package/name package)) - (not brief?)) - (begin - (write-string "created by ") - (print-user-friendly-name environment) - true))))) - (if (not (negative? depth)) - (begin (newline) - (write-string "Depth (relative to starting frame): ") - (write depth))) - (if show-bindings? + (let ((package (environment->package environment))) + (if package (begin - (newline) - (show-environment-bindings environment brief?))))) + (write-string "named ") + (write (package/name package))) + (begin + (write-string "created by ") + (print-user-friendly-name environment))))) (define (show-environment-bindings environment brief?) (let ((names (environment-bound-names environment))) diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index 9acbb9a79..accf8e19e 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.7 1988/12/30 23:29:54 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.8 1989/01/06 20:59:51 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -38,56 +38,59 @@ MIT in each case. |# (declare (usual-integrations)) (define (initialize-package!) - (set! command-set - (make-command-set - 'DEBUG-COMMANDS - `((#\? ,standard-help-command - "Help, list command letters") - (#\A ,show-all-frames - "Show bindings in current environment and its ancestors") - (#\B ,earlier-reduction-command - "Earlier reduction (Back in time)") - (#\C ,show-current-frame - "Show bindings of identifiers in the current environment") - (#\D ,later-subproblem-command - "Move (Down) to the next (later) subproblem") - (#\E ,enter-read-eval-print-loop - "Enter a read-eval-print loop in the current environment") - (#\F ,later-reduction-command - "Later reduction (Forward in time)") - (#\G ,goto-command - "Go to a particular Subproblem/Reduction level") - (#\H ,summarize-history-command - "Prints a summary of the entire history") - (#\I ,error-info-command - "Redisplay the error message") - (#\L ,pretty-print-current-expression - "(list expression) Pretty-print the current expression") - (#\P ,pretty-print-reduction-function - "Pretty print current procedure") - (#\Q ,standard-exit-command - "Quit (exit DEBUG)") - (#\R ,reductions-command - "Print the reductions of the current subproblem level") - (#\S ,print-current-expression - "Print the current subproblem/reduction") - (#\U ,earlier-subproblem-command - "Move (Up) to the previous (earlier) subproblem") - (#\V ,eval-in-current-environment - "Evaluate expression in current environment") - (#\W ,enter-where-command - "Enter WHERE on the current environment") - (#\X ,internal-command - "Create a read eval print loop in the debugger environment") - (#\Z ,return-command - "Return (continue with) an expression after evaluating it") - ))) + (set! + command-set + (make-command-set + 'DEBUG-COMMANDS + `((#\? ,standard-help-command + "Help, list command letters") + (#\A ,show-all-frames + "Show bindings in current environment and its ancestors") + (#\B ,earlier-reduction-command + "Earlier reduction (Back in time)") + (#\C ,show-current-frame + "Show bindings of identifiers in the current environment") + (#\D ,later-subproblem-command + "Move (Down) to the next (later) subproblem") + (#\E ,enter-read-eval-print-loop + "Enter a read-eval-print loop in the current environment") + (#\F ,later-reduction-command + "Later reduction (Forward in time)") + (#\G ,goto-command + "Go to a particular Subproblem/Reduction level") + (#\H ,summarize-history-command + "Prints a summary of the entire history") + (#\I ,error-info-command + "Redisplay the error message") + (#\L ,pretty-print-current-expression + "(list expression) Pretty-print the current expression") + (#\O ,pretty-print-environment-procedure + "Pretty print the procedure that created the current environment") + (#\P ,move-to-parent-environment + "Move to environment which is parent of current environment") + (#\Q ,standard-exit-command + "Quit (exit DEBUG)") + (#\R ,reductions-command + "Print the reductions of the current subproblem level") + (#\S ,move-to-child-environment + "Move to child of current environment (in current chain)") + (#\T ,print-current-reduction + "Print the current subproblem/reduction") + (#\U ,earlier-subproblem-command + "Move (Up) to the previous (earlier) subproblem") + (#\V ,eval-in-current-environment + "Evaluate expression in current environment") + (#\W ,enter-where-command + "Enter WHERE on the current environment") + (#\X ,internal-command + "Create a read eval print loop in the debugger environment") + (#\Z ,return-command + "Return (continue with) an expression after evaluating it") + ))) unspecific) (define command-set) -;;; Basic Commands - (define current-subproblem) (define previous-subproblems) (define current-subproblem-number) @@ -95,8 +98,8 @@ MIT in each case. |# (define current-reductions) (define current-number-of-reductions) (define current-reduction) -(define current-environment) (define current-expression) +(define environment-list) (define reduction-wrap-around-tag 'WRAP-AROUND) (define student-walk? false) @@ -111,8 +114,8 @@ MIT in each case. |# (current-reductions) (current-number-of-reductions) (current-reduction) - (current-environment) - (current-expression)) + (current-expression) + (environment-list)) (set-current-subproblem! (let ((object (if (default-object? object) @@ -125,7 +128,7 @@ MIT in each case. |# (lambda () 0)) (letter-commands command-set (cmdl-message/append - (cmdl-message/active print-current-expression) + (cmdl-message/active print-current-reduction) (cmdl-message/standard "Debugger")) "Debug-->"))) @@ -137,76 +140,108 @@ MIT in each case. |# (else (error "DEBUG: illegal argument" object)))) -;;;; Random display commands - -(define (pretty-print-current-expression) - (cond ((debugging-info/undefined-expression? current-expression) - (newline) - (write-string "")) - ((debugging-info/compiled-code? current-expression) - (newline) - (write-string "")) - (else - (pp current-expression)))) +;;;; Display commands -(define (pretty-print-reduction-function) - (if-valid-ic-environment current-environment - (lambda (environment) - (pp (ic-environment/procedure environment))))) +(define (print-current-reduction) + (print-current-expression) + (print-current-environment)) (define (print-current-expression) (newline) (write-string "Subproblem level: ") (write current-subproblem-number) - (cond (current-reduction - (write-string " Reduction number: ") - (write current-reduction-number) - (newline) - (write-string "Expression (from execution history):") - (pp current-expression) - (print-current-environment false)) - ((debugging-info/undefined-expression? current-expression) + (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) + (write-string + (if (stack-frame/compiled-code? current-subproblem) + "Compiled code expression" + "Expression")) + (if (or (debugging-info/undefined-expression? current-expression) + (debugging-info/compiled-code? current-expression)) + (write-string " unknown") + (begin + (write-string " (from stack):") + (print-expression current-expression)))))) + +(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/undefined-expression? current-expression) (newline) - (write-string "Unknown expression frame") - (print-current-environment true)) + (write-string ";undefined expression")) ((debugging-info/compiled-code? current-expression) (newline) - (write-string "Compiled code frame") - (print-current-environment true)) + (write-string ";compiled code")) (else - (newline) - (write-string "Expression (from stack):") - (pp current-expression) - (print-current-environment false)))) - -(define (print-current-environment continue-previous-line?) - (if-valid-environment current-environment - (lambda (environment) - (if (not continue-previous-line?) - (begin - (newline) - (write-string "Frame"))) - (write-string " created by ") - (print-user-friendly-name environment) - (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))))))))) + (print-expression current-expression)))) + +(define (pretty-print-environment-procedure) + (with-current-environment + (lambda (environment) + (let ((scode-lambda (environment-lambda environment))) + (if scode-lambda + (print-expression scode-lambda) + (begin + (newline) + (write-string + "Unable to get procedure for this environment"))))))) (define (reductions-command) (let loop ((reductions current-reductions)) (cond ((pair? reductions) - (pp (reduction-expression (car 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."))))) + (write-string "Wrap around in the reductions at this level"))))) + +(define (print-expression expression) + (pp expression)) ;;;; Short history display @@ -261,19 +296,24 @@ MIT in each case. |# (write-string " ") (write-string (cond ((debugging-info/undefined-expression? expression) - "") + ";undefined expression") ((debugging-info/compiled-code? expression) - "") + ";compiled code") (else - (output-to-string 50 (lambda () (write (unsyntax expression)))))))) + (output-to-string 50 + (lambda () (write-sexp (unsyntax expression)))))))) + +(define (write-sexp sexp) + (fluid-let ((*unparse-primitives-by-name?* true)) + (write sexp))) -;;;; Motion to earlier expressions +;;;; Subproblem/reduction motion (define (earlier-subproblem-command) (if (stack-frame/next-subproblem current-subproblem) (begin (earlier-subproblem) - (print-current-expression)) + (print-current-reduction)) (begin (beep) (newline) @@ -288,15 +328,16 @@ MIT in each case. |# (earlier-subproblem-command)) ((< current-reduction-number (-1+ current-number-of-reductions)) (set-current-reduction! (1+ current-reduction-number)) - (print-current-expression)) + (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!")) + "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) @@ -304,8 +345,6 @@ MIT in each case. |# (set-current-subproblem! (stack-frame/next-subproblem current-subproblem) (cons current-subproblem previous-subproblems) normal-reduction-number)) - -;;;; Motion to later expressions (define (later-subproblem-command) (later-subproblem normal-reduction-number)) @@ -314,7 +353,7 @@ MIT in each case. |# (if (positive? current-reduction-number) (begin (set-current-reduction! (-1+ current-reduction-number)) - (print-current-expression)) + (print-current-reduction)) (later-subproblem (if (or (not student-walk?) (= current-subproblem-number 1)) @@ -331,7 +370,7 @@ MIT in each case. |# (set-current-subproblem! (car previous-subproblems) (cdr previous-subproblems) select-reduction-number) - (print-current-expression)))) + (print-current-reduction)))) ;;;; General motion command @@ -360,7 +399,7 @@ MIT in each case. |# (begin (beep) (newline) - (write-string "There is no such subproblem.") + (write-string "There is no such subproblem") (newline) (write-string "Now at subproblem number: ~o") (write current-subproblem-number))))))))) @@ -393,34 +432,63 @@ MIT in each case. |# 0) (else (newline) - (write-string "There are no reductions for this subproblem.") + (write-string "There are no reductions for this subproblem") -1))) - (print-current-expression)) + (print-current-reduction)) -;;;; Evaluation and frame display commands - -(define (enter-read-eval-print-loop) - (with-rep-alternative current-environment - (lambda (environment) - (debug/read-eval-print environment - "You are now in the desired environment" - "Eval-in-env-->")))) - -(define (eval-in-current-environment) - (with-rep-alternative current-environment debug/read-eval-print-1)) +;;;; Environment motion and display (define (show-current-frame) - (if-valid-environment current-environment - (lambda (environment) - (show-frame environment -1 false)))) + (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-valid-environment current-environment - (lambda (environment) - (show-frames environment 0)))) + (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) + (with-rep-environment + (lambda (environment) + (debug/read-eval-print environment + "You are now in the desired environment" + "Eval-in-env-->")))) + +(define (eval-in-current-environment) + (with-rep-environment debug/read-eval-print-1)) (define (enter-where-command) - (if-valid-environment current-environment debug/where)) + (with-current-environment debug/where)) + +;;;; Error info (define (error-info-command) (let ((message (error-message)) @@ -460,25 +528,25 @@ MIT in each case. |# (define (return-command) (let ((next (stack-frame/next-subproblem current-subproblem))) (if next - (with-rep-alternative current-environment - (lambda (environment) - (let ((value - (debug/eval - (let ((expression - (prompt-for-expression - "Expression to EVALUATE and CONTINUE with ($ to retry): "))) - (if (eq? expression '$) - (unsyntax current-expression) - expression)) - environment))) - (if print-return-values? - (begin - (newline) - (write-string "That evaluates to:") - (newline) - (write value) - (if (prompt-for-confirmation "Confirm: ") (next value))) - (next value))))) + (with-rep-environment + (lambda (environment) + (let ((value + (debug/eval + (let ((expression + (prompt-for-expression + "Expression to EVALUATE and CONTINUE with ($ to retry): "))) + (if (eq? expression '$) + (unsyntax current-expression) + expression)) + environment))) + (if print-return-values? + (begin + (newline) + (write-string "That evaluates to:") + (newline) + (write value) + (if (prompt-for-confirmation "Confirm: ") (next value))) + (next value))))) (begin (beep) (newline) @@ -518,11 +586,15 @@ MIT in each case. |# (if current-reduction (begin (set! current-expression (reduction-expression current-reduction)) - (set! current-environment (reduction-environment 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! current-environment environment))))) + (set! environment-list + (if (debugging-info/undefined-environment? environment) + '() + (list environment))))))) ;;;; Utilities @@ -547,33 +619,23 @@ MIT in each case. |# (eq? (list-tail reductions (dotted-list-length reductions)) reduction-wrap-around-tag)) -(define (with-rep-alternative environment receiver) - (if (interpreter-environment? environment) - (receiver environment) +(define (with-current-environment receiver) + (if (pair? environment-list) + (receiver (car environment-list)) + (print-undefined-environment))) + +(define (with-rep-environment receiver) + (if (and (pair? environment-list) + (interpreter-environment? (car environment-list))) + (receiver (car environment-list)) (begin - (print-undefined-environment) (newline) - (write-string "Using the read-eval-print environment instead!") + (write-string "Cannot evaluate in current environment") + (newline) + (write-string "Using the read-eval-print environment instead") (receiver (nearest-repl/environment))))) -(define (if-valid-environment environment receiver) - (cond ((debugging-info/undefined-environment? environment) - (print-undefined-environment)) - ((system-global-environment? environment) - (newline) - (write-string - "System global environment at this subproblem/reduction level")) - (else - (receiver environment)))) - -(define (if-valid-ic-environment environment receiver) - (if-valid-environment environment - (if (ic-environment? environment) - receiver - (lambda (environment) - environment - (print-undefined-environment))))) - (define (print-undefined-environment) + (beep) (newline) - (write-string "Undefined environment at this subproblem/reduction level")) \ No newline at end of file + (write-string "There is no current environment")) \ No newline at end of file diff --git a/v7/src/runtime/framex.scm b/v7/src/runtime/framex.scm index b400f0aca..45adb8042 100644 --- a/v7/src/runtime/framex.scm +++ b/v7/src/runtime/framex.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.3 1988/12/30 06:42:40 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.4 1989/01/06 21:00:05 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -87,7 +87,28 @@ MIT in each case. |# (values undefined-expression (stack-frame/ref frame 2))) (define (method/compiled-code frame) - (values compiled-code (stack-frame/environment frame undefined-environment))) + (values + (let ((continuation + (compiled-entry/dbg-object (stack-frame/return-address frame))) + (lose (lambda () compiled-code))) + (if continuation + (let ((source-code (dbg-continuation/source-code continuation))) + (if (and (vector? source-code) + (not (zero? (vector-length source-code)))) + (case (vector-ref source-code 0) + ((SEQUENCE-2-SECOND + SEQUENCE-3-SECOND + SEQUENCE-3-THIRD + CONDITIONAL-DECIDE + ASSIGNMENT-CONTINUE + DEFINITION-CONTINUE + COMBINATION-OPERAND) + (vector-ref source-code 1)) + (else + (lose))) + (lose))) + (lose))) + (stack-frame/environment frame undefined-environment))) (define (method/primitive-combination-3-first-operand frame) (values (stack-frame/ref frame 1) (stack-frame/ref frame 3))) diff --git a/v7/src/runtime/infstr.scm b/v7/src/runtime/infstr.scm index ec499a0f4..d24e918d8 100644 --- a/v7/src/runtime/infstr.scm +++ b/v7/src/runtime/infstr.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infstr.scm,v 1.1 1988/12/30 06:54:01 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infstr.scm,v 1.2 1989/01/06 21:00:12 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -76,7 +76,8 @@ MIT in each case. |# (string->symbol "#[(runtime compiler-info)dbg-procedure]")) (constructor make-dbg-procedure - (block label type name required optional rest auxiliary)) + (block label type name required optional rest auxiliary + source-code)) (conc-name dbg-procedure/)) (block false read-only true) ;dbg-block (label false) ;dbg-label @@ -87,6 +88,7 @@ MIT in each case. |# (rest false read-only true) ;name of rest argument, or #F (auxiliary false read-only true) ;names of internal definitions (external-label false) ;for closure, external entry + (source-code false read-only true) ;SCode ) (define (dbg-procedure/label-offset procedure) @@ -96,7 +98,7 @@ MIT in each case. |# (define-integrable (dbg-proceduresymbol @@ -106,6 +108,7 @@ MIT in each case. |# (label false) ;dbg-label (type false read-only true) (offset false read-only true) ;difference between sp and block + (source-code false read-only true) ) (define-integrable (dbg-continuation/label-offset continuation) @@ -113,19 +116,31 @@ MIT in each case. |# (define-integrable (dbg-continuationsymbol "#[(runtime compiler-info)dbg-block]")) - (constructor make-dbg-block (type parent layout stack-link)) + (constructor + make-dbg-block + (type parent original-parent layout stack-link)) (conc-name dbg-block/)) (type false read-only true) ;continuation, stack, closure, ic (parent false read-only true) ;parent block, or #F + (original-parent false read-only true) ;for closures, closing block (layout false read-only true) ;vector of names, except #F for ic (stack-link false read-only true) ;next block on stack, or #F (procedure false) ;procedure which this is block of ) +(define-structure (dbg-variable + (named + (string->symbol "#[(runtime compiler-info)dbg-variable]")) + (conc-name dbg-variable/)) + (name false read-only true) ;symbol + (type false read-only true) ;normal, cell, integrated + value ;for integrated, the value + ) + (let-syntax ((dbg-block-name (macro (name) diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm index 17877f2e2..c1bcafe65 100644 --- a/v7/src/runtime/infutl.scm +++ b/v7/src/runtime/infutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.6 1988/12/31 05:52:51 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.7 1989/01/06 21:00:16 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -170,25 +170,24 @@ MIT in each case. |# ((< key* key) (loop (1+ midpoint) end)) (else item)))))))) (define (fasload/update-debugging-info! value com-pathname) - (let ((process-entry - (lambda (entry) - (let ((block (compiled-code-address->block entry))) - (let ((info (compiled-code-block/debugging-info block))) - (cond ((string? info) - (set-compiled-code-block/debugging-info! - block - (process-binf-filename info com-pathname))) - ((and (pair? info) (string? (car info))) - (set-car! info - (process-binf-filename (car info) - com-pathname))))))))) + (let ((process-block + (lambda (block) + (let ((info (compiled-code-block/debugging-info block))) + (cond ((string? info) + (set-compiled-code-block/debugging-info! + block + (process-binf-filename info com-pathname))) + ((and (pair? info) (string? (car info))) + (set-car! info + (process-binf-filename (car info) + com-pathname)))))))) (cond ((compiled-code-address? value) - (process-entry value)) + (process-block (compiled-code-address->block value))) ((comment? value) (let ((text (comment-text value))) (if (dbg-info-vector? text) (for-each - process-entry + process-block (vector->list (dbg-info-vector/items text))))))))) (define (process-binf-filename binf-filename com-pathname) (pathname->string @@ -268,61 +267,11 @@ MIT in each case. |# (let ((end (vector-length layout))) (let loop ((index 0)) (and (< index end) - (if (dbg-name=? name (vector-ref layout index)) + (if (let ((item (vector-ref layout index))) + (and (dbg-variable? item) + (eq? name (dbg-variable/name item)))) index (loop (1+ index)))))))) - -(define-integrable (symbol->dbg-name symbol) - (cond ((object-type? (ucode-type interned-symbol) symbol) - (system-pair-car symbol)) - ((object-type? (ucode-type uninterned-symbol) symbol) - symbol) - (else - (error "SYMBOL->DBG-NAME: not a symbol" symbol)))) - -(define (dbg-name? object) - (or (string? object) - (object-type? (ucode-type interned-symbol) object) - (object-type? (ucode-type uninterned-symbol) object))) - -(define (dbg-name/normal? object) - (or (string? object) - (object-type? (ucode-type uninterned-symbol) object))) - -(define (dbg-name=? x y) - (or (eq? x y) - (let ((name->string - (lambda (name) - (cond ((string? name) - name) - ((object-type? (ucode-type interned-symbol) name) - (system-pair-car name)) - (else - false))))) - (let ((x (name->string x)) (y (name->string y))) - (and x y (string-ci=? x y)))))) - -(define (dbg-namestring - (lambda (name) - (cond ((string? name) - name) - ((or (object-type? (ucode-type interned-symbol) name) - (object-type? (ucode-type uninterned-symbol) name)) - (system-pair-car name)) - (else - (error "Illegal dbg-name" name)))))) - (string-cistring x) (name->string y)))) - -(define (dbg-name/string name) - (cond ((string? name) - name) - ((object-type? (ucode-type interned-symbol) name) - (system-pair-car name)) - ((object-type? (ucode-type uninterned-symbol) name) - (write-to-string name)) - (else - (error "Illegal dbg-name" name)))) (let ((procedure (compiled-entry/dbg-object entry *compiler-info/load-on-demand?*))) @@ -330,16 +279,12 @@ MIT in each case. |# (and procedure (let ((name (dbg-procedure/name procedure))) (or (special-form-procedure-name? name) - name))))) -(define *compiler-info/load-on-demand?* + (symbol->string name))))))(define *compiler-info/load-on-demand?* false) (define (special-form-procedure-name? name) - (let ((association - (list-search-positive special-form-procedure-names - (lambda (association) - (dbg-name=? (car association) name))))) + (let ((association (assq name special-form-procedure-names))) (and association (symbol->string (cdr association))))) (define special-form-procedure-names) entry))) \ No newline at end of file diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index cf202e167..8cb3cdf48 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.25 1988/12/30 23:42:18 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.26 1989/01/06 21:00:24 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -225,6 +225,7 @@ MIT in each case. |# dbg-block/ic-parent-index dbg-block/layout dbg-block/normal-closure-index + dbg-block/original-parent dbg-block/parent dbg-block/procedure dbg-block/stack-link @@ -232,12 +233,18 @@ MIT in each case. |# dbg-block/type dbg-continuation/block dbg-continuation/offset - dbg-name/normal? dbg-procedure/block dbg-procedure/name dbg-procedure/required dbg-procedure/optional - dbg-procedure/rest) + dbg-procedure/rest + dbg-procedure/source-code + dbg-variable/name + dbg-variable/type + dbg-variable/value + dbg-variable?) + (export (runtime debugging-info) + dbg-continuation/source-code) (initialization (initialize-package!))) (define-package (runtime console-input) @@ -356,6 +363,7 @@ MIT in each case. |# output-to-string print-user-friendly-name show-environment-bindings + show-environment-name show-frame show-frames write-dbg-name) @@ -401,9 +409,11 @@ MIT in each case. |# (parent ()) (export () environment-arguments + environment-bindings environment-bound-names environment-bound? environment-has-parent? + environment-lambda environment-lookup environment-parent environment-procedure-name @@ -414,8 +424,6 @@ MIT in each case. |# (export (runtime advice) ic-environment/arguments ic-environment/procedure) - (export (runtime debugger) - ic-environment/procedure) (export (runtime debugging-info) stack-frame/environment)) @@ -1647,6 +1655,8 @@ MIT in each case. |# (export (runtime pretty-printer) unparse-list/unparser unparse-vector/unparser) + (export (runtime debugger) + *unparse-primitives-by-name?*) (initialization (initialize-package!))) (define-package (runtime unsyntaxer) diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm index 844f9261e..7e9fef16f 100644 --- a/v7/src/runtime/uenvir.scm +++ b/v7/src/runtime/uenvir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.4 1988/12/30 06:43:34 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.5 1989/01/06 21:00:34 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -75,6 +75,15 @@ MIT in each case. |# ((closure-ccenv? environment) (closure-ccenv/bound-names environment)) (else (error "Illegal environment" environment)))) + +(define (environment-bindings environment) + (map (lambda (name) + (cons name + (let ((value (environment-lookup environment name))) + (if (unassigned-reference-trap? value) + '() + (list value))))) + (environment-bound-names environment))) (define (environment-arguments environment) (cond ((ic-environment? environment) @@ -87,14 +96,19 @@ MIT in each case. |# (else (error "Illegal environment" environment)))) (define (environment-procedure-name environment) + (let ((scode-lambda (environment-lambda environment))) + (and scode-lambda + (lambda-name scode-lambda)))) + +(define (environment-lambda environment) (cond ((system-global-environment? environment) false) ((ic-environment? environment) - (ic-environment/procedure-name environment)) + (ic-environment/lambda environment)) ((stack-ccenv? environment) - (stack-ccenv/procedure-name environment)) + (stack-ccenv/lambda environment)) ((closure-ccenv? environment) - (closure-ccenv/procedure-name environment)) + (closure-ccenv/lambda environment)) (else (error "Illegal environment" environment)))) (define (environment-bound? environment name) @@ -160,9 +174,6 @@ MIT in each case. |# (error "Bad IC environment" object)) object) -(define (ic-environment/procedure-name environment) - (lambda-name (procedure-lambda (ic-environment/procedure environment)))) - (define (ic-environment/has-parent? environment) (not (eq? (ic-environment/parent environment) null-environment))) @@ -202,6 +213,9 @@ MIT in each case. |# lookup required))))) +(define (ic-environment/lambda environment) + (procedure-lambda (ic-environment/procedure environment))) + (define (ic-environment/procedure environment) (select-procedure (ic-environment->external environment))) diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm index 2ab2b0c8d..cd75ac37c 100644 --- a/v7/src/runtime/unpars.scm +++ b/v7/src/runtime/unpars.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.10 1988/12/30 06:43:48 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.11 1989/01/06 21:00:42 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -44,12 +44,16 @@ MIT in each case. |# (set! *unparser-radix* 10) (set! *unparser-list-breadth-limit* false) (set! *unparser-list-depth-limit* false) + (set! *unparse-primitives-by-name?* false) + (set! *unparse-uninterned-symbols-by-name?* false) (set! system-global-unparser-table (make-system-global-unparser-table)) (set-current-unparser-table! system-global-unparser-table)) (define *unparser-radix*) (define *unparser-list-breadth-limit*) (define *unparser-list-depth-limit*) +(define *unparse-primitives-by-name?*) +(define *unparse-uninterned-symbols-by-name?*) (define system-global-unparser-table) (define *current-unparser-table*) @@ -216,7 +220,7 @@ MIT in each case. |# ((1 2 3 4 -3 -4) ; cell pair triple quad vector compiled (*unparse-with-brackets type object false)) (else ; non pointer, gc special, undefined - (*unparse-with-brackets type false + (*unparse-with-brackets type object (lambda () (*unparse-datum object))))))) @@ -270,9 +274,10 @@ MIT in each case. |# (define hook/interned-symbol) (define (unparse/uninterned-symbol symbol) - (*unparse-with-brackets 'UNINTERNED-SYMBOL - symbol - (lambda () (unparse-symbol symbol)))) + (let ((unparse-symbol (lambda () (unparse-symbol symbol)))) + (if *unparse-uninterned-symbols-by-name?* + (unparse-symbol) + (*unparse-with-brackets 'UNINTERNED-SYMBOL symbol unparse-symbol)))) (define (unparse-symbol symbol) (*unparse-string (symbol->string symbol))) @@ -439,10 +444,12 @@ MIT in each case. |# (lambda () (*unparse-object name))))))) (define (unparse/primitive-procedure procedure) - (*unparse-with-brackets 'PRIMITIVE-PROCEDURE false - (lambda () - (*unparse-object (primitive-procedure-name procedure))))) - + (let ((unparse-name + (lambda () + (*unparse-object (primitive-procedure-name procedure))))) + (if *unparse-primitives-by-name?* + (unparse-name) + (*unparse-with-brackets 'PRIMITIVE-PROCEDURE false unparse-name)))) (define (unparse/compiled-entry entry) (let* ((type (compiled-entry-type entry)) (closure? diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 301bdc6f9..7e242da62 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.31 1988/12/30 06:43:59 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.32 1989/01/06 21:00:48 cph Exp $ Copyright (c) 1988 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 31)) + (add-identification! "Runtime" 14 32)) (define microcode-system) diff --git a/v8/src/runtime/dbgutl.scm b/v8/src/runtime/dbgutl.scm index fd76d2075..bdccf57a8 100644 --- a/v8/src/runtime/dbgutl.scm +++ b/v8/src/runtime/dbgutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.6 1988/12/31 06:38:40 cph Exp $ +$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 $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -49,14 +49,6 @@ MIT in each case. |# (write-dbg-name name)))) (write-string "an unknown procedure")))) -(define (show-frames environment depth) - (let loop ((environment environment) (depth depth)) - (show-frame environment depth true) - (if (environment-has-parent? environment) - (begin - (newline) - (loop (environment-parent environment) (1+ depth)))))) - (define (write-dbg-name name) (if (string? name) (write-string name) (write name))) @@ -70,29 +62,39 @@ MIT in each case. |# (if (and (car x) (> length 4)) (substring-move-right! " ..." 0 4 (cdr x) (- length 4))) (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)))))) + (define (show-frame environment depth brief?) + (show-environment-name environment) + (if (not (negative? depth)) + (begin (newline) + (write-string "Depth (relative to initial environment): ") + (write depth))) + (if (not (and (environment->package environment) brief?)) + (begin + (newline) + (show-environment-bindings environment brief?)))) + +(define (show-environment-name environment) (newline) (write-string "Environment ") - (let ((show-bindings? - (let ((package (environment->package environment))) - (if package - (begin - (write-string "named ") - (write (package/name package)) - (not brief?)) - (begin - (write-string "created by ") - (print-user-friendly-name environment) - true))))) - (if (not (negative? depth)) - (begin (newline) - (write-string "Depth (relative to starting frame): ") - (write depth))) - (if show-bindings? + (let ((package (environment->package environment))) + (if package (begin - (newline) - (show-environment-bindings environment brief?))))) + (write-string "named ") + (write (package/name package))) + (begin + (write-string "created by ") + (print-user-friendly-name environment))))) (define (show-environment-bindings environment brief?) (let ((names (environment-bound-names environment))) diff --git a/v8/src/runtime/framex.scm b/v8/src/runtime/framex.scm index 2a15be58a..f9c97fece 100644 --- a/v8/src/runtime/framex.scm +++ b/v8/src/runtime/framex.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.3 1988/12/30 06:42:40 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.4 1989/01/06 21:00:05 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -87,7 +87,28 @@ MIT in each case. |# (values undefined-expression (stack-frame/ref frame 2))) (define (method/compiled-code frame) - (values compiled-code (stack-frame/environment frame undefined-environment))) + (values + (let ((continuation + (compiled-entry/dbg-object (stack-frame/return-address frame))) + (lose (lambda () compiled-code))) + (if continuation + (let ((source-code (dbg-continuation/source-code continuation))) + (if (and (vector? source-code) + (not (zero? (vector-length source-code)))) + (case (vector-ref source-code 0) + ((SEQUENCE-2-SECOND + SEQUENCE-3-SECOND + SEQUENCE-3-THIRD + CONDITIONAL-DECIDE + ASSIGNMENT-CONTINUE + DEFINITION-CONTINUE + COMBINATION-OPERAND) + (vector-ref source-code 1)) + (else + (lose))) + (lose))) + (lose))) + (stack-frame/environment frame undefined-environment))) (define (method/primitive-combination-3-first-operand frame) (values (stack-frame/ref frame 1) (stack-frame/ref frame 3))) diff --git a/v8/src/runtime/infstr.scm b/v8/src/runtime/infstr.scm index 864c27e70..f321955ea 100644 --- a/v8/src/runtime/infstr.scm +++ b/v8/src/runtime/infstr.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infstr.scm,v 1.1 1988/12/30 06:54:01 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infstr.scm,v 1.2 1989/01/06 21:00:12 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -76,7 +76,8 @@ MIT in each case. |# (string->symbol "#[(runtime compiler-info)dbg-procedure]")) (constructor make-dbg-procedure - (block label type name required optional rest auxiliary)) + (block label type name required optional rest auxiliary + source-code)) (conc-name dbg-procedure/)) (block false read-only true) ;dbg-block (label false) ;dbg-label @@ -87,6 +88,7 @@ MIT in each case. |# (rest false read-only true) ;name of rest argument, or #F (auxiliary false read-only true) ;names of internal definitions (external-label false) ;for closure, external entry + (source-code false read-only true) ;SCode ) (define (dbg-procedure/label-offset procedure) @@ -96,7 +98,7 @@ MIT in each case. |# (define-integrable (dbg-proceduresymbol @@ -106,6 +108,7 @@ MIT in each case. |# (label false) ;dbg-label (type false read-only true) (offset false read-only true) ;difference between sp and block + (source-code false read-only true) ) (define-integrable (dbg-continuation/label-offset continuation) @@ -113,19 +116,31 @@ MIT in each case. |# (define-integrable (dbg-continuationsymbol "#[(runtime compiler-info)dbg-block]")) - (constructor make-dbg-block (type parent layout stack-link)) + (constructor + make-dbg-block + (type parent original-parent layout stack-link)) (conc-name dbg-block/)) (type false read-only true) ;continuation, stack, closure, ic (parent false read-only true) ;parent block, or #F + (original-parent false read-only true) ;for closures, closing block (layout false read-only true) ;vector of names, except #F for ic (stack-link false read-only true) ;next block on stack, or #F (procedure false) ;procedure which this is block of ) +(define-structure (dbg-variable + (named + (string->symbol "#[(runtime compiler-info)dbg-variable]")) + (conc-name dbg-variable/)) + (name false read-only true) ;symbol + (type false read-only true) ;normal, cell, integrated + value ;for integrated, the value + ) + (let-syntax ((dbg-block-name (macro (name) diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm index de0eeee7f..ba4be1fae 100644 --- a/v8/src/runtime/infutl.scm +++ b/v8/src/runtime/infutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.6 1988/12/31 05:52:51 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.7 1989/01/06 21:00:16 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -170,25 +170,24 @@ MIT in each case. |# ((< key* key) (loop (1+ midpoint) end)) (else item)))))))) (define (fasload/update-debugging-info! value com-pathname) - (let ((process-entry - (lambda (entry) - (let ((block (compiled-code-address->block entry))) - (let ((info (compiled-code-block/debugging-info block))) - (cond ((string? info) - (set-compiled-code-block/debugging-info! - block - (process-binf-filename info com-pathname))) - ((and (pair? info) (string? (car info))) - (set-car! info - (process-binf-filename (car info) - com-pathname))))))))) + (let ((process-block + (lambda (block) + (let ((info (compiled-code-block/debugging-info block))) + (cond ((string? info) + (set-compiled-code-block/debugging-info! + block + (process-binf-filename info com-pathname))) + ((and (pair? info) (string? (car info))) + (set-car! info + (process-binf-filename (car info) + com-pathname)))))))) (cond ((compiled-code-address? value) - (process-entry value)) + (process-block (compiled-code-address->block value))) ((comment? value) (let ((text (comment-text value))) (if (dbg-info-vector? text) (for-each - process-entry + process-block (vector->list (dbg-info-vector/items text))))))))) (define (process-binf-filename binf-filename com-pathname) (pathname->string @@ -268,61 +267,11 @@ MIT in each case. |# (let ((end (vector-length layout))) (let loop ((index 0)) (and (< index end) - (if (dbg-name=? name (vector-ref layout index)) + (if (let ((item (vector-ref layout index))) + (and (dbg-variable? item) + (eq? name (dbg-variable/name item)))) index (loop (1+ index)))))))) - -(define-integrable (symbol->dbg-name symbol) - (cond ((object-type? (ucode-type interned-symbol) symbol) - (system-pair-car symbol)) - ((object-type? (ucode-type uninterned-symbol) symbol) - symbol) - (else - (error "SYMBOL->DBG-NAME: not a symbol" symbol)))) - -(define (dbg-name? object) - (or (string? object) - (object-type? (ucode-type interned-symbol) object) - (object-type? (ucode-type uninterned-symbol) object))) - -(define (dbg-name/normal? object) - (or (string? object) - (object-type? (ucode-type uninterned-symbol) object))) - -(define (dbg-name=? x y) - (or (eq? x y) - (let ((name->string - (lambda (name) - (cond ((string? name) - name) - ((object-type? (ucode-type interned-symbol) name) - (system-pair-car name)) - (else - false))))) - (let ((x (name->string x)) (y (name->string y))) - (and x y (string-ci=? x y)))))) - -(define (dbg-namestring - (lambda (name) - (cond ((string? name) - name) - ((or (object-type? (ucode-type interned-symbol) name) - (object-type? (ucode-type uninterned-symbol) name)) - (system-pair-car name)) - (else - (error "Illegal dbg-name" name)))))) - (string-cistring x) (name->string y)))) - -(define (dbg-name/string name) - (cond ((string? name) - name) - ((object-type? (ucode-type interned-symbol) name) - (system-pair-car name)) - ((object-type? (ucode-type uninterned-symbol) name) - (write-to-string name)) - (else - (error "Illegal dbg-name" name)))) (let ((procedure (compiled-entry/dbg-object entry *compiler-info/load-on-demand?*))) @@ -330,16 +279,12 @@ MIT in each case. |# (and procedure (let ((name (dbg-procedure/name procedure))) (or (special-form-procedure-name? name) - name))))) -(define *compiler-info/load-on-demand?* + (symbol->string name))))))(define *compiler-info/load-on-demand?* false) (define (special-form-procedure-name? name) - (let ((association - (list-search-positive special-form-procedure-names - (lambda (association) - (dbg-name=? (car association) name))))) + (let ((association (assq name special-form-procedure-names))) (and association (symbol->string (cdr association))))) (define special-form-procedure-names) entry))) \ No newline at end of file diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 88c547fcd..2b5d0afcb 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.25 1988/12/30 23:42:18 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.26 1989/01/06 21:00:24 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -225,6 +225,7 @@ MIT in each case. |# dbg-block/ic-parent-index dbg-block/layout dbg-block/normal-closure-index + dbg-block/original-parent dbg-block/parent dbg-block/procedure dbg-block/stack-link @@ -232,12 +233,18 @@ MIT in each case. |# dbg-block/type dbg-continuation/block dbg-continuation/offset - dbg-name/normal? dbg-procedure/block dbg-procedure/name dbg-procedure/required dbg-procedure/optional - dbg-procedure/rest) + dbg-procedure/rest + dbg-procedure/source-code + dbg-variable/name + dbg-variable/type + dbg-variable/value + dbg-variable?) + (export (runtime debugging-info) + dbg-continuation/source-code) (initialization (initialize-package!))) (define-package (runtime console-input) @@ -356,6 +363,7 @@ MIT in each case. |# output-to-string print-user-friendly-name show-environment-bindings + show-environment-name show-frame show-frames write-dbg-name) @@ -401,9 +409,11 @@ MIT in each case. |# (parent ()) (export () environment-arguments + environment-bindings environment-bound-names environment-bound? environment-has-parent? + environment-lambda environment-lookup environment-parent environment-procedure-name @@ -414,8 +424,6 @@ MIT in each case. |# (export (runtime advice) ic-environment/arguments ic-environment/procedure) - (export (runtime debugger) - ic-environment/procedure) (export (runtime debugging-info) stack-frame/environment)) @@ -1647,6 +1655,8 @@ MIT in each case. |# (export (runtime pretty-printer) unparse-list/unparser unparse-vector/unparser) + (export (runtime debugger) + *unparse-primitives-by-name?*) (initialization (initialize-package!))) (define-package (runtime unsyntaxer) diff --git a/v8/src/runtime/uenvir.scm b/v8/src/runtime/uenvir.scm index be4a412d8..70c446b66 100644 --- a/v8/src/runtime/uenvir.scm +++ b/v8/src/runtime/uenvir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.4 1988/12/30 06:43:34 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.5 1989/01/06 21:00:34 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -75,6 +75,15 @@ MIT in each case. |# ((closure-ccenv? environment) (closure-ccenv/bound-names environment)) (else (error "Illegal environment" environment)))) + +(define (environment-bindings environment) + (map (lambda (name) + (cons name + (let ((value (environment-lookup environment name))) + (if (unassigned-reference-trap? value) + '() + (list value))))) + (environment-bound-names environment))) (define (environment-arguments environment) (cond ((ic-environment? environment) @@ -87,14 +96,19 @@ MIT in each case. |# (else (error "Illegal environment" environment)))) (define (environment-procedure-name environment) + (let ((scode-lambda (environment-lambda environment))) + (and scode-lambda + (lambda-name scode-lambda)))) + +(define (environment-lambda environment) (cond ((system-global-environment? environment) false) ((ic-environment? environment) - (ic-environment/procedure-name environment)) + (ic-environment/lambda environment)) ((stack-ccenv? environment) - (stack-ccenv/procedure-name environment)) + (stack-ccenv/lambda environment)) ((closure-ccenv? environment) - (closure-ccenv/procedure-name environment)) + (closure-ccenv/lambda environment)) (else (error "Illegal environment" environment)))) (define (environment-bound? environment name) @@ -160,9 +174,6 @@ MIT in each case. |# (error "Bad IC environment" object)) object) -(define (ic-environment/procedure-name environment) - (lambda-name (procedure-lambda (ic-environment/procedure environment)))) - (define (ic-environment/has-parent? environment) (not (eq? (ic-environment/parent environment) null-environment))) @@ -202,6 +213,9 @@ MIT in each case. |# lookup required))))) +(define (ic-environment/lambda environment) + (procedure-lambda (ic-environment/procedure environment))) + (define (ic-environment/procedure environment) (select-procedure (ic-environment->external environment)))