#| -*-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
(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)))
(if (and (car x) (> length 4))
(substring-move-right! " ..." 0 4 (cdr x) (- length 4)))
(cdr x)))
-\f
+
+(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?))))
+\f
+(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)))
#| -*-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
(declare (usual-integrations))
\f
(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)
\f
-;;; Basic Commands
-
(define current-subproblem)
(define previous-subproblems)
(define current-subproblem-number)
(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)
(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)
(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-->")))
(else
(error "DEBUG: illegal argument" object))))
\f
-;;;; Random display commands
-
-(define (pretty-print-current-expression)
- (cond ((debugging-info/undefined-expression? current-expression)
- (newline)
- (write-string "<undefined-expression>"))
- ((debugging-info/compiled-code? current-expression)
- (newline)
- (write-string "<compiled-code>"))
- (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)))))))))
+\f
+(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))
\f
;;;; Short history display
(write-string " ")
(write-string
(cond ((debugging-info/undefined-expression? expression)
- "<undefined-expression>")
+ ";undefined expression")
((debugging-info/compiled-code? expression)
- "<compiled-code>")
+ ";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)))
\f
-;;;; 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)
(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)
(set-current-subproblem! (stack-frame/next-subproblem current-subproblem)
(cons current-subproblem previous-subproblems)
normal-reduction-number))
-\f
-;;;; Motion to later expressions
(define (later-subproblem-command)
(later-subproblem normal-reduction-number))
(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))
(set-current-subproblem! (car previous-subproblems)
(cdr previous-subproblems)
select-reduction-number)
- (print-current-expression))))
+ (print-current-reduction))))
\f
;;;; General motion command
(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)))))))))
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))
\f
-;;;; 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))
+\f
+;;;; Error info
(define (error-info-command)
(let ((message (error-message))
(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)
(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)))))))
\f
;;;; Utilities
(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
#| -*-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
(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)))
#| -*-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
(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
(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)
(define-integrable (dbg-procedure<? x y)
(< (dbg-procedure/label-offset x) (dbg-procedure/label-offset y)))
-
+\f
(define-structure (dbg-continuation
(named
(string->symbol
(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)
(define-integrable (dbg-continuation<? x y)
(< (dbg-continuation/label-offset x) (dbg-continuation/label-offset y)))
-\f
+
(define-structure (dbg-block
(named
(string->symbol "#[(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)
#| -*-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
((< key* key) (loop (1+ midpoint) end))
(else item))))))))\f
(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
(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))))))))
-\f
-(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-name<? x y)
- (let ((name->string
- (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-ci<? (name->string 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?*)))
(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
#| -*-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
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
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)
output-to-string
print-user-friendly-name
show-environment-bindings
+ show-environment-name
show-frame
show-frames
write-dbg-name)
(parent ())
(export ()
environment-arguments
+ environment-bindings
environment-bound-names
environment-bound?
environment-has-parent?
+ environment-lambda
environment-lookup
environment-parent
environment-procedure-name
(export (runtime advice)
ic-environment/arguments
ic-environment/procedure)
- (export (runtime debugger)
- ic-environment/procedure)
(export (runtime debugging-info)
stack-frame/environment))
(export (runtime pretty-printer)
unparse-list/unparser
unparse-vector/unparser)
+ (export (runtime debugger)
+ *unparse-primitives-by-name?*)
(initialization (initialize-package!)))
(define-package (runtime unsyntaxer)
#| -*-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
((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)))
\f
(define (environment-arguments environment)
(cond ((ic-environment? environment)
(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)
(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)))
lookup
required)))))
+(define (ic-environment/lambda environment)
+ (procedure-lambda (ic-environment/procedure environment)))
+
(define (ic-environment/procedure environment)
(select-procedure (ic-environment->external environment)))
#| -*-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
(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*)
((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)))))))
(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)))
(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?
#| -*-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
'()))
(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)
#| -*-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
(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)))
(if (and (car x) (> length 4))
(substring-move-right! " ..." 0 4 (cdr x) (- length 4)))
(cdr x)))
-\f
+
+(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?))))
+\f
+(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)))
#| -*-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
(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)))
#| -*-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
(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
(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)
(define-integrable (dbg-procedure<? x y)
(< (dbg-procedure/label-offset x) (dbg-procedure/label-offset y)))
-
+\f
(define-structure (dbg-continuation
(named
(string->symbol
(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)
(define-integrable (dbg-continuation<? x y)
(< (dbg-continuation/label-offset x) (dbg-continuation/label-offset y)))
-\f
+
(define-structure (dbg-block
(named
(string->symbol "#[(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)
#| -*-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
((< key* key) (loop (1+ midpoint) end))
(else item))))))))\f
(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
(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))))))))
-\f
-(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-name<? x y)
- (let ((name->string
- (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-ci<? (name->string 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?*)))
(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
#| -*-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
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
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)
output-to-string
print-user-friendly-name
show-environment-bindings
+ show-environment-name
show-frame
show-frames
write-dbg-name)
(parent ())
(export ()
environment-arguments
+ environment-bindings
environment-bound-names
environment-bound?
environment-has-parent?
+ environment-lambda
environment-lookup
environment-parent
environment-procedure-name
(export (runtime advice)
ic-environment/arguments
ic-environment/procedure)
- (export (runtime debugger)
- ic-environment/procedure)
(export (runtime debugging-info)
stack-frame/environment))
(export (runtime pretty-printer)
unparse-list/unparser
unparse-vector/unparser)
+ (export (runtime debugger)
+ *unparse-primitives-by-name?*)
(initialization (initialize-package!)))
(define-package (runtime unsyntaxer)
#| -*-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
((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)))
\f
(define (environment-arguments environment)
(cond ((ic-environment? environment)
(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)
(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)))
lookup
required)))))
+(define (ic-environment/lambda environment)
+ (procedure-lambda (ic-environment/procedure environment)))
+
(define (ic-environment/procedure environment)
(select-procedure (ic-environment->external environment)))
projects / mit-scheme.git / commitdiff