anything but an compound procedure.
* Continuation parser keeps track of the type of the previous stack
frame. This information is used as context in some situations.
This mechanism replaces special-purpose flag `allow-next-extended?'.
* Continuation parser slightly reorganized and commented to make it
easier to understand.
* Debugger modified to provide more flexible control over use of
history information, to provide more detailed information about
stack frames, and to make it more self-explanatory. Also knows
about "simulated" compiled-code environment frames, and ignores
them.
* The environment inspector has been modified to make it more
self-explanatory. The N command has been replaced by an O command
like that of the debugger.
* `pretty-print' now has additional optional argument that specifies
an indentation for the printed expression. If given, the output is
indented by that many columns.
* The emacs interface now has a hook for evaluating arbitrary
emacs-lisp expressions. This is used to provide a better debugger
interface.
**** This requires "xscheme.el" version 1.26 or later. ****
* `stack-frame/debugging-info' now returns a third value,
"subexpression", which indicates the subexpression of the expression
that the next later subproblem is evaluating.
* The lambda abstraction now forces the use of internal lambda
expressions for auxiliary variables. This is required for correct
semantics of `letrec'.
* `make-lambda' now does error-checking on its parameter-list
arguments, which disallows duplicates in the parameter lists.
* The `procedure' abstraction has been split off into a separate file.
`procedure-arity' has been modified to handle entities correctly.
A new datatype, `apply-hook', is like entities except that it
doesn't pass itself to the handler. `compound-procedure' operations
have been removed from the global environment; use generic
operations instead.
* The unsyntaxer has a new entry point, `unsyntax-with-substitutions',
which allows subexpressions of an expression to be replaced in the
output with arbitrary objects.
* Removed `dynamic-state-let' from `system-global-syntax-table'.
* The syntaxer now disallows the use of syntactic keywords as
variables. This applies to references, bindings, and definitions.
* The syntaxer signals an error if the name of a named `let' is also
one of its bound variables.
* The syntaxer signals an error if there are duplicates in the
parameters of a lambda expression.
* Compiled-code environments that do not have interpreter-compatible
ancestors now simulate such ancestors for debugging convenience.
The simulated ancestor is the closing environment of the compiled
code, if known, otherwise it is the system global environment.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 14.6 1990/09/07 00:46:02 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 14.7 1990/09/11 20:43:35 cph Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
;;;; Top Level Wrappers
(define (find-internal-lambda procedure path)
- (define (find-lambda *lambda path)
- (define (loop elements)
- (cond ((null? elements)
- (error "Couldn't find internal definition" path))
- ((assignment? (car elements))
- (assignment-components (car elements)
- (lambda (name value)
- (if (eq? name (car path))
- (if (lambda? value)
- (find-lambda value (cdr path))
- (error "Internal definition not a procedure" path))
- (loop (cdr elements))))))
- (else
- (loop (cdr elements)))))
-
- (if (null? path)
- *lambda
- (lambda-components *lambda
- (lambda (name required optional rest auxiliary declarations body)
- name required optional rest declarations
- (if (memq (car path) auxiliary)
- (loop (sequence-actions body))
- (error "No internal definition by this name" (car path)))))))
-
+ (if (not (compound-procedure? procedure))
+ (error "only compound procedures may be advised" procedure))
(if (null? path)
(procedure-lambda procedure)
- (find-lambda (procedure-lambda procedure) (car path))))
+ (let find-lambda
+ ((*lambda (procedure-lambda procedure))
+ (path (car path)))
+ (if (null? path)
+ *lambda
+ (let loop
+ ((elements
+ (lambda-components *lambda
+ (lambda (name required optional rest auxiliary declarations
+ body)
+ name required optional rest declarations
+ (if (not (memq (car path) auxiliary))
+ (error "no internal definition by this name"
+ (car path)))
+ (sequence-actions body)))))
+ (if (null? elements)
+ (error "Couldn't find internal definition" path))
+ (if (assignment? (car elements))
+ (assignment-components (car elements)
+ (lambda (name value)
+ (if (eq? name (car path))
+ (begin
+ (if (not (lambda? value))
+ (error "internal definition not a procedure"
+ path))
+ (find-lambda value (cdr path)))
+ (loop (cdr elements)))))
+ (loop (cdr elements))))))))
;; The LIST-COPY will prevent any mutation problems.
(define ((wrap-advice-extractor extractor) procedure . path)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.18 1990/08/25 03:08:22 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.19 1990/09/11 20:43:44 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
interrupt-mask history
previous-history-offset
previous-history-control-point
- offset %next))
+ offset previous-type %next))
(conc-name stack-frame/))
(type false read-only true)
(elements false read-only true)
(previous-history-offset false read-only true)
(previous-history-control-point false read-only true)
(offset false read-only true)
+ ;; PREVIOUS-TYPE is the stack-frame-type of the frame above this one
+ ;; on the stack (closer to the stack's top). In at least two cases
+ ;; we need to know this information.
+ (previous-type false read-only true)
;; %NEXT is either a parser-state object or the next frame. In the
;; former case, the parser-state is used to compute the next frame.
%next
(define (stack-frame/next stack-frame)
(let ((next (stack-frame/%next stack-frame)))
(if (parser-state? next)
- (let ((next (parse/start next)))
+ (let ((next (parse-one-frame next)))
(set-stack-frame/%next! stack-frame next)
next)
next)))
(element-stream false read-only true)
(n-elements false read-only true)
(next-control-point false read-only true)
- (allow-next-extended? false read-only true))
+ (previous-type false read-only true))
(define (continuation->stack-frame continuation)
- (parse/control-point (continuation/control-point continuation)
+ (parse-control-point (continuation/control-point continuation)
(continuation/dynamic-state continuation)
- (continuation/fluid-bindings continuation)))
-
-(define (parse/control-point control-point dynamic-state fluid-bindings)
- (and control-point
- (parse/start
- (make-parser-state
- dynamic-state
- fluid-bindings
- (control-point/interrupt-mask control-point)
- (history-transform (control-point/history control-point))
- (control-point/previous-history-offset control-point)
- (control-point/previous-history-control-point control-point)
- (control-point/element-stream control-point)
- (control-point/n-elements control-point)
- (control-point/next-control-point control-point)
- false))))
-
-(define (parse/start state)
+ (continuation/fluid-bindings continuation)
+ false))
+
+(define (parse-control-point control-point dynamic-state fluid-bindings type)
+ (parse-one-frame
+ (make-parser-state
+ dynamic-state
+ fluid-bindings
+ (control-point/interrupt-mask control-point)
+ (history-transform (control-point/history control-point))
+ (control-point/previous-history-offset control-point)
+ (control-point/previous-history-control-point control-point)
+ (control-point/element-stream control-point)
+ (control-point/n-elements control-point)
+ (control-point/next-control-point control-point)
+ type)))
+
+(define (parse-one-frame state)
(let ((stream (parser-state/element-stream state)))
(if (stream-pair? stream)
(let ((type
(return-address->stack-frame-type
(element-stream/head stream)
- (parser-state/allow-next-extended? state))))
+ (let ((type (parser-state/previous-type state)))
+ (and type
+ (1d-table/get (stack-frame-type/properties type)
+ allow-extended?-tag
+ false))))))
(let ((length
(let ((length (stack-frame-type/length type)))
(if (exact-nonnegative-integer? length)
((stack-frame-type/parser type)
type
(list->vector (stream-head stream length))
- (parse/next-state state length (stream-tail stream length)
- (stack-frame-type/allow-extended? type)))))
- (parse/control-point (parser-state/next-control-point state)
- (parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)))))
+ (make-intermediate-state state
+ length
+ (stream-tail stream length)))))
+ (let ((control-point (parser-state/next-control-point state)))
+ (and control-point
+ (parse-control-point control-point
+ (parser-state/dynamic-state state)
+ (parser-state/fluid-bindings state)
+ (parser-state/previous-type state)))))))
\f
-(define (parse/next-state state length stream allow-extended?)
+;;; `make-intermediate-state' is used to construct an intermediate
+;;; parser state that is passed to the frame parser. This
+;;; intermediate state is identical to `state' except that it shows
+;;; `length' items having been removed from the stream.
+
+(define (make-intermediate-state state length stream)
(let ((previous-history-control-point
(parser-state/previous-history-control-point state)))
(make-parser-state
(parser-state/history state)
(if previous-history-control-point
(parser-state/previous-history-offset state)
- (max (- (parser-state/previous-history-offset state) (-1+ length))
- 0))
+ (max 0 (- (parser-state/previous-history-offset state) (-1+ length))))
previous-history-control-point
stream
(- (parser-state/n-elements state) length)
(parser-state/next-control-point state)
- allow-extended?)))
-
-(define (make-frame type elements state element-stream n-elements)
- (let ((history-subproblem?
+ (parser-state/previous-type state))))
+
+;;; After each frame parser is done, it either tail recurses into the
+;;; parsing loop, or it calls `parser/standard' to produces a new
+;;; output frame. The argument `state' is usually what was passed to
+;;; the frame parser (i.e. the state that was returned by the previous
+;;; call to `make-intermediate-state'). However, several of the
+;;; parsers change the values of some of the components of `state'
+;;; before calling `parser/standard' -- for example,
+;;; RESTORE-TO-STATE-POINT changes the `dynamic-state' component.
+
+(define (parser/standard type elements state)
+ (let ((n-elements (parser-state/n-elements state))
+ (history-subproblem?
(stack-frame-type/history-subproblem? type))
(history (parser-state/history state))
(previous-history-offset (parser-state/previous-history-offset state))
(previous-history-control-point
(parser-state/previous-history-control-point state)))
- (make-stack-frame type
- elements
- (parser-state/dynamic-state state)
+ (make-stack-frame
+ type
+ elements
+ (parser-state/dynamic-state state)
+ (parser-state/fluid-bindings state)
+ (parser-state/interrupt-mask state)
+ (if (and history-subproblem? (stack-frame-type/subproblem? type))
+ history
+ undefined-history)
+ previous-history-offset
+ previous-history-control-point
+ (+ (vector-length elements) n-elements)
+ (parser-state/previous-type state)
+ (make-parser-state (parser-state/dynamic-state state)
+ (parser-state/fluid-bindings state)
+ (parser-state/interrupt-mask state)
+ (if history-subproblem?
+ (history-superproblem history)
+ history)
+ previous-history-offset
+ previous-history-control-point
+ (parser-state/element-stream state)
+ n-elements
+ (parser-state/next-control-point state)
+ type))))
+\f
+(define (parser/restore-dynamic-state type elements state)
+ ;; Possible problem: the dynamic state really consists of all of the
+ ;; state spaces in existence. Probably we should have some
+ ;; mechanism for keeping track of them all.
+ (parser/standard
+ type
+ elements
+ (make-parser-state (let ((dynamic-state (vector-ref elements 1)))
+ (if (eq? system-state-space
+ (state-point/space dynamic-state))
+ dynamic-state
+ (parser-state/dynamic-state state)))
(parser-state/fluid-bindings state)
(parser-state/interrupt-mask state)
- (if (and history-subproblem?
- (stack-frame-type/subproblem? type))
- history
- undefined-history)
- previous-history-offset
- previous-history-control-point
- (+ (vector-length elements) n-elements)
- (make-parser-state
- (parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
- (parser-state/interrupt-mask state)
- (if history-subproblem?
- (history-superproblem history)
- history)
- previous-history-offset
- previous-history-control-point
- element-stream
- n-elements
- (parser-state/next-control-point state)
- (stack-frame-type/allow-extended? type)))))
+ (parser-state/history state)
+ (parser-state/previous-history-offset state)
+ (parser-state/previous-history-control-point state)
+ (parser-state/element-stream state)
+ (parser-state/n-elements state)
+ (parser-state/next-control-point state)
+ (parser-state/previous-type state))))
-(define (element-stream/head stream)
- (if (not (stream-pair? stream)) (error "not a stream-pair" stream))
- (map-reference-trap (lambda () (stream-car stream))))
+(define (parser/restore-fluid-bindings type elements state)
+ (parser/standard
+ type
+ elements
+ (make-parser-state (parser-state/dynamic-state state)
+ (vector-ref elements 1)
+ (parser-state/interrupt-mask state)
+ (parser-state/history state)
+ (parser-state/previous-history-offset state)
+ (parser-state/previous-history-control-point state)
+ (parser-state/element-stream state)
+ (parser-state/n-elements state)
+ (parser-state/next-control-point state)
+ (parser-state/previous-type state))))
-(define-integrable (element-stream/ref stream index)
- (map-reference-trap (lambda () (stream-ref stream index))))
+(define (parser/restore-interrupt-mask type elements state)
+ (parser/standard
+ type
+ elements
+ (make-parser-state (parser-state/dynamic-state state)
+ (parser-state/fluid-bindingU state)
+ (vector-ref elements 1)
+ (parser-state/history state)
+ (parser-state/previous-history-offset state)
+ (parser-state/previous-history-control-point state)
+ (parser-state/element-stream state)
+ (parser-state/n-elements state)
+ (parser-state/next-control-point state)
+ (parser-state/previous-type state))))
+
+(define (parser/restore-history type elements state)
+ (parser/standard
+ type
+ elements
+ (make-parser-state (parser-state/dynamic-state state)
+ (parser-state/fluid-bindings state)
+ (parser-state/interrupt-mask state)
+ (history-transform (vector-ref elements 1))
+ (vector-ref elements 2)
+ (vector-ref elements 3)
+ (parser-state/element-stream state)
+ (parser-state/n-elements state)
+ (parser-state/next-control-point state)
+ (parser-state/previous-type state))))
\f
;;;; Unparser
(define (verify paranoia-index stream offset)
(or (zero? paranoia-index)
(stream-null? stream)
- (let* ((type (return-address->stack-frame-type
- (element-stream/head stream)
- false))
+ (let* ((type
+ (return-address->stack-frame-type (element-stream/head stream)
+ false))
(length
(let ((length (stack-frame-type/length type)))
(if (exact-nonnegative-integer? length)
((stream-pair? stream)
(stream-tail* (stream-cdr stream) (-1+ n)))
(else
- (error "stream-tail*: not a proper stream" stream))))
-\f
-;;;; Parsers
-
-(define (parser/standard-next type elements state)
- (make-frame type
- elements
- state
- (parser-state/element-stream state)
- (parser-state/n-elements state)))
-
-(define (make-restore-frame type
- elements
- state
- dynamic-state
- fluid-bindings
- interrupt-mask
- history
- previous-history-offset
- previous-history-control-point)
- (parser/standard-next
- type
- elements
- (make-parser-state dynamic-state
- fluid-bindings
- interrupt-mask
- history
- previous-history-offset
- previous-history-control-point
- (parser-state/element-stream state)
- (parser-state/n-elements state)
- (parser-state/next-control-point state)
- false)))
-\f
-(define (parser/restore-dynamic-state type elements state)
- (make-restore-frame type elements state
- ;; Possible problem: the dynamic state really
- ;; consists of all of the state spaces in
- ;; existence. Probably we should have some
- ;; mechanism for keeping track of them all.
- (let ((dynamic-state (vector-ref elements 1)))
- (if (eq? system-state-space
- (state-point/space dynamic-state))
- dynamic-state
- (parser-state/dynamic-state state)))
- (parser-state/fluid-bindings state)
- (parser-state/interrupt-mask state)
- (parser-state/history state)
- (parser-state/previous-history-offset state)
- (parser-state/previous-history-control-point state)))
+ (error "stream-tail*: not a proper stream" stream))))
-(define (parser/restore-fluid-bindings type elements state)
- (make-restore-frame type elements state
- (parser-state/dynamic-state state)
- (vector-ref elements 1)
- (parser-state/interrupt-mask state)
- (parser-state/history state)
- (parser-state/previous-history-offset state)
- (parser-state/previous-history-control-point state)))
-
-(define (parser/restore-interrupt-mask type elements state)
- (make-restore-frame type elements state
- (parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
- (vector-ref elements 1)
- (parser-state/history state)
- (parser-state/previous-history-offset state)
- (parser-state/previous-history-control-point state)))
+(define (element-stream/head stream)
+ (if (not (stream-pair? stream)) (error "not a stream-pair" stream))
+ (map-reference-trap (lambda () (stream-car stream))))
-(define (parser/restore-history type elements state)
- (make-restore-frame type elements state
- (parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
- (parser-state/interrupt-mask state)
- (history-transform (vector-ref elements 1))
- (vector-ref elements 2)
- (vector-ref elements 3)))
+(define-integrable (element-stream/ref stream index)
+ (map-reference-trap (lambda () (stream-ref stream index))))
\f
;;;; Stack Frame Types
(define-structure (stack-frame-type
(constructor make-stack-frame-type
- (code subproblem?
- history-subproblem?
+ (code subproblem? history-subproblem?
length parser))
(conc-name stack-frame-type/))
(code false read-only true)
(length false read-only true)
(parser false read-only true))
-(define allow-extended-return-addresses?-tag
- "stack-frame-type/allow-extended")
-
-(define (stack-frame-type/allow-extended? type)
- (1d-table/get
- (stack-frame-type/properties type)
- allow-extended-return-addresses?-tag
- false))
+(define allow-extended?-tag "stack-frame-type/allow-extended?")
(define (microcode-return/code->type code)
(if (not (< code (vector-length stack-frame-types)))
(error "return-code too large" code))
(vector-ref stack-frame-types code))
+(define (microcode-return/name->type name)
+ (microcode-return/code->type (microcode-return name)))
+
(define (return-address->stack-frame-type return-address allow-extended?)
(cond ((interpreter-return-address? return-address)
(let ((code (return-address/code return-address)))
(error "return-code has no type" code))
type)))
((compiled-return-address? return-address)
- (if (compiled-continuation/return-to-interpreter?
- return-address)
+ (if (compiled-continuation/return-to-interpreter? return-address)
stack-frame-type/return-to-interpreter
stack-frame-type/compiled-return-address))
((and allow-extended? (compiled-procedure? return-address))
(make-return-address (microcode-return 'REENTER-COMPILED-CODE)))
(set! stack-frame-types (make-stack-frame-types))
(set! stack-frame-type/hardware-trap
- (vector-ref stack-frame-types (microcode-return 'HARDWARE-TRAP)))
+ (microcode-return/name->type 'HARDWARE-TRAP))
(set! stack-frame-type/compiled-return-address
- (make-stack-frame-type false
- true
- false
+ (make-stack-frame-type false true false
length/compiled-return-address
- parser/standard-next))
+ parser/standard))
(set! stack-frame-type/return-to-interpreter
- (make-stack-frame-type false
- false
- true
+ (make-stack-frame-type false false true
1
- parser/standard-next))
+ parser/standard))
(set! stack-frame-type/interrupt-compiled-procedure
- (make-stack-frame-type false
- true
- false
+ (make-stack-frame-type false true false
length/interrupt-compiled-procedure
- parser/standard-next))
+ parser/standard))
(set! stack-frame-type/interrupt-compiled-expression
- (make-stack-frame-type false
- true
- false
+ (make-stack-frame-type false true false
1
- parser/standard-next))
+ parser/standard))
(set! word-size
(let ((initial (system-vector-length (make-bit-string 1 #f))))
(let loop ((size 2))
- (if (= (system-vector-length (make-bit-string size #f))
- initial)
+ (if (= (system-vector-length (make-bit-string size #f)) initial)
(loop (1+ size))
(-1+ size)))))
unspecific)
false
length
(if (default-object? parser)
- parser/standard-next
+ parser/standard
parser)))
(define (standard-subproblem name length)
true
true
length
- parser/standard-next))
+ parser/standard))
(standard-frame 'RESTORE-TO-STATE-POINT 2 parser/restore-dynamic-state)
(standard-frame 'RESTORE-FLUIDS 2 parser/restore-fluid-bindings)
(standard-subproblem 'COMBINATION-APPLY length)
(standard-subproblem 'INTERNAL-APPLY length)
(standard-subproblem 'INTERNAL-APPLY-VAL length))
-\f
+
(let ((compiler-frame
(lambda (name length)
- (stack-frame-type name false true length parser/standard-next)))
+ (stack-frame-type name false true length parser/standard)))
(compiler-subproblem
(lambda (name length)
- (stack-frame-type name true true length parser/standard-next))))
+ (stack-frame-type name true true length parser/standard))))
(let ((length (length/application-frame 4 0)))
(compiler-subproblem 'COMPILER-LOOKUP-APPLY-TRAP-RESTART length)
(compiler-subproblem 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART length))
- (let ((type
- (compiler-frame 'COMPILER-INTERRUPT-RESTART 3)))
+ (let ((type (compiler-frame 'COMPILER-INTERRUPT-RESTART 3)))
(1d-table/put! (stack-frame-type/properties type)
- allow-extended-return-addresses?-tag
+ allow-extended?-tag
true))
(compiler-frame 'COMPILER-LINK-CACHES-RESTART 8)
true
false
length/hardware-trap
- parser/standard-next)
+ parser/standard)
types))
\f
(arity (primitive-procedure-arity primitive))
(nargs
(if (negative? arity)
- (element-stream/ref stream hardware-trap/pc-info2-index)
+ (element-stream/ref stream
+ hardware-trap/pc-info2-index)
arity)))
(if (return-address? (element-stream/ref after-header nargs))
(+ hardware-trap/frame-size nargs)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.7 1990/06/20 20:28:51 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.8 1990/09/11 20:43:52 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(define (default/leaving-command-loop thunk)
(input-port/normal-mode (cmdl/input-port (nearest-cmdl)) thunk))
-(define (debug/read-eval-print environment message prompt)
+(define (debug/read-eval-print environment from to prompt)
(leaving-command-loop
(lambda ()
- (read-eval-print environment (cmdl-message/standard message) prompt))))
+ (read-eval-print
+ environment
+ (cmdl-message/standard
+ (string-append
+ "You are now in " to ". Type C-c C-u to return to " from "."))
+ prompt))))
(define (debug/eval expression environment)
(leaving-command-loop (lambda () (eval expression environment))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgutl.scm,v 14.9 1990/02/20 16:15:16 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgutl.scm,v 14.10 1990/09/11 20:43:59 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(begin (write-string "a ")
(write-string rename)
(write-string " special form"))
- (begin (write-string "the procedure ")
+ (begin (write-string "the procedure: ")
(write-dbg-name name))))
(write-string "an unknown procedure"))))
+(define (show-environment-procedure environment)
+ (let ((scode-lambda (environment-lambda environment)))
+ (if scode-lambda
+ (presentation (lambda () (pretty-print scode-lambda)))
+ (debugger-failure "No procedure for this environment."))))
+
(define (write-dbg-name name)
(if (string? name) (write-string name) (write name)))
(debug/eval (prompt-for-expression "Evaluate expression")
environment)))
(if (undefined-value? value)
- (debugger-message "\n" ";No value")
- (debugger-message "\n" "Value: " value))))
+ (debugger-message "No value")
+ (debugger-message "Value: " value))))
(define (output-to-string length thunk)
(let ((x (with-output-to-truncated-string length thunk)))
(let loop ((environment environment) (depth depth))
(write-string "----------------------------------------")
(show-frame environment depth true)
- (if (environment-has-parent? environment)
+ (if (eq? true (environment-has-parent? environment))
(begin
(newline)
(newline)
(let ((package (environment->package environment)))
(if package
(begin
- (write-string "named ")
+ (write-string "named: ")
(write (package/name package)))
(begin
(write-string "created by ")
(environment-lookup environment name)))
names))))
(cond ((zero? n-bindings)
- (write-string "Has no bindings"))
+ (write-string " has no bindings"))
((and brief? (> n-bindings brief-bindings-limit))
- (write-string "Has ")
+ (write-string " has ")
(write n-bindings)
(write-string " bindings (first ")
(write brief-bindings-limit)
(write-string " shown):")
(finish (list-head names brief-bindings-limit)))
(else
- (write-string "Has bindings:")
+ (write-string " has bindings:")
(finish names))))))
(define brief-bindings-limit
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.18 1990/08/21 04:18:33 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.19 1990/09/11 20:44:13 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
-(define student-walk? false)
-(define print-return-values? false)
+(define debugger:student-walk? false)
+(define debugger:print-return-values? false)
+(define debugger:auto-toggle? true)
+(define debugger:count-subproblems-limit 50)
+(define debugger:use-history? false)
(define (debug #!optional object)
(let ((dstate
(or (error-continuation)
(current-proceed-continuation))
object))))
- (letter-commands command-set
- (cmdl-message/append
- (cmdl-message/active
- (lambda ()
- (command/print-reduction dstate)))
- (cmdl-message/standard "Debugger"))
- "Debug-->"
- dstate)))
+ (letter-commands
+ command-set
+ (cmdl-message/active
+ (lambda ()
+ (presentation
+ (lambda ()
+ (let ((n (count-subproblems dstate)))
+ (write-string "There ")
+ (write-string (if (= n 1) "is" "are"))
+ (write-string " ")
+ (if (> n debugger:count-subproblems-limit)
+ (write-string "more than "))
+ (write n)
+ (write-string " subproblem")
+ (if (not (= n 1))
+ (write-string "s")))
+ (write-string " on the stack.")
+ (newline)
+ (newline)
+ (print-subproblem dstate)))
+ (debugger-message
+ "You are now in the debugger. Type q to quit, ? for commands.")))
+ "Debug-->"
+ dstate)))
(define (make-initial-dstate object)
(let ((dstate (allocate-dstate)))
- (set-current-subproblem!
+ (set-dstate/history-state!
dstate
- (or (coerce-to-stack-frame object)
+ (cond (debugger:use-history? 'ALWAYS)
+ (debugger:auto-toggle? 'ENABLED)
+ (else 'DISABLED)))
+ (let ((stack-frame (coerce-to-stack-frame object)))
+ (if (not stack-frame)
(error "DEBUG: null continuation" object))
- '()
- first-reduction-number)
+ (set-current-subproblem! dstate stack-frame '()))
dstate))
(define (coerce-to-stack-frame object)
(else
(error "DEBUG: illegal argument" object))))
+(define (count-subproblems dstate)
+ (do ((i 0 (1+ i))
+ (subproblem (dstate/subproblem dstate)
+ (stack-frame/next-subproblem subproblem)))
+ ((or (not subproblem) (> i debugger:count-subproblems-limit)) i)))
+
(define-structure (dstate
(conc-name dstate/)
(constructor allocate-dstate ()))
subproblem
previous-subproblems
subproblem-number
- reduction-number
- reductions
number-of-reductions
- reduction
+ reduction-number
+ history-state
expression
+ subexpression
environment-list)
+
+(define (dstate/reduction dstate)
+ (nth-reduction (dstate/reductions dstate)
+ (dstate/reduction-number dstate)))
+
+(define (dstate/reductions dstate)
+ (stack-frame/reductions (dstate/subproblem dstate)))
\f
(define (initialize-package!)
(set!
(make-command-set
'DEBUG-COMMANDS
`((#\? ,standard-help-command
- "Help, list command letters")
+ "help, list command letters")
(#\A ,command/show-all-frames
- "Show bindings in current environment and its ancestors")
+ "show All bindings in current environment and its ancestors")
(#\B ,command/earlier-reduction
- "Earlier reduction (Back in time)")
+ "move (Back) to next reduction (earlier in time)")
(#\C ,command/show-current-frame
- "Show bindings of identifiers in the current environment")
+ "show bindings of identifiers in the Current environment")
(#\D ,command/later-subproblem
- "Move (Down) to the next (later) subproblem")
+ "move (Down) to the previous subproblem (later in time)")
(#\E ,command/enter-read-eval-print-loop
"Enter a read-eval-print loop in the current environment")
(#\F ,command/later-reduction
- "Later reduction (Forward in time)")
+ "move (Forward) to previous reduction (later in time)")
(#\G ,command/goto
- "Go to a particular Subproblem/Reduction level")
- (#\H ,command/summarize-history
- "Prints a summary of the entire history")
+ "Go to a particular subproblem")
+ (#\H ,command/summarize-subproblems
+ "prints a summary (History) of all subproblems")
(#\I ,command/error-info
- "Redisplay the error message")
+ "redisplay the error message Info")
(#\L ,command/print-expression
- "(list expression) Pretty-print the current expression")
+ "(List expression) pretty print the current expression")
(#\O ,command/print-environment-procedure
- "Pretty print the procedure that created the current environment")
+ "pretty print the procedure that created the current environment")
(#\P ,command/move-to-parent-environment
- "Move to environment which is parent of current environment")
+ "move to environment that is Parent of current environment")
(#\Q ,standard-exit-command
- "Quit (exit DEBUG)")
+ "Quit (exit debugger)")
(#\R ,command/print-reductions
- "Print the reductions of the current subproblem level")
+ "print the execution history (Reductions) of the current subproblem level")
(#\S ,command/move-to-child-environment
- "Move to child of current environment (in current chain)")
- (#\T ,command/print-reduction
- "Print the current subproblem/reduction")
+ "move to child of current environment (in current chain)")
+ (#\T ,command/print-subproblem-or-reduction
+ "print the current subproblem or reduction")
(#\U ,command/earlier-subproblem
- "Move (Up) to the previous (earlier) subproblem")
+ "move (Up) to the next subproblem (earlier in time)")
(#\V ,command/eval-in-current-environment
- "Evaluate expression in current environment")
+ "eValuate expression in current environment")
(#\W ,command/enter-where
- "Enter WHERE on the current environment")
+ "enter environment inspector (Where) on the current environment")
(#\X ,command/internal
- "Create a read eval print loop in the debugger environment")
+ "create a read eval print loop in the debugger environment")
(#\Y ,command/frame
- "Display the current stack frame")
+ "display the current stack frame")
(#\Z ,command/return
- "Return (continue with) an expression after evaluating it")
+ "return (continue with) an expression after evaluating it")
)))
unspecific)
(define command-set)
\f
-(define (command/print-reduction dstate)
- (presentation
- (lambda ()
- (write-string "Subproblem level: ")
- (write (dstate/subproblem-number dstate))
- (let ((expression (dstate/expression dstate)))
- (if (dstate/reduction dstate)
- (begin
- (write-string " Reduction number: ")
- (write (dstate/reduction-number dstate))
+(define (command/print-subproblem-or-reduction dstate)
+ (if (dstate/reduction-number dstate)
+ (command/print-reduction dstate)
+ (command/print-subproblem dstate)))
+
+(define (command/print-subproblem dstate)
+ (presentation (lambda () (print-subproblem dstate))))
+
+(define (print-subproblem dstate)
+ (let ((subproblem (dstate/subproblem dstate)))
+ (write-string "Subproblem level: ")
+ (let ((level (dstate/subproblem-number dstate))
+ (qualify-level
+ (lambda (adjective)
+ (write-string " (this is the ")
+ (write-string adjective)
+ (write-string " subproblem level)"))))
+ (write level)
+ (cond ((not (stack-frame/next-subproblem subproblem))
+ (qualify-level (if (zero? level) "only" "highest")))
+ ((zero? level)
+ (qualify-level "lowest"))))
+ (newline)
+ (let ((expression (dstate/expression dstate)))
+ (cond ((not (invalid-expression? expression))
+ (write-string
+ (if (stack-frame/compiled-code? subproblem)
+ "Compiled code expression (from stack):"
+ "Expression (from stack):"))
(newline)
- (write-string "Expression (from execution history):")
+ (let ((subexpression (dstate/subexpression dstate)))
+ (if (or (debugging-info/undefined-expression? subexpression)
+ (debugging-info/undefined-expression? subexpression))
+ (debugger-pp expression expression-indentation)
+ (begin
+ (debugger-pp
+ (unsyntax-with-substitutions
+ expression
+ (list (cons subexpression subexpression-marker)))
+ expression-indentation)
+ (newline)
+ (write-string " subproblem being executed (marked by ")
+ (write subexpression-marker)
+ (write-string "):")
+ (newline)
+ (debugger-pp subexpression expression-indentation)))))
+ ((or (not (debugging-info/undefined-expression? expression))
+ (not (debugging-info/noise? expression)))
+ (write-string
+ (if (stack-frame/compiled-code? subproblem)
+ "Compiled code expression unknown"
+ "Expression unknown"))
(newline)
- (pretty-print expression))
- (let ((subproblem (dstate/subproblem dstate)))
+ (write (stack-frame/return-address subproblem)))
+ (else
+ (write-string ((debugging-info/noise expression) true)))))
+ (let ((environment-list (dstate/environment-list dstate)))
+ (if (pair? environment-list)
+ (print-environment (car environment-list))
+ (begin
+ (newline)
+ (write-string "There is no current environment."))))
+ (let ((n-reductions (dstate/number-of-reductions dstate)))
+ (newline)
+ (if (positive? n-reductions)
+ (begin
+ (write-string
+ "The execution history for this subproblem contains ")
+ (write n-reductions)
+ (write-string " reduction")
+ (if (> n-reductions 1)
+ (write-string "s"))
+ (write-string "."))
+ (write-string
+ "There is no execution history for this subproblem.")))))
+
+(define subexpression-marker (string->symbol "#SUBPROBLEM#"))
+\f
+(define (command/print-reductions dstate)
+ (let ((reductions (dstate/reductions dstate))
+ (subproblem-level (dstate/subproblem-number dstate)))
+ (if (pair? reductions)
+ (presentation
+ (lambda ()
+ (write-string "Execution history for this subproblem:")
+ (let loop ((reductions reductions) (number 0))
(newline)
- (cond ((not (invalid-expression? expression))
- (write-string
- (if (stack-frame/compiled-code? subproblem)
- "Compiled code expression (from stack):"
- "Expression (from stack):"))
- (newline)
- (pretty-print expression))
- ((or (not (debugging-info/undefined-expression? expression))
- (not (debugging-info/noise? expression)))
- (write-string
- (if (stack-frame/compiled-code? subproblem)
- "Compiled code expression unknown"
- "Expression unknown")))
- (else
- (write-string
- ((debugging-info/noise expression) true)))))))
- (let ((environment-list (dstate/environment-list dstate)))
- (if (pair? environment-list)
- (let ((environment (car environment-list)))
- (show-environment-name environment)
- (if (not (environment->package environment))
- (begin
- (newline)
- (let ((arguments (environment-arguments environment)))
- (if (eq? arguments 'UNKNOWN)
- (show-environment-bindings environment true)
- (begin
- (write-string "applied to ")
- (write-string
- (cdr
- (write-to-string
- arguments
- (- (output-port/x-size (current-output-port))
- 11))))))))))
- (begin
+ (write-string "----------------------------------------")
(newline)
- (write-string "There is no current environment")))))))
-\f
+ (print-reduction (car reductions) subproblem-level number)
+ (if (pair? (cdr reductions))
+ (loop (cdr reductions) (1+ number))))))
+ (debugger-failure
+ "There is no execution history for this subproblem."))))
+
+(define (command/print-reduction dstate)
+ (presentation
+ (lambda ()
+ (print-reduction (dstate/reduction dstate)
+ (dstate/subproblem-number dstate)
+ (dstate/reduction-number dstate)))))
+
+(define (print-reduction reduction subproblem-level reduction-number)
+ (write-string "Subproblem level: ")
+ (write subproblem-level)
+ (write-string " Reduction number: ")
+ (write reduction-number)
+ (newline)
+ (write-string "Expression (from execution history):")
+ (newline)
+ (debugger-pp (reduction-expression reduction) expression-indentation)
+ (print-environment (reduction-environment reduction)))
+
+(define (print-environment environment)
+ (show-environment-name environment)
+ (if (not (environment->package environment))
+ (begin
+ (newline)
+ (let ((arguments (environment-arguments environment)))
+ (if (eq? arguments 'UNKNOWN)
+ (show-environment-bindings environment true)
+ (begin
+ (write-string " applied to: ")
+ (write-string
+ (cdr
+ (write-to-string
+ arguments
+ (- (output-port/x-size (current-output-port)) 11))))))))))
+
+(define (debugger-pp expression indentation)
+ (pretty-print expression (current-output-port) true indentation))
+
+(define expression-indentation 4)
+
(define (command/print-expression dstate)
(presentation
(lambda ()
(cond ((debugging-info/compiled-code? expression)
(write-string ";compiled code"))
((not (debugging-info/undefined-expression? expression))
- (pretty-print expression))
+ (debugger-pp expression 0))
((debugging-info/noise? expression)
(write-string ";")
(write-string ((debugging-info/noise expression) false)))
(write-string ";undefined expression")))))))
(define (command/print-environment-procedure dstate)
- (with-current-environment dstate
- (lambda (environment)
- (let ((scode-lambda (environment-lambda environment)))
- (if scode-lambda
- (presentation (lambda () (pretty-print scode-lambda)))
- (debugger-failure "No procedure for this environment"))))))
-
-(define (command/print-reductions dstate)
- (let ((reductions (dstate/reductions dstate)))
- (if (pair? reductions)
- (presentation
- (lambda ()
- (pretty-print (reduction-expression (car reductions)))
- (let loop ((reductions (cdr reductions)))
- (cond ((pair? reductions)
- (newline)
- (pretty-print (reduction-expression (car reductions)))
- (loop (cdr reductions)))
- ((eq? 'WRAP-AROUND reductions)
- (newline)
- (write-string
- "Wrap around in the reductions at this level"))))))
- (debugger-failure "No reductions at this level"))))
+ (with-current-environment dstate show-environment-procedure))
\f
-;;;; Short history display
+;;;; Short subproblem display
-(define (command/summarize-history dstate)
+(define (command/summarize-subproblems dstate)
(let ((top-subproblem
(let ((previous-subproblems (dstate/previous-subproblems dstate)))
(if (null? previous-subproblems)
(let loop ((frame top-subproblem) (level 0))
(if frame
(begin
- (let ((reductions (stack-frame/reductions frame)))
- (if (pair? reductions)
- (let ((print-reduction
- (lambda (reduction)
- (terse-print-expression
- level
- (reduction-expression reduction)
- (reduction-environment reduction)))))
- (print-reduction (car reductions))
- (if (= level 0)
- (let loop ((reductions (cdr reductions)))
- (if (pair? reductions)
- (begin
- (print-reduction (car reductions))
- (loop (cdr reductions)))))))
- (with-values
- (lambda () (stack-frame/debugging-info frame))
- (lambda (expression environment)
- (terse-print-expression level
- expression
- environment)))))
+ (with-values
+ (lambda () (stack-frame/debugging-info frame))
+ (lambda (expression environment subexpression)
+ subexpression
+ (terse-print-expression level
+ expression
+ environment)))
(loop (stack-frame/next-subproblem frame) (1+ level)))))))))
(define (terse-print-expression level expression environment)
(else
";undefined expression"))))
\f
-;;;; Subproblem/reduction motion
+;;;; Subproblem motion
(define (command/earlier-subproblem dstate)
- (if (stack-frame/next-subproblem (dstate/subproblem dstate))
- (let ((subproblem (dstate/subproblem dstate)))
- (move-to-subproblem! dstate
- (stack-frame/next-subproblem subproblem)
- (cons subproblem
- (dstate/previous-subproblems dstate))
- normal-reduction-number))
- (debugger-failure "There are only "
- (1+ (dstate/subproblem-number dstate))
- " subproblem levels; already at earliest level")))
-
-(define (command/earlier-reduction dstate)
- (let ((reduction-number (dstate/reduction-number dstate)))
- (cond ((and student-walk?
- (> (dstate/subproblem-number dstate) 0)
- (= reduction-number 0))
- (command/earlier-subproblem dstate))
- ((< reduction-number
- (-1+ (dstate/number-of-reductions dstate)))
- (move-to-reduction! dstate (1+ reduction-number)))
- (else
- (debugger-message
- (if (wrap-around-in-reductions? (dstate/reductions dstate))
- "Wrap around in"
- "No more")
- " reductions; going to the previous (earlier) subproblem")
- (command/earlier-subproblem dstate)))))
+ (maybe-stop-using-history! dstate)
+ (earlier-subproblem dstate false finish-move-to-subproblem!))
+
+(define (earlier-subproblem dstate reason if-successful)
+ (let ((subproblem (dstate/subproblem dstate)))
+ (let ((next (stack-frame/next-subproblem subproblem)))
+ (if next
+ (begin
+ (set-current-subproblem!
+ dstate
+ next
+ (cons subproblem (dstate/previous-subproblems dstate)))
+ (if-successful dstate))
+ (debugger-failure
+ (reason+message (or reason "no more subproblems")
+ "already at highest subproblem level."))))))
(define (command/later-subproblem dstate)
- (later-subproblem dstate normal-reduction-number))
+ (maybe-stop-using-history! dstate)
+ (later-subproblem dstate false finish-move-to-subproblem!))
-(define (command/later-reduction dstate)
- (if (positive? (dstate/reduction-number dstate))
- (move-to-reduction! dstate (-1+ (dstate/reduction-number dstate)))
- (later-subproblem dstate
- (if (or (not student-walk?)
- (= (dstate/subproblem-number dstate) 1))
- last-reduction-number
- normal-reduction-number))))
-
-(define (later-subproblem dstate select-reduction-number)
+(define (later-subproblem dstate reason if-successful)
(if (null? (dstate/previous-subproblems dstate))
- (debugger-failure "Already at latest subproblem level")
- (let ((previous-subproblems (dstate/previous-subproblems dstate)))
- (move-to-subproblem! dstate
- (car previous-subproblems)
- (cdr previous-subproblems)
- select-reduction-number))))
-\f
-;;;; General motion command
+ (debugger-failure
+ (reason+message reason "already at lowest subproblem level."))
+ (begin
+ (let ((p (dstate/previous-subproblems dstate)))
+ (set-current-subproblem! dstate (car p) (cdr p)))
+ (if-successful dstate))))
(define (command/goto dstate)
- (let* ((subproblems (select-subproblem dstate))
- (subproblem (car subproblems))
- (reduction-number
- (select-reduction
- (improper-list-length (stack-frame/reductions subproblem)))))
- (move-to-subproblem! dstate
- subproblem
- (cdr subproblems)
- (lambda (number-of-reductions)
- number-of-reductions ;ignore
- reduction-number))))
+ (maybe-stop-using-history! dstate)
+ (let ((subproblems (select-subproblem dstate)))
+ (set-current-subproblem! dstate (car subproblems) (cdr subproblems)))
+ (finish-move-to-subproblem! dstate))
(define (select-subproblem dstate)
(let top-level-loop ()
(debugger-failure
"Subproblem number too large (limit is "
(length subproblems)
- " inclusive)")
+ " inclusive).")
(top-level-loop))))))))))
-(define (select-reduction number-of-reductions)
- (cond ((> number-of-reductions 1)
- (prompt-for-nonnegative-integer "Reduction number"
- number-of-reductions))
- ((= number-of-reductions 1)
- (debugger-message "Exactly one reduction for this subproblem")
- 0)
- (else
- (debugger-message "No reductions for this subproblem")
- -1)))
-
(define (prompt-for-nonnegative-integer prompt limit)
(let loop ()
(let ((expression
" inclusive)")
"")))))
(cond ((not (exact-nonnegative-integer? expression))
- (debugger-failure prompt " must be nonnegative integer")
+ (debugger-failure prompt " must be nonnegative integer.")
(loop))
((and limit (>= expression limit))
- (debugger-failure prompt " too large")
+ (debugger-failure prompt " too large.")
(loop))
(else
expression)))))
\f
+;;;; Reduction motion
+
+(define (command/earlier-reduction dstate)
+ (maybe-start-using-history! dstate)
+ (let ((up
+ (lambda ()
+ (earlier-subproblem dstate false finish-move-to-subproblem!))))
+ (if (not (dstate/using-history? dstate))
+ (up)
+ (let ((n-reductions (dstate/number-of-reductions dstate))
+ (reduction-number (dstate/reduction-number dstate))
+ (wrap
+ (lambda (reason)
+ (earlier-subproblem
+ dstate
+ reason
+ (lambda (dstate)
+ (debugger-message
+ (reason+message
+ reason
+ "going to the next (less recent) subproblem."))
+ (finish-move-to-subproblem! dstate))))))
+ (cond ((zero? n-reductions)
+ (up))
+ ((not reduction-number)
+ (move-to-reduction! dstate 0))
+ ((and (< reduction-number (-1+ n-reductions))
+ (not (and debugger:student-walk?
+ (positive? (dstate/subproblem-number dstate))
+ (= reduction-number 0))))
+ (move-to-reduction! dstate (1+ reduction-number)))
+ (debugger:student-walk?
+ (up))
+ (else
+ (wrap "no more reductions")))))))
+
+(define (command/later-reduction dstate)
+ (maybe-start-using-history! dstate)
+ (let ((down
+ (lambda ()
+ (later-subproblem dstate false finish-move-to-subproblem!))))
+ (if (not (dstate/using-history? dstate))
+ (later-subproblem dstate false finish-move-to-subproblem!)
+ (let ((reduction-number (dstate/reduction-number dstate))
+ (wrap
+ (lambda (reason)
+ (later-subproblem
+ dstate
+ reason
+ (lambda (dstate)
+ (debugger-message
+ (reason+message
+ reason
+ "going to the previous (more recent) subproblem."))
+ (let ((n (dstate/number-of-reductions dstate)))
+ (if (and n (positive? n))
+ (move-to-reduction!
+ dstate
+ (if (and debugger:student-walk?
+ (positive?
+ (dstate/subproblem-number dstate)))
+ 0
+ (-1+ n)))
+ (finish-move-to-subproblem! dstate))))))))
+ (cond ((zero? (dstate/number-of-reductions dstate))
+ (down))
+ ((not reduction-number)
+ (wrap false))
+ ((positive? reduction-number)
+ (move-to-reduction! dstate (-1+ reduction-number)))
+ (debugger:student-walk?
+ (down))
+ (else
+ (wrap "no more reductions")))))))
+\f
;;;; Environment motion and display
(define (command/show-current-frame dstate)
(let ((environment-list (dstate/environment-list dstate)))
(cond ((not (pair? environment-list))
(undefined-environment))
- ((environment-has-parent? (car environment-list))
+ ((eq? true (environment-has-parent? (car environment-list)))
(set-dstate/environment-list!
dstate
(cons (environment-parent (car environment-list))
environment-list))
(show-current-frame dstate true))
(else
- (debugger-failure "The current environment has no parent")))))
+ (debugger-failure "The current environment has no parent.")))))
(define (command/move-to-child-environment dstate)
(let ((environment-list (dstate/environment-list dstate)))
(undefined-environment))
((not (pair? (cdr environment-list)))
(debugger-failure
- "This is the initial environment; can't move to child"))
+ "This is the initial environment; can't move to child."))
(else
(set-dstate/environment-list! dstate (cdr environment-list))
(show-current-frame dstate true)))))
(define (command/enter-read-eval-print-loop dstate)
(debug/read-eval-print (get-evaluation-environment dstate)
- "You are now in the desired environment"
+ "the debugger"
+ "the desired environment"
"Eval-in-env-->"))
(define (command/eval-in-current-environment dstate)
(write-string " Formatted output:")
(newline)
((condition/reporter condition) condition port))))
- (debugger-failure "No error to report")))
+ (debugger-failure "No error to report.")))
\f
;;;; Advanced hacking commands
(unsyntax (dstate/expression dstate))
expression))
environment)))
- (if print-return-values?
+ (if debugger:print-return-values?
(begin
(newline)
(write-string "That evaluates to:")
(define (command/internal dstate)
(fluid-let ((*dstate* dstate))
(debug/read-eval-print (->environment '(RUNTIME DEBUGGER))
- "You are now in the debugger environment"
+ "the debugger"
+ "the debugger environment"
"Debugger-->")))
(define (command/frame dstate)
(write (dstate/subproblem dstate))
(for-each (lambda (element)
(newline)
- (pretty-print element))
+ (debugger-pp element 0))
(named-structure/description (dstate/subproblem dstate))))))
\f
;;;; Low-level Side-effects
-(define (move-to-subproblem! dstate
- stack-frame
- previous-frames
- select-reduction-number)
- (dynamic-wind
- (lambda ()
- unspecific)
- (lambda ()
- (set-current-subproblem! dstate
- stack-frame
- previous-frames
- select-reduction-number))
- (lambda ()
- (command/print-reduction dstate))))
+(define (maybe-start-using-history! dstate)
+ (if (eq? 'ENABLED (dstate/history-state dstate))
+ (begin
+ (set-dstate/history-state! dstate 'NOW)
+ (debugger-message
+ "Now using information from the execution history."))))
-(define (move-to-reduction! dstate reduction-number)
- (dynamic-wind (lambda () unspecific)
- (lambda () (set-current-reduction! dstate reduction-number))
- (lambda () (command/print-reduction dstate))))
-
-(define (set-current-subproblem! dstate
- stack-frame
- previous-frames
- select-reduction-number)
+(define (maybe-stop-using-history! dstate)
+ (if (eq? 'NOW (dstate/history-state dstate))
+ (begin
+ (set-dstate/history-state! dstate 'ENABLED)
+ (debugger-message
+ "Now ignoring information from the execution history."))))
+
+(define (dstate/using-history? dstate)
+ (or (eq? 'ALWAYS (dstate/history-state dstate))
+ (eq? 'NOW (dstate/history-state dstate))))
+
+(define (dstate/auto-toggle? dstate)
+ (not (eq? 'DISABLED (dstate/history-state dstate))))
+
+(define (set-current-subproblem! dstate stack-frame previous-frames)
(set-dstate/subproblem! dstate stack-frame)
(set-dstate/previous-subproblems! dstate previous-frames)
(set-dstate/subproblem-number! dstate (length previous-frames))
- (let* ((reductions (if stack-frame (stack-frame/reductions stack-frame) '()))
- (number-of-reductions (improper-list-length reductions)))
- (set-dstate/reductions! dstate reductions)
- (set-dstate/number-of-reductions! dstate number-of-reductions)
- (set-current-reduction! dstate
- (select-reduction-number number-of-reductions))))
-
-(define (normal-reduction-number number-of-reductions)
- (min (-1+ number-of-reductions) 0))
-
-(define (first-reduction-number number-of-reductions)
- number-of-reductions ;ignore
- 0)
-
-(define (last-reduction-number number-of-reductions)
- (-1+ number-of-reductions))
-
-(define (set-current-reduction! dstate number)
- (set-dstate/reduction-number! dstate number)
- (let ((reduction
- (and (>= number 0)
- (let loop
- ((reductions (dstate/reductions dstate))
- (number number))
- (and (pair? reductions)
- (if (zero? number)
- (car reductions)
- (loop (cdr reductions) (-1+ number))))))))
- (set-dstate/reduction! dstate reduction)
- (if reduction
- (begin
- (set-dstate/expression! dstate (reduction-expression reduction))
- (set-dstate/environment-list!
- dstate
- (list (reduction-environment reduction))))
- (with-values
- (lambda ()
- (stack-frame/debugging-info (dstate/subproblem dstate)))
- (lambda (expression environment)
- (set-dstate/expression! dstate expression)
- (set-dstate/environment-list!
- dstate
- (if (debugging-info/undefined-environment? environment)
- '()
- (list environment))))))))
+ (set-dstate/number-of-reductions!
+ dstate
+ (improper-list-length (stack-frame/reductions stack-frame)))
+ (with-values (lambda () (stack-frame/debugging-info stack-frame))
+ (lambda (expression environment subexpression)
+ (set-dstate/expression! dstate expression)
+ (set-dstate/subexpression! dstate subexpression)
+ (set-dstate/environment-list!
+ dstate
+ (if (debugging-info/undefined-environment? environment)
+ '()
+ (list environment))))))
+
+(define (finish-move-to-subproblem! dstate)
+ (if (and (dstate/using-history? dstate)
+ (positive? (dstate/number-of-reductions dstate)))
+ (move-to-reduction! dstate 0)
+ (begin
+ (set-dstate/reduction-number! dstate false)
+ (command/print-subproblem dstate))))
+
+(define (move-to-reduction! dstate reduction-number)
+ (set-dstate/reduction-number! dstate reduction-number)
+ (set-dstate/environment-list!
+ dstate
+ (list (reduction-environment (dstate/reduction dstate))))
+ (command/print-reduction dstate))
\f
;;;; Utilities
(count (1+ n) (cdr l))
n)))
+(define (nth-reduction reductions n)
+ (let loop ((reductions reductions) (n n))
+ (if (zero? n)
+ (car reductions)
+ (loop (cdr reductions) (-1+ n)))))
+
(define-integrable (reduction-expression reduction)
(car reduction))
(car environment-list)
(begin
(debugger-message
- "Cannot evaluate in current environment;\nusing the read-eval-print environment instead")
+ "Cannot evaluate in current environment;
+using the read-eval-print environment instead.")
(nearest-repl/environment)))))
(define (with-current-environment dstate receiver)
(undefined-environment))))
(define (undefined-environment)
- (debugger-failure "There is no current environment"))
\ No newline at end of file
+ (debugger-failure "There is no current environment."))
+
+(define (reason+message reason message)
+ (string-capitalize (if reason (string-append reason "; " message) message)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.5 1990/06/22 01:04:32 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.6 1990/09/11 20:44:25 cph Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
("Debug-->" . "[Debugger]")
("Where-->" . "[Environment Inspector]")
("Which-->" . "[Task Inspector]")))
+
+(define (emacs/debugger-failure message)
+ (beep)
+ (emacs-typeout message))
+
+(define (emacs/debugger-message message)
+ (emacs-typeout message))
+
+(define (emacs/presentation thunk)
+ (newline)
+ (if emacs-presentation-top-justify?
+ (begin
+ (emacs-eval "(setq xscheme-temp-1 (point))")
+ (thunk)
+ (emacs-eval "(set-window-start (selected-window) xscheme-temp-1 nil)"))
+ (thunk)))
+
+(define emacs-presentation-top-justify? false)
+
+(define (emacs-typeout message)
+ (emacs-eval "(message \"%s\" " (write-to-string message) ")"))
+
+(define (emacs-eval . strings)
+ (transmit-signal-with-argument #\E (apply string-append strings)))
\f
(define (emacs/error-decision)
(transmit-signal-without-gc #\z)
(define normal/prompt-for-expression)
(define normal/^G-interrupt)
(define normal/set-working-directory-pathname!)
+(define normal/debugger-failure)
+(define normal/debugger-message)
(define normal/presentation)
(define normal/clean-input/flush-typeahead)
(set! normal/^G-interrupt hook/^G-interrupt)
(set! normal/set-working-directory-pathname!
hook/set-working-directory-pathname!)
- ;;(set! normal/presentation hook/presentation)
+ (set! normal/debugger-failure hook/debugger-failure)
+ (set! normal/debugger-message hook/debugger-message)
+ (set! normal/presentation hook/presentation)
(set! normal/clean-input/flush-typeahead hook/clean-input/flush-typeahead)
(add-event-receiver! event:after-restore install!)
(install!))
(set! hook/^G-interrupt emacs/^G-interrupt)
(set! hook/set-working-directory-pathname!
emacs/set-working-directory-pathname!)
- ;;(set! hook/presentation (lambda (thunk) (thunk)))
+ (set! hook/debugger-failure emacs/debugger-failure)
+ (set! hook/debugger-message emacs/debugger-message)
+ (set! hook/presentation emacs/presentation)
(set! hook/clean-input/flush-typeahead emacs/clean-input/flush-typeahead)
unspecific)
(set! hook/^G-interrupt normal/^G-interrupt)
(set! hook/set-working-directory-pathname!
normal/set-working-directory-pathname!)
- ;;(set! hook/presentation normal/presentation)
+ (set! hook/debugger-failure normal/debugger-failure)
+ (set! hook/debugger-message normal/debugger-message)
+ (set! hook/presentation normal/presentation)
(set! hook/clean-input/flush-typeahead normal/clean-input/flush-typeahead)
unspecific)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.11 1990/08/21 04:18:40 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.12 1990/09/11 20:44:34 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
+(define (stack-frame/debugging-info frame)
+ (let ((method
+ (stack-frame-type/debugging-info-method (stack-frame/type frame))))
+ (if (not method)
+ ;; (error "STACK-FRAME/DEBUGGING-INFO: missing method" frame)
+ (values (make-debugging-info/noise
+ (lambda (long?)
+ (with-output-to-string
+ (lambda ()
+ (display "Unknown (methodless) ")
+ (if long?
+ (pp frame)
+ (write frame))))))
+ undefined-environment
+ undefined-expression)
+ (method frame))))
+
(define (debugging-info/undefined-expression? expression)
(or (eq? expression undefined-expression)
(debugging-info/noise? expression)))
(define-integrable (debugging-info/undefined-environment? environment)
(eq? environment undefined-environment))
+(define-integrable (debugging-info/unknown-expression? expression)
+ (eq? expression unknown-expression))
+
(define-integrable (debugging-info/compiled-code? expression)
(eq? expression compiled-code))
-(define (stack-frame/debugging-info frame)
- (let ((method
- (1d-table/get (stack-frame-type/properties (stack-frame/type frame))
- method-tag
- false)))
- (if (not method)
- ;; (error "STACK-FRAME/DEBUGGING-INFO: missing method" frame)
- (values (make-debugging-info/noise
- (lambda (long?)
- (with-output-to-string
- (lambda ()
- (display "Unknown (methodless) ")
- (if long?
- (pp frame)
- (write frame))))))
- undefined-environment)
- (method frame))))
-
(define (make-evaluated-object object)
(if (scode-constant? object)
object
(define-integrable (debugging-info/evaluated-object-value expression)
(cdr expression))
-(define method-tag "stack-frame/debugging-info method")
+(define (validate-subexpression frame subexpression)
+ (if (eq? (stack-frame/previous-type frame) stack-frame-type/pop-return-error)
+ undefined-expression
+ subexpression))
+
(define undefined-expression "undefined expression")
(define undefined-environment "undefined environment")
+(define unknown-expression "unknown expression")
(define compiled-code "compiled code")
(define evaluated-object-tag "evaluated")
+(define stack-frame-type/pop-return-error)
\f
-(define (method/standard frame)
- (values (stack-frame/ref frame 1) (stack-frame/ref frame 2)))
-
(define (method/null frame)
frame
- (values undefined-expression undefined-environment))
-
-(define (method/expression-only frame)
- (values (stack-frame/ref frame 1) undefined-environment))
+ (values undefined-expression undefined-environment undefined-expression))
(define (method/environment-only frame)
- (values undefined-expression (stack-frame/ref frame 2)))
+ (values undefined-expression (stack-frame/ref frame 2) undefined-expression))
-(define (method/compiled-code frame)
- (values
- (let ((object
- (compiled-entry/dbg-object (stack-frame/return-address frame)))
- (lose (lambda () compiled-code)))
- (cond ((not object)
- (lose))
- ((dbg-continuation? object)
- (let ((source-code (dbg-continuation/source-code object)))
- (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))))
- ((dbg-procedure? object)
- (lambda-body (dbg-procedure/source-code object)))
- #|
- ((dbg-expression? object)
- ;; no expression!
- (lose))
- |#
- (else
- (lose))))
- (stack-frame/environment frame undefined-environment)))
+(define ((method/standard select-subexpression) frame)
+ (let ((expression (stack-frame/ref frame 1)))
+ (values expression
+ (stack-frame/ref frame 2)
+ (validate-subexpression frame (select-subexpression expression)))))
+
+(define ((method/expression-only select-subexpression) frame)
+ (let ((expression (stack-frame/ref frame 1)))
+ (values expression
+ undefined-environment
+ (validate-subexpression frame (select-subexpression expression)))))
(define (method/primitive-combination-3-first-operand frame)
- (values (stack-frame/ref frame 1) (stack-frame/ref frame 3)))
+ (let ((expression (stack-frame/ref frame 1)))
+ (values expression
+ (stack-frame/ref frame 3)
+ (validate-subexpression frame (&vector-ref expression 2)))))
+
+(define (method/combination-save-value frame)
+ (let ((expression (stack-frame/ref frame 1)))
+ (values expression
+ (stack-frame/ref frame 2)
+ (validate-subexpression
+ frame
+ (&vector-ref expression (1+ (stack-frame/ref frame 3)))))))
+
+(define (method/eval-error frame)
+ (values (stack-frame/ref frame 1)
+ (stack-frame/ref frame 2)
+ undefined-expression))
(define (method/force-snap-thunk frame)
- (values (%make-combination
- (ucode-primitive force 1)
- (list (make-evaluated-object (stack-frame/ref frame 1))))
- undefined-environment))
+ (let ((promise (stack-frame/ref frame 1)))
+ (values (%make-combination
+ (ucode-primitive force 1)
+ (list (make-evaluated-object promise)))
+ undefined-environment
+ (cond ((promise-forced? promise) undefined-expression)
+ ((promise-non-expression? promise) unknown-expression)
+ (else
+ (validate-subexpression frame
+ (promise-expression promise)))))))
(define ((method/application-frame index) frame)
(values (%make-combination
(make-evaluated-object (stack-frame/ref frame index))
(stack-frame-list frame (1+ index)))
- undefined-environment))
+ undefined-environment
+ undefined-expression))
\f
(define ((method/compiler-reference scode-maker) frame)
(values (scode-maker (stack-frame/ref frame 3))
- (stack-frame/ref frame 2)))
+ (stack-frame/ref frame 2)
+ undefined-expression))
(define ((method/compiler-assignment scode-maker) frame)
(values (scode-maker (stack-frame/ref frame 3)
(make-evaluated-object (stack-frame/ref frame 4)))
- (stack-frame/ref frame 2)))
+ (stack-frame/ref frame 2)
+ undefined-expression))
(define ((method/compiler-reference-trap scode-maker) frame)
(values (scode-maker (stack-frame/ref frame 2))
- (stack-frame/ref frame 3)))
+ (stack-frame/ref frame 3)
+ undefined-expression))
(define ((method/compiler-assignment-trap scode-maker) frame)
(values (scode-maker (stack-frame/ref frame 2)
(make-evaluated-object (stack-frame/ref frame 4)))
- (stack-frame/ref frame 3)))
+ (stack-frame/ref frame 3)
+ undefined-expression))
(define (method/compiler-lookup-apply-restart frame)
(values (%make-combination (stack-frame/ref frame 3)
(stack-frame-list frame 5))
- undefined-environment))
+ undefined-environment
+ undefined-expression))
(define (method/compiler-lookup-apply-trap-restart frame)
(values (%make-combination (make-variable (stack-frame/ref frame 2))
(stack-frame-list frame 6))
- (stack-frame/ref frame 3)))
+ (stack-frame/ref frame 3)
+ undefined-expression))
(define (stack-frame-list frame start)
(let ((end (stack-frame/length frame)))
(define (method/hardware-trap frame)
(values (make-debugging-info/noise (hardware-trap-noise frame))
- undefined-environment))
+ undefined-environment
+ undefined-expression))
(define ((hardware-trap-noise frame) long?)
(with-output-to-string
(lambda ()
(hardware-trap-frame/describe frame long?))))
\f
+(define (method/compiled-code frame)
+ (let ((environment (stack-frame/environment frame undefined-environment)))
+ (let ((object
+ (compiled-entry/dbg-object (stack-frame/return-address frame)))
+ (lose
+ (lambda ()
+ (values compiled-code environment undefined-expression))))
+ (cond ((not object)
+ (lose))
+ ((dbg-continuation? object)
+ (let ((source-code (dbg-continuation/source-code object)))
+ (if (and (vector? source-code)
+ (not (zero? (vector-length source-code))))
+ (let ((expression (vector-ref source-code 1)))
+ (let ((win
+ (lambda (select-subexpression)
+ (values
+ expression
+ environment
+ (validate-subexpression
+ frame
+ (select-subexpression expression))))))
+ (case (vector-ref source-code 0)
+ ((SEQUENCE-2-SECOND)
+ (win &pair-car))
+ ((ASSIGNMENT-CONTINUE
+ DEFINITION-CONTINUE)
+ (win &pair-cdr))
+ ((SEQUENCE-3-SECOND
+ CONDITIONAL-DECIDE)
+ (win &triple-first))
+ ((SEQUENCE-3-THIRD)
+ (win &triple-second))
+ ((COMBINATION-OPERAND)
+ (values
+ expression
+ environment
+ (validate-subexpression
+ frame
+ (list-ref (combination-operands expression)
+ (-1+ (vector-ref source-code 2))))))
+ (else
+ (lose)))))
+ (lose))))
+ ((dbg-procedure? object)
+ (values (lambda-body (dbg-procedure/source-code object))
+ environment
+ undefined-expression))
+ #|
+ ((dbg-expression? object)
+ ;; no expression!
+ (lose))
+ |#
+ (else
+ (lose))))))
+\f
(define (initialize-package!)
- (for-each (lambda (entry)
- (for-each (lambda (name)
- (let ((type
- (or (microcode-return/code->type
- (microcode-return name))
- (error "Missing return type" name))))
- (1d-table/put! (stack-frame-type/properties type)
- method-tag
- (car entry))))
- (cdr entry)))
- `((,method/standard
- ASSIGNMENT-CONTINUE
- COMBINATION-1-PROCEDURE
- COMBINATION-2-FIRST-OPERAND
- COMBINATION-2-PROCEDURE
- COMBINATION-SAVE-VALUE
- CONDITIONAL-DECIDE
- DEFINITION-CONTINUE
- DISJUNCTION-DECIDE
- EVAL-ERROR
- PRIMITIVE-COMBINATION-2-FIRST-OPERAND
- PRIMITIVE-COMBINATION-3-SECOND-OPERAND
- SEQUENCE-2-SECOND
- SEQUENCE-3-SECOND
- SEQUENCE-3-THIRD)
-
- (,method/null
- COMBINATION-APPLY
- GC-CHECK
- MOVE-TO-ADJACENT-POINT
- REENTER-COMPILED-CODE)
-
- (,method/expression-only
- ACCESS-CONTINUE
- IN-PACKAGE-CONTINUE
- PRIMITIVE-COMBINATION-1-APPLY
- PRIMITIVE-COMBINATION-2-APPLY
- PRIMITIVE-COMBINATION-3-APPLY)
-
- (,method/environment-only
- REPEAT-DISPATCH)
-
- (,method/primitive-combination-3-first-operand
- PRIMITIVE-COMBINATION-3-FIRST-OPERAND)
-
- (,method/force-snap-thunk
- FORCE-SNAP-THUNK)
-
- (,(method/application-frame 3)
- INTERNAL-APPLY)
-
- (,(method/application-frame 3)
- INTERNAL-APPLY-VAL)
-
- (,(method/application-frame 1)
- REPEAT-PRIMITIVE)
-
- (,(method/compiler-reference identity-procedure)
- COMPILER-REFERENCE-RESTART
- COMPILER-SAFE-REFERENCE-RESTART)
-
- (,(method/compiler-reference make-variable)
- COMPILER-ACCESS-RESTART)
-
- (,(method/compiler-reference make-unassigned?)
- COMPILER-UNASSIGNED?-RESTART)
-
- (,(method/compiler-reference
- (lambda (name)
- (%make-combination (ucode-primitive lexical-unbound?)
- (list (make-the-environment) name))))
- COMPILER-UNBOUND?-RESTART)
-
- (,(method/compiler-assignment make-assignment-from-variable)
- COMPILER-ASSIGNMENT-RESTART)
-
- (,(method/compiler-assignment make-definition)
- COMPILER-DEFINITION-RESTART)
-
- (,(method/compiler-reference-trap make-variable)
- COMPILER-REFERENCE-TRAP-RESTART
- COMPILER-SAFE-REFERENCE-TRAP-RESTART)
-
- (,(method/compiler-reference-trap make-unassigned?)
- COMPILER-UNASSIGNED?-TRAP-RESTART)
-
- (,(method/compiler-assignment-trap make-assignment)
- COMPILER-ASSIGNMENT-TRAP-RESTART)
-
- (,method/compiler-lookup-apply-restart
- COMPILER-LOOKUP-APPLY-RESTART)
-
- (,method/compiler-lookup-apply-trap-restart
- COMPILER-LOOKUP-APPLY-TRAP-RESTART
- COMPILER-OPERATOR-LOOKUP-TRAP-RESTART)
-
- (,method/hardware-trap
- HARDWARE-TRAP)))
- (for-each
- (lambda (type)
- (1d-table/put!
- (stack-frame-type/properties type)
- method-tag
- method/compiled-code))
- (list
- stack-frame-type/compiled-return-address
- stack-frame-type/interrupt-compiled-procedure
- stack-frame-type/interrupt-compiled-expression)))
\ No newline at end of file
+ (set! stack-frame-type/pop-return-error
+ (microcode-return/name->type 'POP-RETURN-ERROR))
+ (record-method 'COMBINATION-APPLY method/null)
+ (record-method 'GC-CHECK method/null)
+ (record-method 'MOVE-TO-ADJACENT-POINT method/null)
+ (record-method 'REENTER-COMPILED-CODE method/null)
+ (record-method 'REPEAT-DISPATCH method/environment-only)
+ (let ((method (method/standard &pair-car)))
+ (record-method 'DISJUNCTION-DECIDE method)
+ (record-method 'SEQUENCE-2-SECOND method))
+ (let ((method (method/standard &pair-cdr)))
+ (record-method 'ASSIGNMENT-CONTINUE method)
+ (record-method 'COMBINATION-1-PROCEDURE method)
+ (record-method 'DEFINITION-CONTINUE method))
+ (let ((method (method/standard &triple-first)))
+ (record-method 'CONDITIONAL-DECIDE method)
+ (record-method 'SEQUENCE-3-SECOND method))
+ (let ((method (method/standard &triple-second)))
+ (record-method 'COMBINATION-2-PROCEDURE method)
+ (record-method 'SEQUENCE-3-THIRD method))
+ (let ((method (method/standard &triple-third)))
+ (record-method 'COMBINATION-2-FIRST-OPERAND method)
+ (record-method 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND method))
+ (record-method 'PRIMITIVE-COMBINATION-3-SECOND-OPERAND
+ (method/standard &vector-fourth))
+ (let ((method (method/expression-only &pair-car)))
+ (record-method 'ACCESS-CONTINUE method)
+ (record-method 'IN-PACKAGE-CONTINUE method))
+ (record-method 'PRIMITIVE-COMBINATION-1-APPLY
+ (method/expression-only &pair-cdr))
+ (record-method 'PRIMITIVE-COMBINATION-2-APPLY
+ (method/expression-only &triple-second))
+ (record-method 'PRIMITIVE-COMBINATION-3-APPLY
+ (method/expression-only &vector-second))
+ (record-method 'COMBINATION-SAVE-VALUE method/combination-save-value)
+ (record-method 'PRIMITIVE-COMBINATION-3-FIRST-OPERAND
+ method/primitive-combination-3-first-operand)
+ (record-method 'EVAL-ERROR method/eval-error)
+ (record-method 'FORCE-SNAP-THUNK method/force-snap-thunk)
+ (let ((method (method/application-frame 3)))
+ (record-method 'INTERNAL-APPLY method)
+ (record-method 'INTERNAL-APPLY-VAL method))
+ (record-method 'REPEAT-PRIMITIVE (method/application-frame 1))
+ (let ((method (method/compiler-reference identity-procedure)))
+ (record-method 'COMPILER-REFERENCE-RESTART method)
+ (record-method 'COMPILER-SAFE-REFERENCE-RESTART method))
+ (record-method 'COMPILER-ACCESS-RESTART
+ (method/compiler-reference make-variable))
+ (record-method 'COMPILER-UNASSIGNED?-RESTART
+ (method/compiler-reference make-unassigned?))
+ (record-method 'COMPILER-UNBOUND?-RESTART
+ (method/compiler-reference
+ (lambda (name)
+ (%make-combination (ucode-primitive lexical-unbound?)
+ (list (make-the-environment) name)))))
+ (record-method 'COMPILER-ASSIGNMENT-RESTART
+ (method/compiler-assignment make-assignment-from-variable))
+ (record-method 'COMPILER-DEFINITION-RESTART
+ (method/compiler-assignment make-definition))
+ (let ((method (method/compiler-reference-trap make-variable)))
+ (record-method 'COMPILER-REFERENCE-TRAP-RESTART method)
+ (record-method 'COMPILER-SAFE-REFERENCE-TRAP-RESTART method))
+ (record-method 'COMPILER-UNASSIGNED?-TRAP-RESTART
+ (method/compiler-reference-trap make-unassigned?))
+ (record-method 'COMPILER-ASSIGNMENT-TRAP-RESTART
+ (method/compiler-assignment-trap make-assignment))
+ (record-method 'COMPILER-LOOKUP-APPLY-RESTART
+ method/compiler-lookup-apply-restart)
+ (record-method 'COMPILER-LOOKUP-APPLY-TRAP-RESTART
+ method/compiler-lookup-apply-trap-restart)
+ (record-method 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART
+ method/compiler-lookup-apply-trap-restart)
+ (record-method 'HARDWARE-TRAP method/hardware-trap)
+ (set-stack-frame-type/debugging-info-method!
+ stack-frame-type/compiled-return-address
+ method/compiled-code)
+ (set-stack-frame-type/debugging-info-method!
+ stack-frame-type/interrupt-compiled-procedure
+ method/compiled-code)
+ (set-stack-frame-type/debugging-info-method!
+ stack-frame-type/interrupt-compiled-expression
+ method/compiled-code))
+
+(define (&vector-second vector)
+ (&vector-ref vector 1))
+
+(define (&vector-fourth vector)
+ (&vector-ref vector 3))
+
+(define (record-method name method)
+ (set-stack-frame-type/debugging-info-method!
+ (microcode-return/name->type name)
+ method))
+
+(define-integrable (stack-frame-type/debugging-info-method type)
+ (1d-table/get (stack-frame-type/properties type) method-tag false))
+
+(define-integrable (set-stack-frame-type/debugging-info-method! type method)
+ (1d-table/put! (stack-frame-type/properties type) method-tag method))
+
+(define method-tag "stack-frame-type/debugging-info-method")
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 14.5 1989/04/18 16:29:32 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 14.6 1990/09/11 20:44:43 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(set! clexpr-unwrap-body! unwrap-body!)
(set! clexpr-unwrapped-body unwrapped-body)
(set! set-clexpr-unwrapped-body! set-unwrapped-body!)))
- (lambda-body-procedures &triple-first &triple-set-first!
+ (lambda-body-procedures xlambda/physical-body xlambda/set-physical-body!
(lambda (wrap-body! wrapper-components unwrap-body!
unwrapped-body set-unwrapped-body!)
(set! xlambda-wrap-body! wrap-body!)
(slambda-components clambda
(lambda (name required body)
(receiver name required '() '()
- (if (combination? body)
- (let ((operator (combination-operator body)))
- (if (internal-lambda? operator)
- (slambda-components operator
- (lambda (tag auxiliary body)
- tag body
- auxiliary))
- '()))
- '())
+ (lambda-body-auxiliary body)
(clambda-unwrapped-body clambda)))))
(define (clambda-bound clambda)
(slambda-components clambda
(lambda (name required body)
name
- (if (combination? body)
- (let ((operator (combination-operator body)))
- (if (internal-lambda? operator)
- (slambda-components operator
- (lambda (tag auxiliary body)
- tag body
- (append required auxiliary)))
- required))
- required))))
+ (append required (lambda-body-auxiliary body)))))
(define (clambda-has-internal-lambda? clambda)
- (let ((body (slambda-body clambda)))
- (and (combination? body)
- (let ((operator (combination-operator body)))
- (and (internal-lambda? operator)
- operator)))))
+ (lambda-body-has-internal-lambda? (slambda-body clambda)))
+
+(define (lambda-body-auxiliary body)
+ (if (combination? body)
+ (let ((operator (combination-operator body)))
+ (if (internal-lambda? operator)
+ (slambda-auxiliary operator)
+ '()))
+ '()))
+
+(define (lambda-body-has-internal-lambda? body)
+ (and (combination? body)
+ (let ((operator (combination-operator body)))
+ (and (internal-lambda? operator)
+ operator))))
(define clambda-wrap-body!)
(define clambda-wrapper-components)
(make-slexpr name
required
(make-combination
- (make-internal-lexpr (cons rest auxiliary) body)
- (cons (let ((environment (make-the-environment)))
+ (make-internal-lexpr
+ (list rest)
+ (if (null? auxiliary)
+ body
+ (make-combination (make-internal-lambda auxiliary body)
+ (make-unassigned auxiliary))))
+ (list (let ((environment (make-the-environment)))
(make-combination
system-subvector->list
(list environment
(+ (length required) 3)
(make-combination system-vector-length
- (list environment)))))
- (make-unassigned auxiliary)))))
+ (list environment)))))))))
(define (clexpr-components clexpr receiver)
(slexpr-components clexpr
(lambda (name required body)
- (slambda-components (combination-operator body)
- (lambda (tag auxiliary body)
- tag body
+ (let ((internal (combination-operator body)))
+ (let ((auxiliary (slambda-auxiliary internal)))
(receiver name
required
'()
(car auxiliary)
- (cdr auxiliary)
+ (append (cdr auxiliary)
+ (lambda-body-auxiliary (slambda-body internal)))
(clexpr-unwrapped-body clexpr)))))))
(define (clexpr-bound clexpr)
(slexpr-components clexpr
(lambda (name required body)
name
- (slambda-components (combination-operator body)
- (lambda (tag auxiliary body)
- tag body
- (append required auxiliary))))))
+ (let ((internal (combination-operator body)))
+ (append required
+ (slambda-auxiliary internal)
+ (lambda-body-auxiliary (slambda-body internal)))))))
(define (clexpr-has-internal-lambda? clexpr)
- (combination-operator (slexpr-body clexpr)))
+ (let ((internal (combination-operator (slexpr-body clexpr))))
+ (or (lambda-body-has-internal-lambda? (slambda-body internal))
+ internal)))
(define clexpr-wrap-body!)
(define clexpr-wrapper-components)
(ucode-type extended-lambda))
(define (make-xlambda name required optional rest auxiliary body)
- (&typed-triple-cons xlambda-type
- body
- (list->vector
- (cons name
- (append required
- optional
- (if (null? rest)
- auxiliary
- (cons rest auxiliary)))))
- (make-non-pointer-object
- (+ (length optional)
- (* 256
- (+ (length required) (if (null? rest) 0 256)))))))
+ (&typed-triple-cons
+ xlambda-type
+ (if (null? auxiliary)
+ body
+ (make-combination (make-internal-lambda auxiliary body)
+ (make-unassigned auxiliary)))
+ (list->vector
+ (cons name (append required optional (if (null? rest) '() (list rest)))))
+ (make-non-pointer-object
+ (+ (length optional)
+ (* 256
+ (+ (length required)
+ (if (null? rest) 0 256)))))))
(define-integrable (xlambda? object)
(object-type? xlambda-type object))
(if (zero? (car qr2))
'()
(vector-ref bound rstart))
- (subvector->list bound
- astart
- (vector-length bound))
+ (append
+ (subvector->list bound astart (vector-length bound))
+ (lambda-body-auxiliary (&triple-first xlambda)))
(xlambda-unwrapped-body xlambda))))))))
(define (xlambda-name xlambda)
(vector-ref (&triple-second xlambda) 0))
(define (xlambda-bound xlambda)
- (let ((names (&triple-second xlambda)))
- (subvector->list names 1 (vector-length names))))
+ (append (let ((names (&triple-second xlambda)))
+ (subvector->list names 1 (vector-length names)))
+ (lambda-body-auxiliary (&triple-first xlambda))))
(define (xlambda-has-internal-lambda? xlambda)
- xlambda
- false)
+ (lambda-body-has-internal-lambda? (&triple-first xlambda)))
(define xlambda-wrap-body!)
(define xlambda-wrapper-components)
(define xlambda-unwrap-body!)
(define xlambda-unwrapped-body)
(define set-xlambda-unwrapped-body!)
+
+(define (xlambda/physical-body xlambda)
+ (let ((internal (xlambda-has-internal-lambda? xlambda)))
+ (if internal
+ (slambda-body internal)
+ (&triple-first xlambda))))
+
+(define (xlambda/set-physical-body! xlambda body)
+ (let ((internal (xlambda-has-internal-lambda? xlambda)))
+ (if internal
+ (set-slambda-body! internal body)
+ (&triple-set-first! xlambda body))))
\f
;;;; Generic Lambda
(xlambda? object)))
(define (make-lambda name required optional rest auxiliary declarations body)
+ (if (or (list-has-duplicates? required)
+ (list-has-duplicates? optional)
+ (list-has-duplicates? auxiliary)
+ (there-exists? required (lambda (name) (memq name optional)))
+ (and rest (or (memq rest required) (memq rest optional))))
+ (error "one or more duplicate parameters"
+ required optional rest auxiliary))
(let ((body* (if (null? declarations)
body
(make-sequence (list (make-block-declaration declarations)
(block-declaration-text (car actions))
(make-sequence (cdr actions)))
(receiver name required optional rest auxiliary '() body))))))
+
+(define (list-has-duplicates? items)
+ (and (not (null? items))
+ (if (memq (car items) (cdr items))
+ true
+ (list-has-duplicates? (cdr items)))))
\f
(define ((dispatch-0 op-name clambda-op clexpr-op xlambda-op) lambda)
((cond ((slambda? lambda) clambda-op)
(define-integrable (slambda-name slambda)
(vector-ref (&pair-cdr slambda) 0))
+(define (slambda-auxiliary slambda)
+ (let ((bound (&pair-cdr slambda)))
+ (subvector->list bound 1 (vector-length bound))))
+
(define-integrable (slambda-body slambda)
(&pair-car slambda))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.9 1989/10/26 06:46:43 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.10 1990/09/11 20:44:54 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
;;; package: (runtime pretty-printer)
(declare (usual-integrations))
-\f
+
(define (initialize-package!)
(set! forced-indentation (special-printer kernel/forced-indentation))
(set! pressured-indentation (special-printer kernel/pressured-indentation))
(or (and (procedure? object) (procedure-lambda object))
object))))))
-(define (pretty-print object #!optional port as-code?)
- (let ((port (if (default-object? port) (current-output-port) port)))
+(define (pretty-print object #!optional port as-code? indentation)
+ (let ((port (if (default-object? port) (current-output-port) port))
+ (indentation (if (default-object? indentation) 0 indentation)))
(if (scode-constant? object)
(pp-top-level object
port
- (if (default-object? as-code?) false as-code?))
+ (if (default-object? as-code?) false as-code?)
+ indentation)
(pp-top-level (let ((sexp (unsyntax object)))
(if (and *named-lambda->define?*
(pair? sexp)
`(DEFINE ,@(cdr sexp))
sexp))
port
- true)))
+ true
+ indentation)))
unspecific)
-(define (pp-top-level expression port as-code?)
+(define (pp-top-level expression port as-code? indentation)
(fluid-let
((x-size (get-x-size port))
(output-port port)
(operation/write-char (output-port/operation/write-char port))
(operation/write-string (output-port/operation/write-string port)))
(let ((node (numerical-walk expression)))
- ((if as-code? print-node print-non-code-node) node 0 0)
+ (if (positive? indentation)
+ (*unparse-string (make-string indentation #\Space)))
+ ((if as-code? print-node print-non-code-node) node indentation 0)
(output-port/flush-output port))))
(define (stepper-pp expression port p-wrapper table nc relink! sc! offset)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.73 1990/08/21 04:18:57 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.74 1990/09/11 20:45:03 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
hardware-trap-frame/print-stack
hardware-trap-frame/code
microcode-return/code->type
+ microcode-return/name->type
stack-frame->continuation
stack-frame-type/code
stack-frame-type/compiled-return-address
stack-frame/next
stack-frame/next-subproblem
stack-frame/offset
+ stack-frame/previous-type
stack-frame/properties
stack-frame/reductions
stack-frame/ref
print-user-friendly-name
show-environment-bindings
show-environment-name
+ show-environment-procedure
show-frame
show-frames
write-dbg-name)
(export (runtime emacs-interface)
+ hook/debugger-failure
+ hook/debugger-message
hook/presentation)
(initialization (initialize-package!)))
(parent ())
(initialization (initialize-package!)))
+(define-package (runtime procedure)
+ (files "uproc")
+ (parent ())
+ (export ()
+ apply-hook-extra
+ apply-hook-procedure
+ apply-hook?
+ compiled-closure->entry
+ compiled-closure/ref
+ compiled-closure/set!
+ compiled-closure?
+ compiled-procedure?
+ compound-procedure?
+ entity-extra
+ entity-procedure
+ entity?
+ implemented-primitive-procedure?
+ make-apply-hook
+ make-entity
+ make-primitive-procedure
+ primitive-procedure-name
+ primitive-procedure?
+ procedure-arity
+ procedure-arity-valid?
+ procedure-components
+ procedure-environment
+ procedure-lambda
+ procedure?
+ set-apply-hook-extra!
+ set-apply-hook-procedure!
+ set-entity-extra!
+ set-entity-procedure!)
+ (export (runtime continuation-parser)
+ compiled-procedure-frame-size))
+
(define-package (runtime environment)
(files "uenvir")
(parent ())
&triple-set-third!
&triple-third
&typed-pair-cons
- &typed-triple-cons))
+ &typed-triple-cons)
+ (export (runtime debugging-info)
+ &pair-car
+ &pair-cdr
+ &triple-first
+ &triple-second
+ &triple-third
+ &vector-ref))
(define-package (runtime scode-scan)
(files "scan")
(parent ())
(export ()
unsyntax
- unsyntax-lambda-list)
+ unsyntax-lambda-list
+ unsyntax-with-substitutions)
(initialization (initialize-package!)))
(define-package (runtime working-directory)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 14.12 1990/07/03 19:47:57 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 14.13 1990/09/11 20:45:14 cph Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(FLUID-LET ,syntax/fluid-let)
(LOCAL-DECLARE ,syntax/local-declare)
(NAMED-LAMBDA ,syntax/named-lambda)
- (SCODE-QUOTE ,syntax/scode-quote)
- (DYNAMIC-STATE-LET ,syntax/dynamic-state-let)))
+ (SCODE-QUOTE ,syntax/scode-quote)))
table))
\f
;;;; Top Level Syntaxers
(make-combination (syntax-expression (car expression))
(syntax-expressions (cdr expression))))))
((symbol? expression)
+ (if (syntax-table-ref *syntax-table* expression)
+ (error "syntactic keyword referenced as variable" expression))
(make-variable expression))
(else
expression)))
((invert-expression (syntax-expression name)) (expand-binding-value rest)))
(define (syntax/define pattern . rest)
- (cond ((symbol? pattern)
- (make-definition pattern
- (expand-binding-value
- (if (and (= (length rest) 2)
- (string? (cadr rest)))
- (list (car rest))
- rest))))
- ((pair? pattern)
- (expand-lambda pattern rest
- (lambda (pattern body)
- (make-definition (car pattern)
- (make-named-lambda (car pattern) (cdr pattern)
- body)))))
- (else
- (syntax-error "bad pattern" pattern))))
+ (let ((make-definition
+ (lambda (name value)
+ (if (syntax-table-ref *syntax-table* name)
+ (syntax-error "redefinition of syntactic keyword" name))
+ (make-definition name value))))
+ (cond ((symbol? pattern)
+ (make-definition
+ pattern
+ (let ((value
+ (expand-binding-value
+ (if (and (= (length rest) 2)
+ (string? (cadr rest)))
+ (list (car rest))
+ rest))))
+ (if (lambda? value)
+ (lambda-components* value
+ (lambda (name required optional rest body)
+ (if (eq? name lambda-tag:unnamed)
+ (make-lambda* pattern required optional rest body)
+ value)))
+ value))))
+ ((pair? pattern)
+ (expand-lambda pattern rest
+ (lambda (pattern body)
+ (make-definition (car pattern)
+ (make-named-lambda (car pattern) (cdr pattern)
+ body)))))
+ (else
+ (syntax-error "bad pattern" pattern)))))
(define (syntax/begin . actions)
(syntax-sequence actions))
(if (symbol? name-or-pattern)
(syntax-bindings pattern-or-first
(lambda (names values)
+ (if (memq name-or-pattern names)
+ (syntax-error "name conflicts with binding"
+ name-or-pattern))
(make-combination
(make-letrec (list name-or-pattern)
(list (make-named-lambda name-or-pattern names
(syntax-error "name of lambda expression must be a symbol" name))
(parse-lambda-list pattern
(lambda (required optional rest)
+ (for-each guarantee-parameter-not-syntactic-keyword required)
+ (for-each guarantee-parameter-not-syntactic-keyword optional)
+ (if rest (guarantee-parameter-not-syntactic-keyword rest))
(internal-make-lambda name required optional rest body))))
(define (make-closed-block tag names values body)
- (make-combination (internal-make-lambda tag names '() '() body)
- values))
+ (for-each guarantee-parameter-not-syntactic-keyword names)
+ (make-combination (internal-make-lambda tag names '() false body) values))
(define (make-letrec names values body)
+ (for-each guarantee-parameter-not-syntactic-keyword names)
(make-closed-block lambda-tag:let '() '()
(make-scode-sequence
(append! (map make-definition names values)
(list body)))))
+(define (guarantee-parameter-not-syntactic-keyword name)
+ (if (syntax-table-ref *syntax-table* name)
+ (syntax-error "rebinding syntactic keyword" name)))
+
(define-integrable lambda-tag:unnamed
(string->symbol "#[unnamed-procedure]"))
(else (bad-lambda-list pattern)))))
(define (finish rest)
- (receiver (reverse! (car required))
- (reverse! (car optional))
- rest))
+ (let ((required (reverse! (car required)))
+ (optional (reverse! (car optional))))
+ (do ((parameters
+ (append required optional (if rest (list rest) '()))
+ (cdr parameters)))
+ ((null? parameters))
+ (if (memq (car parameters) (cdr parameters))
+ (syntax-error "lambda list has duplicate parameters"
+ lambda-list)))
+ (receiver required optional rest)))
(define (bad-lambda-list pattern)
- (syntax-error "illegally-formed lambda-list" pattern))
+ (syntax-error "illegally-formed lambda list" pattern))
(parse-parameters required lambda-list)))
-\f
+
;;;; Scan Defines
(define (make-sequence/scan actions)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.14 1990/08/21 04:19:05 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.15 1990/09/11 20:45:26 cph Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(and (compiled-code-address? object)
(eq? (compiled-entry-type object) 'COMPILED-EXPRESSION)))
-(define (compiled-procedure? object)
- (and (compiled-code-address? object)
- (eq? (compiled-entry-type object) 'COMPILED-PROCEDURE)))
-
(define (compiled-return-address? object)
(and (compiled-code-address? object)
(eq? (compiled-entry-type object) 'COMPILED-RETURN-ADDRESS)))
-(define (compiled-closure? object)
- (and (compiled-procedure? object)
- (compiled-code-block/manifest-closure?
- (compiled-code-address->block object))))
-
(define-primitives
- (compiled-closure->entry 1)
(stack-address-offset 1)
(compiled-code-address->block 1)
(compiled-code-address->offset 1))
((1) 'COMPILED-RETURN-ADDRESS)
((2) 'COMPILED-EXPRESSION)
(else 'COMPILED-ENTRY)))
-\f
-(define (compiled-procedure-arity object)
- (let ((info ((ucode-primitive compiled-entry-kind 1) object)))
- (if (not (= (system-hunk3-cxr0 info) 0))
- (error "COMPILED-PROCEDURE-ARITY: bad compiled procedure" object))
- ;; max = (-1)^tail? * (1 + req + opt + tail?)
- ;; min = (1 + req)
- (cons (-1+ (system-hunk3-cxr1 info))
- (let ((max (system-hunk3-cxr2 info)))
- (and (not (negative? max))
- (-1+ max))))))
-
-(define (compiled-procedure-frame-size procedure)
- (let ((info ((ucode-primitive compiled-entry-kind 1) procedure)))
- (if (not (= (system-hunk3-cxr0 info) 0))
- (error "COMPILED-PROCEDURE-FRAME-SIZE: bad compiled procedure"
- procedure))
- (let ((max (system-hunk3-cxr2 info)))
- ;; max = (-1)^tail? * (1 + req + opt + tail?)
- ;; frame = req + opt + tail?
- (if (negative? max)
- (- -1 max)
- (-1+ max)))))
(define (compiled-continuation/next-continuation-offset entry)
(let ((offset
(if (negative? index)
(error "Stack address out of range" address start-offset))
index))
-
-;; In the following two procedures, offset can be #f to support
-;; old-style 68020 closures. When offset is not #f, it works on all
-;; architectures.
-
-(define (compiled-closure/ref closure index offset)
- (if (not offset)
- ((ucode-primitive primitive-object-ref 2) closure (+ 2 index))
- ((ucode-primitive primitive-object-ref 2)
- ((ucode-primitive compiled-code-address->block 1)
- closure)
- (+ index offset))))
-
-(define-integrable (compiled-closure/set! closure index offset value)
- (if (not offset)
- ((ucode-primitive primitive-object-set! 3) closure (+ 2 index) value)
- ((ucode-primitive primitive-object-set! 3)
- ((ucode-primitive compiled-code-address->block 1)
- closure)
- (+ index offset)
- value))
- unspecific)
\f
;;;; Compiled Code Blocks
(else
(cons (car aux-list)
(filter-potentially-dangerous (cdr aux-list)))))))
-\f
+
;;;; Promises
(define-integrable (promise? object)
(error "Promise already forced" promise))
(if (promise-non-expression? promise)
(error "Promise has no environment" promise))
- (system-pair-car promise))
-\f
-;;;; Procedures
-
-(define-integrable (primitive-procedure? object)
- (object-type? (ucode-type primitive) object))
-
-(define (guarantee-primitive-procedure object)
- (if (not (primitive-procedure? object))
- (error "Not a primitive procedure" object))
- object)
-
-(define (make-primitive-procedure name #!optional arity)
- (let ((arity (if (default-object? arity) false arity)))
- (let ((result ((ucode-primitive get-primitive-address) name arity)))
- (if (not (or (object-type? (ucode-type primitive) result)
- (eq? arity true)))
- (if (false? result)
- (error "MAKE-PRIMITIVE-PROCEDURE: unknown name" name)
- (error "MAKE-PRIMITIVE-PROCEDURE: inconsistent arity" name
- (error-irritant/noise " new:") arity
- (error-irritant/noise " old:") result)))
- result)))
-
-(define (implemented-primitive-procedure? object)
- ((ucode-primitive get-primitive-address) (primitive-procedure-name object)
- false))
-
-(define (primitive-procedure-name primitive)
- (intern
- ((ucode-primitive get-primitive-name)
- (guarantee-primitive-procedure primitive))))
-
-(define (compound-procedure? object)
- (or (object-type? (ucode-type procedure) object)
- (object-type? (ucode-type extended-procedure) object)))
-
-(define (guarantee-compound-procedure object)
- (if (not (compound-procedure? object))
- (error "Not a compound procedure" object))
- object)
-
-(define-integrable (compound-procedure-lambda procedure)
- (system-pair-car procedure))
-
-(define-integrable (compound-procedure-environment procedure)
- (system-pair-cdr procedure))
-
-(define-integrable (make-entity procedure extra)
- (system-pair-cons (ucode-type entity) procedure extra))
-
-(define-integrable (entity? object)
- (object-type? (ucode-type entity) object))
-
-(define-integrable (entity-procedure entity)
- (system-pair-car entity))
-
-(define-integrable (entity-extra entity)
- (system-pair-cdr entity))
-
-(define-integrable (set-entity-procedure! entity procedure)
- (system-pair-set-car! entity procedure)
- unspecific)
-
-(define-integrable (set-entity-extra! entity extra)
- (system-pair-set-car! entity extra)
- unspecific)
-\f
-(define (procedure? object)
- (or (compound-procedure? object)
- (primitive-procedure? object)
- (compiled-procedure? object)
- (and (entity? object)
- (procedure? (entity-procedure object)))))
-
-(define (discriminate-procedure object if-primitive if-compound if-compiled)
- (let loop ((procedure object))
- (cond ((primitive-procedure? procedure) (if-primitive procedure))
- ((compound-procedure? procedure) (if-compound procedure))
- ((compiled-procedure? procedure) (if-compiled procedure))
- ((entity? procedure) (loop (entity-procedure procedure)))
- (else (error "Not a procedure" object)))))
-
-(define (procedure-lambda object)
- (discriminate-procedure
- object
- (lambda (procedure) procedure false)
- compound-procedure-lambda
- compiled-procedure/lambda))
-
-(define (procedure-environment object)
- (discriminate-procedure
- object
- (lambda (procedure)
- (error "Primitive procedures have no closing environment" procedure))
- compound-procedure-environment
- compiled-procedure/environment))
-
-(define (procedure-components object receiver)
- (discriminate-procedure
- object
- (lambda (procedure)
- (error "Primitive procedures have no components" procedure))
- (lambda (procedure)
- (receiver (compound-procedure-lambda procedure)
- (compound-procedure-environment procedure)))
- (lambda (procedure)
- (receiver (compiled-procedure/lambda procedure)
- (compiled-procedure/environment procedure)))))
-
-(define (procedure-arity object)
- (discriminate-procedure
- object
- (lambda (procedure)
- (let ((arity (primitive-procedure-arity procedure)))
- (if (negative? arity)
- (cons 0 false)
- (cons arity arity))))
- (lambda (procedure)
- (lambda-components (compound-procedure-lambda procedure)
- (lambda (name required optional rest auxiliary decl body)
- name auxiliary decl body
- (let ((r (length required)))
- (cons r
- (and (not rest)
- (+ r (length optional))))))))
- compiled-procedure-arity))
-
-(define (procedure-arity-valid? procedure n-arguments)
- (let ((arity (procedure-arity procedure)))
- (and (<= (car arity) n-arguments)
- (if (cdr arity)
- (<= n-arguments (cdr arity))
- true))))
\ No newline at end of file
+ (system-pair-car promise))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.19 1990/08/21 04:19:12 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.20 1990/09/11 20:45:35 cph Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(define (ic-environment->external environment)
(let ((procedure (select-procedure environment)))
- (if (internal-lambda? (compound-procedure-lambda procedure))
- (compound-procedure-environment procedure)
+ (if (internal-lambda? (procedure-lambda procedure))
+ (procedure-environment procedure)
environment)))
(define-integrable (select-extension environment)
object)))
(define (select-parent environment)
- (compound-procedure-environment (select-procedure environment)))
+ (procedure-environment (select-procedure environment)))
(define (select-lambda environment)
- (compound-procedure-lambda (select-procedure environment)))
+ (procedure-lambda (select-procedure environment)))
(define (ic-environment/extension environment)
(select-extension (ic-environment->external environment)))
(error "Illegal procedure parent block" parent)))))))
\f
(define (stack-ccenv/has-parent? environment)
- (dbg-block/parent (stack-ccenv/block environment)))
+ (if (dbg-block/parent (stack-ccenv/block environment))
+ true
+ 'SIMULATED))
(define (stack-ccenv/parent environment)
(let ((block (stack-ccenv/block environment)))
(let ((parent (dbg-block/parent block)))
- (case (dbg-block/type parent)
- ((STACK)
- (let loop
- ((block block)
- (frame (stack-ccenv/frame environment))
- (index
- (+ (stack-ccenv/start-index environment)
- (vector-length (dbg-block/layout-vector block)))))
- (let ((stack-link (dbg-block/stack-link block)))
- (cond ((not stack-link)
- (with-values
- (lambda ()
- (stack-frame/resolve-stack-address
- frame
- (stack-ccenv/static-link environment)))
- (lambda (frame index)
- (let ((block (dbg-block/parent block)))
- (if (eq? block parent)
- (make-stack-ccenv parent frame index)
- (loop block frame index))))))
- ((eq? stack-link parent)
- (make-stack-ccenv parent frame index))
- (else
- (loop stack-link
- frame
- (+ (vector-length
- (dbg-block/layout-vector stack-link))
- (case (dbg-block/type stack-link)
- ((STACK)
- 0)
- ((CONTINUATION)
- (dbg-continuation/offset
- (dbg-block/procedure stack-link)))
- (else
- (error "illegal stack-link type" stack-link)))
- index)))))))
- ((CLOSURE)
- (make-closure-ccenv (dbg-block/original-parent block)
- parent
- (stack-ccenv/normal-closure environment)))
- ((IC)
- (guarantee-ic-environment
- (if (dbg-block/static-link-index block)
- (stack-ccenv/static-link environment)
- (compiled-code-block/environment
- (compiled-code-address->block
- (stack-frame/return-address
- (stack-ccenv/frame environment)))))))
- (else
- (error "illegal parent block" parent))))))
+ (if parent
+ (case (dbg-block/type parent)
+ ((STACK)
+ (let loop
+ ((block block)
+ (frame (stack-ccenv/frame environment))
+ (index
+ (+ (stack-ccenv/start-index environment)
+ (vector-length (dbg-block/layout-vector block)))))
+ (let ((stack-link (dbg-block/stack-link block)))
+ (cond ((not stack-link)
+ (with-values
+ (lambda ()
+ (stack-frame/resolve-stack-address
+ frame
+ (stack-ccenv/static-link environment)))
+ (lambda (frame index)
+ (let ((block (dbg-block/parent block)))
+ (if (eq? block parent)
+ (make-stack-ccenv parent frame index)
+ (loop block frame index))))))
+ ((eq? stack-link parent)
+ (make-stack-ccenv parent frame index))
+ (else
+ (loop stack-link
+ frame
+ (+ (vector-length
+ (dbg-block/layout-vector stack-link))
+ (case (dbg-block/type stack-link)
+ ((STACK)
+ 0)
+ ((CONTINUATION)
+ (dbg-continuation/offset
+ (dbg-block/procedure stack-link)))
+ (else
+ (error "illegal stack-link type" stack-link)))
+ index)))))))
+ ((CLOSURE)
+ (make-closure-ccenv (dbg-block/original-parent block)
+ parent
+ (stack-ccenv/normal-closure environment)))
+ ((IC)
+ (guarantee-ic-environment
+ (if (dbg-block/static-link-index block)
+ (stack-ccenv/static-link environment)
+ (compiled-code-block/environment
+ (compiled-code-address->block
+ (stack-frame/return-address
+ (stack-ccenv/frame environment)))))))
+ (else
+ (error "illegal parent block" parent)))
+ (let ((environment
+ (compiled-code-block/environment
+ (compiled-code-address->block
+ (stack-frame/return-address
+ (stack-ccenv/frame environment))))))
+ (if (ic-environment? environment)
+ environment
+ system-global-environment))))))
\f
(define (stack-ccenv/lambda environment)
(dbg-block/source-code (stack-ccenv/block environment)))
index)))
(define (closure-ccenv/has-parent? environment)
- (let ((stack-block (closure-ccenv/stack-block environment)))
- (let ((parent (dbg-block/parent stack-block)))
- (and parent
- (case (dbg-block/type parent)
- ((CLOSURE) (dbg-block/original-parent stack-block))
- ((STACK IC) true)
- (else (error "Illegal parent block" parent)))))))
+ (or (let ((stack-block (closure-ccenv/stack-block environment)))
+ (let ((parent (dbg-block/parent stack-block)))
+ (and parent
+ (case (dbg-block/type parent)
+ ((CLOSURE) (dbg-block/original-parent stack-block))
+ ((STACK IC) true)
+ (else (error "Illegal parent block" parent))))))
+ 'SIMULATED))
(define (closure-ccenv/parent environment)
(let ((stack-block (closure-ccenv/stack-block environment))
(closure-block (closure-ccenv/closure-block environment))
(closure (closure-ccenv/closure environment)))
- (let ((parent (dbg-block/parent stack-block)))
- (case (dbg-block/type parent)
- ((STACK)
- (make-closure-ccenv parent closure-block closure))
- ((CLOSURE)
- (make-closure-ccenv (dbg-block/original-parent stack-block)
- closure-block
- closure))
- ((IC)
- (guarantee-ic-environment
- (let ((index (dbg-block/ic-parent-index closure-block)))
- (if index
- (closure/get-value closure closure-block index)
- (compiled-code-block/environment
- (compiled-entry/block closure))))))
- (else
- (error "Illegal parent block" parent))))))
+ (let ((parent (dbg-block/parent stack-block))
+ (use-simulation
+ (lambda ()
+ (let ((environment
+ (compiled-code-block/environment
+ (compiled-entry/block closure))))
+ (if (ic-environment? environment)
+ environment
+ system-global-environment)))))
+ (if parent
+ (case (dbg-block/type parent)
+ ((STACK)
+ (make-closure-ccenv parent closure-block closure))
+ ((CLOSURE)
+ (let ((parent (dbg-block/original-parent stack-block)))
+ (if parent
+ (make-closure-ccenv parent closure-block closure)
+ (use-simulation))))
+ ((IC)
+ (guarantee-ic-environment
+ (let ((index (dbg-block/ic-parent-index closure-block)))
+ (if index
+ (closure/get-value closure closure-block index)
+ (compiled-code-block/environment
+ (compiled-entry/block closure))))))
+ (else
+ (error "Illegal parent block" parent)))
+ (use-simulation)))))
(define (closure-ccenv/lambda environment)
(dbg-block/source-code (closure-ccenv/stack-block environment)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.15 1989/10/27 07:20:32 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.16 1990/09/11 20:45:45 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(*unparse-hex ((ucode-primitive primitive-object-datum 1) future)))))
(define (unparse/entity entity)
- (*unparse-with-brackets (if (continuation? entity) 'CONTINUATION 'ENTITY)
+ (*unparse-with-brackets (cond ((continuation? entity) 'CONTINUATION)
+ ((apply-hook? entity) 'APPLY-HOOK)
+ (else 'ENTITY))
entity
false))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 14.8 1990/06/14 01:27:54 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 14.9 1990/09/11 20:45:54 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define unsyntaxer:show-comments?
false)
+(define substitutions '())
+
+(define (unsyntax-with-substitutions scode alist)
+ (if (not (alist? alist))
+ (error "substitutions not an alist" alist))
+ (fluid-let ((substitutions alist))
+ (unsyntax scode)))
+
+(define (maybe-substitute object action)
+ (let ((association (has-substitution? object)))
+ (if association
+ (cdr association)
+ (action object))))
+
+(define-integrable (has-substitution? object)
+ (and (not (null? substitutions))
+ (assq object substitutions)))
+
(define (unsyntax scode)
(unsyntax-object (if (procedure? scode) (procedure-lambda scode) scode)))
(define (unsyntax-object object)
- ((scode-walk unsyntaxer/scode-walker object) object))
+ (maybe-substitute
+ object
+ (lambda (object) ((scode-walk unsyntaxer/scode-walker object) object))))
(define unsyntaxer/scode-walker)
(variable-name object))
(define (unsyntax-ACCESS-object object)
- `(ACCESS ,@(unexpand-access object true)))
-
-(define (unexpand-access object separate?)
- (if (and (access? object) separate?)
- (access-components object
- (lambda (environment name)
- `(,name ,@(unexpand-access environment
- (and separate? unsyntaxer:macroize?)))))
- `(,(unsyntax-object object))))
+ `(ACCESS ,@(unexpand-access object)))
+
+(define (unexpand-access object)
+ (let loop ((object object) (separate? true))
+ (if (and separate?
+ (access? object)
+ (not (has-substitution? object)))
+ (access-components object
+ (lambda (environment name)
+ `(,name ,@(loop environment unsyntaxer:macroize?))))
+ `(,(unsyntax-object object)))))
(define (unsyntax-DEFINITION-object definition)
(definition-components definition unexpand-definition))
`(SET! ,name ,@(unexpand-binding-value value)))))
(define (unexpand-definition name value)
- (if (and (lambda? value) unsyntaxer:macroize?)
+ (if (and unsyntaxer:macroize?
+ (lambda? value)
+ (not (has-substitution? value)))
(lambda-components** value
(lambda (lambda-name required optional rest body)
(if (eq? lambda-name name)
(lambda (text expression)
`(LOCAL-DECLARE ,text ,(unsyntax-object expression)))))
-(define (unsyntax-SEQUENCE-object sequence)
- (if unsyntaxer:macroize?
- `(BEGIN ,@(unsyntax-sequence sequence))
- (car (unsyntax-sequence sequence))))
-
-(define (unsyntax-sequence sequence)
- (cond ((not (sequence? sequence))
- (list (unsyntax-object sequence)))
- (unsyntaxer:macroize?
- (unsyntax-objects (sequence-actions sequence)))
- (else
- `((BEGIN
- ,@(unsyntax-objects (sequence-immediate-actions sequence)))))))
+(define (unsyntax-SEQUENCE-object seq)
+ `(BEGIN ,@(unsyntax-sequence-actions seq)))
-(define (unsyntax-OPEN-BLOCK-object open-block)
- (open-block-components open-block
- (lambda (auxiliary declarations expression)
+(define (unsyntax-sequence seq)
+ (if (sequence? seq)
(if unsyntaxer:macroize?
+ (unsyntax-sequence-actions seq)
+ `((BEGIN ,@(unsyntax-sequence-actions seq))))
+ (list (unsyntax-object seq))))
+
+(define (unsyntax-sequence-actions seq)
+ (let ((actions (sequence-immediate-actions seq)))
+ (let loop ((actions actions))
+ (if (null? actions)
+ '()
+ (let ((substitution (has-substitution? (car actions))))
+ (cond (substitution
+ (cons (cdr substitution)
+ (loop (cdr actions))))
+ ((and unsyntaxer:macroize?
+ (sequence? (car actions)))
+ (append (unsyntax-sequence-actions (car actions))
+ (loop (cdr actions))))
+ (else
+ (cons (unsyntax-object (car actions))
+ (loop (cdr actions))))))))))
+
+(define (unsyntax-OPEN-BLOCK-object open-block)
+ (if unsyntaxer:macroize?
+ (open-block-components open-block
+ (lambda (auxiliary declarations expression)
`(OPEN-BLOCK ,auxiliary
,declarations
- ,@(unsyntax-sequence expression))
- (unsyntax-SEQUENCE-object open-block)))))
+ ,@(unsyntax-sequence expression))))
+ (unsyntax-SEQUENCE-object open-block)))
(define (unsyntax-DELAY-object object)
`(DELAY ,(unsyntax-object (delay-expression object))))
(define (unsyntax-THE-ENVIRONMENT-object object)
object
`(THE-ENVIRONMENT))
-
+\f
(define (unsyntax-DISJUNCTION-object object)
`(OR ,@(disjunction-components object
(if unsyntaxer:macroize?
,@(if (disjunction? alternative)
(disjunction-components alternative unexpand-disjunction)
`(,(unsyntax-object alternative)))))
-\f
+
(define (unsyntax-CONDITIONAL-object conditional)
(conditional-components conditional
(if unsyntaxer:macroize?
((eq? consequent undefined-conditional-branch)
`(IF (,not ,(unsyntax-object predicate))
,(unsyntax-object alternative)))
- ((conditional? alternative)
+ ((and (conditional? alternative)
+ (not (has-substitution? alternative)))
`(COND ,@(unsyntax-cond-conditional predicate
consequent
alternative)))
,@(unsyntax-cond-alternative alternative)))
(define (unsyntax-cond-alternative alternative)
- (cond ((eq? alternative undefined-conditional-branch) '())
+ (cond ((eq? alternative undefined-conditional-branch)
+ '())
+ ((has-substitution? alternative)
+ =>
+ (lambda (substitution)
+ `((ELSE ,substitution))))
((disjunction? alternative)
(disjunction-components alternative unsyntax-cond-disjunction))
((conditional? alternative)
(conditional-components alternative unsyntax-cond-conditional))
- (else `((ELSE ,@(unsyntax-sequence alternative))))))
+ (else
+ `((ELSE ,@(unsyntax-sequence alternative))))))
(define (unexpand-conjunction predicate consequent)
- (if (conditional? consequent)
+ (if (and (conditional? consequent)
+ (not (has-substitution? consequent)))
`(,(unsyntax-object predicate)
,@(conditional-components consequent
(lambda (predicate consequent alternative)
(let ((ordinary-combination
(lambda ()
`(,(unsyntax-object operator) ,@(unsyntax-objects operands)))))
- (cond ((not unsyntaxer:macroize?)
+ (cond ((or (not unsyntaxer:macroize?)
+ (has-substitution? operator))
(ordinary-combination))
((and (or (eq? operator cons)
(absolute-reference-to? operator 'CONS))
(= (length operands) 2)
- (delay? (cadr operands)))
+ (delay? (cadr operands))
+ (not (has-substitution? (cadr operands))))
`(CONS-STREAM ,(unsyntax-object (car operands))
,(unsyntax-object
(delay-expression (cadr operands)))))
(define (unsyntax-let-binding name value)
`(,name ,@(unexpand-binding-value value)))
-
+\f
(define (rewrite-named-let expression)
(if (and (pair? expression)
(let ((expression (car expression)))
(cdr expression))
,@(cddr (caddr (car expression))))
expression))
-\f
+
(define (unsyntax-ERROR-COMBINATION-object combination)
(if unsyntaxer:macroize?
(unsyntax-error-like-form (combination-operands combination) 'ERROR)
(define (unsyntax-error-like-form operands name)
(cons* name
- (unsyntax-object (first operands))
+ (unsyntax-object (car operands))
(unsyntax-objects
(let loop ((irritants (cadr operands)))
(cond ((null? irritants) '())
+ ((has-substitution? irritants) (list irritants))
((and (combination? irritants)
(absolute-reference-to?
(combination-operator irritants)
(cons (car operands)
(loop (cadr operands)))))
(else
- ;; Actually, this is an error. But do something useful
- ;; here just in case it actually happens.
+ ;; Actually, this is an error. But do
+ ;; something useful here just in case it
+ ;; actually happens.
(list irritants)))))))
\f
(define (unsyntax/fluid-let names values body if-malformed)
(combination-components body
(lambda (operator operands)
- (cond ((or (absolute-reference-to? operator 'DYNAMIC-WIND)
- (and (variable? operator)
- (eq? (variable-name operator) 'DYNAMIC-WIND)))
+ ;; `fluid-let' expressions are complicated. Rather than scan
+ ;; the entire expresion to find out if it has any substitutable
+ ;; subparts, we just treat it as malformed if there are active
+ ;; substitutions.
+ (cond ((not (null? substitutions))
+ (if-malformed))
+ ((and (or (absolute-reference-to? operator 'DYNAMIC-WIND)
+ (and (variable? operator)
+ (eq? (variable-name operator) 'DYNAMIC-WIND)))
+ (pair? operands)
+ (lambda? (car operands))
+ (pair? (cdr operands))
+ (lambda? (cadr operands))
+ (pair? (cddr operands))
+ (lambda? (caddr operands))
+ (null? (cdddr operands)))
(unsyntax/fluid-let/shallow names values operands))
((and (eq? operator (ucode-primitive with-saved-fluid-bindings 1))
(null? names)
(null? values)
(not (null? operands))
+ (lambda? (car operands))
(null? (cdr operands)))
(unsyntax/fluid-let/deep (car operands)))
(else
(lambda (operator operands)
(cond ((eq? operator lexical-assignment)
`(ACCESS ,(cadr operands)
- ,@(unexpand-access (car operands) true)))
+ ,@(unexpand-access (car operands))))
(else
(unsyntax-error 'FLUID-LET
"Unknown SCODE form"
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 14.7 1989/08/07 07:37:09 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 14.8 1990/09/11 20:46:01 cph Rel $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
(define (where #!optional environment)
- (let ((environment
- (if (default-object? environment)
- (nearest-repl/environment)
- (->environment environment))))
- (hook/repl-environment (nearest-repl) environment)
- (letter-commands command-set
- (cmdl-message/standard "Environment Inspector")
- "Where-->"
- (make-wstate (list environment)))))
+ (let ((wstate
+ (make-wstate
+ (list
+ (if (default-object? environment)
+ (nearest-repl/environment)
+ (->environment environment))))))
+ (letter-commands
+ command-set
+ (cmdl-message/active
+ (lambda ()
+ (show-current-frame wstate true)
+ (debugger-message
+ "You are now in the environment inspector. Type q to quit, ? for commands.")))
+ "Where-->"
+ wstate)))
(define-structure (wstate
(conc-name wstate/))
frame-list)
(define (initialize-package!)
- (set! command-set
- (make-command-set
- 'WHERE-COMMANDS
- `((#\? ,standard-help-command
- "Help, list command letters")
- (#\Q ,standard-exit-command
- "Quit (exit from Where)")
- (#\C ,show
- "Display the bindings in the current frame")
- (#\A ,show-all
- "Display the bindings of all the frames in the current chain")
- (#\P ,parent
- "Find the parent frame of the current one")
- (#\S ,son
- "Find the son of the current environment in the current chain")
- (#\W ,recursive-where
- "Eval an expression in the current frame and do WHERE on it")
- (#\V ,show-object
- "Eval expression in current frame")
- (#\E ,enter
- "Create a read-eval-print loop in the current environment")
- (#\N ,name
- "Name of procedure which created current environment")
- )))
+ (set!
+ command-set
+ (make-command-set
+ 'WHERE-COMMANDS
+ `((#\? ,standard-help-command
+ "help, list command letters")
+ (#\A ,show-all
+ "show All bindings in current environment and its ancestors")
+ (#\C ,show
+ "show bindings of identifiers in the Current environment")
+ (#\E ,enter
+ "Enter a read-eval-print loop in the current environment")
+ (#\O ,command/print-environment-procedure
+ "pretty print the procedure that created the current environment")
+ (#\P ,parent
+ "move to environment that is Parent of current environment")
+ (#\Q ,standard-exit-command
+ "Quit (exit environment inspector)")
+ (#\S ,son
+ "move to child of current environment (in current chain)")
+ (#\V ,show-object
+ "eValuate expression in current environment")
+ (#\W ,recursive-where
+ "enter environment inspector (Where) on the current environment")
+ )))
unspecific)
(define command-set)
(define (parent wstate)
(let ((frame-list (wstate/frame-list wstate)))
- (if (environment-has-parent? (car frame-list))
+ (if (eq? true (environment-has-parent? (car frame-list)))
(begin
(set-wstate/frame-list! wstate
(cons (environment-parent (car frame-list))
(set-wstate/frame-list! wstate (cdr frames))
(show-current-frame wstate true)))))
-(define (name wstate)
- (presentation
- (lambda ()
- (write-string "This frame was created by ")
- (print-user-friendly-name (car (wstate/frame-list wstate))))))
+(define (command/print-environment-procedure wstate)
+ (show-environment-procedure (car (wstate/frame-list wstate))))
(define (recursive-where wstate)
(let ((inp (prompt-for-expression "Object to evaluate and examine")))
(define (enter wstate)
(debug/read-eval-print (car (wstate/frame-list wstate))
- "You are now in the desired environment"
+ "the environment inspector"
+ "the desired environment"
"Eval-in-env-->"))
(define (show-object wstate)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.18 1990/08/25 03:08:22 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.19 1990/09/11 20:43:44 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
interrupt-mask history
previous-history-offset
previous-history-control-point
- offset %next))
+ offset previous-type %next))
(conc-name stack-frame/))
(type false read-only true)
(elements false read-only true)
(previous-history-offset false read-only true)
(previous-history-control-point false read-only true)
(offset false read-only true)
+ ;; PREVIOUS-TYPE is the stack-frame-type of the frame above this one
+ ;; on the stack (closer to the stack's top). In at least two cases
+ ;; we need to know this information.
+ (previous-type false read-only true)
;; %NEXT is either a parser-state object or the next frame. In the
;; former case, the parser-state is used to compute the next frame.
%next
(define (stack-frame/next stack-frame)
(let ((next (stack-frame/%next stack-frame)))
(if (parser-state? next)
- (let ((next (parse/start next)))
+ (let ((next (parse-one-frame next)))
(set-stack-frame/%next! stack-frame next)
next)
next)))
(element-stream false read-only true)
(n-elements false read-only true)
(next-control-point false read-only true)
- (allow-next-extended? false read-only true))
+ (previous-type false read-only true))
(define (continuation->stack-frame continuation)
- (parse/control-point (continuation/control-point continuation)
+ (parse-control-point (continuation/control-point continuation)
(continuation/dynamic-state continuation)
- (continuation/fluid-bindings continuation)))
-
-(define (parse/control-point control-point dynamic-state fluid-bindings)
- (and control-point
- (parse/start
- (make-parser-state
- dynamic-state
- fluid-bindings
- (control-point/interrupt-mask control-point)
- (history-transform (control-point/history control-point))
- (control-point/previous-history-offset control-point)
- (control-point/previous-history-control-point control-point)
- (control-point/element-stream control-point)
- (control-point/n-elements control-point)
- (control-point/next-control-point control-point)
- false))))
-
-(define (parse/start state)
+ (continuation/fluid-bindings continuation)
+ false))
+
+(define (parse-control-point control-point dynamic-state fluid-bindings type)
+ (parse-one-frame
+ (make-parser-state
+ dynamic-state
+ fluid-bindings
+ (control-point/interrupt-mask control-point)
+ (history-transform (control-point/history control-point))
+ (control-point/previous-history-offset control-point)
+ (control-point/previous-history-control-point control-point)
+ (control-point/element-stream control-point)
+ (control-point/n-elements control-point)
+ (control-point/next-control-point control-point)
+ type)))
+
+(define (parse-one-frame state)
(let ((stream (parser-state/element-stream state)))
(if (stream-pair? stream)
(let ((type
(return-address->stack-frame-type
(element-stream/head stream)
- (parser-state/allow-next-extended? state))))
+ (let ((type (parser-state/previous-type state)))
+ (and type
+ (1d-table/get (stack-frame-type/properties type)
+ allow-extended?-tag
+ false))))))
(let ((length
(let ((length (stack-frame-type/length type)))
(if (exact-nonnegative-integer? length)
((stack-frame-type/parser type)
type
(list->vector (stream-head stream length))
- (parse/next-state state length (stream-tail stream length)
- (stack-frame-type/allow-extended? type)))))
- (parse/control-point (parser-state/next-control-point state)
- (parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)))))
+ (make-intermediate-state state
+ length
+ (stream-tail stream length)))))
+ (let ((control-point (parser-state/next-control-point state)))
+ (and control-point
+ (parse-control-point control-point
+ (parser-state/dynamic-state state)
+ (parser-state/fluid-bindings state)
+ (parser-state/previous-type state)))))))
\f
-(define (parse/next-state state length stream allow-extended?)
+;;; `make-intermediate-state' is used to construct an intermediate
+;;; parser state that is passed to the frame parser. This
+;;; intermediate state is identical to `state' except that it shows
+;;; `length' items having been removed from the stream.
+
+(define (make-intermediate-state state length stream)
(let ((previous-history-control-point
(parser-state/previous-history-control-point state)))
(make-parser-state
(parser-state/history state)
(if previous-history-control-point
(parser-state/previous-history-offset state)
- (max (- (parser-state/previous-history-offset state) (-1+ length))
- 0))
+ (max 0 (- (parser-state/previous-history-offset state) (-1+ length))))
previous-history-control-point
stream
(- (parser-state/n-elements state) length)
(parser-state/next-control-point state)
- allow-extended?)))
-
-(define (make-frame type elements state element-stream n-elements)
- (let ((history-subproblem?
+ (parser-state/previous-type state))))
+
+;;; After each frame parser is done, it either tail recurses into the
+;;; parsing loop, or it calls `parser/standard' to produces a new
+;;; output frame. The argument `state' is usually what was passed to
+;;; the frame parser (i.e. the state that was returned by the previous
+;;; call to `make-intermediate-state'). However, several of the
+;;; parsers change the values of some of the components of `state'
+;;; before calling `parser/standard' -- for example,
+;;; RESTORE-TO-STATE-POINT changes the `dynamic-state' component.
+
+(define (parser/standard type elements state)
+ (let ((n-elements (parser-state/n-elements state))
+ (history-subproblem?
(stack-frame-type/history-subproblem? type))
(history (parser-state/history state))
(previous-history-offset (parser-state/previous-history-offset state))
(previous-history-control-point
(parser-state/previous-history-control-point state)))
- (make-stack-frame type
- elements
- (parser-state/dynamic-state state)
+ (make-stack-frame
+ type
+ elements
+ (parser-state/dynamic-state state)
+ (parser-state/fluid-bindings state)
+ (parser-state/interrupt-mask state)
+ (if (and history-subproblem? (stack-frame-type/subproblem? type))
+ history
+ undefined-history)
+ previous-history-offset
+ previous-history-control-point
+ (+ (vector-length elements) n-elements)
+ (parser-state/previous-type state)
+ (make-parser-state (parser-state/dynamic-state state)
+ (parser-state/fluid-bindings state)
+ (parser-state/interrupt-mask state)
+ (if history-subproblem?
+ (history-superproblem history)
+ history)
+ previous-history-offset
+ previous-history-control-point
+ (parser-state/element-stream state)
+ n-elements
+ (parser-state/next-control-point state)
+ type))))
+\f
+(define (parser/restore-dynamic-state type elements state)
+ ;; Possible problem: the dynamic state really consists of all of the
+ ;; state spaces in existence. Probably we should have some
+ ;; mechanism for keeping track of them all.
+ (parser/standard
+ type
+ elements
+ (make-parser-state (let ((dynamic-state (vector-ref elements 1)))
+ (if (eq? system-state-space
+ (state-point/space dynamic-state))
+ dynamic-state
+ (parser-state/dynamic-state state)))
(parser-state/fluid-bindings state)
(parser-state/interrupt-mask state)
- (if (and history-subproblem?
- (stack-frame-type/subproblem? type))
- history
- undefined-history)
- previous-history-offset
- previous-history-control-point
- (+ (vector-length elements) n-elements)
- (make-parser-state
- (parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
- (parser-state/interrupt-mask state)
- (if history-subproblem?
- (history-superproblem history)
- history)
- previous-history-offset
- previous-history-control-point
- element-stream
- n-elements
- (parser-state/next-control-point state)
- (stack-frame-type/allow-extended? type)))))
+ (parser-state/history state)
+ (parser-state/previous-history-offset state)
+ (parser-state/previous-history-control-point state)
+ (parser-state/element-stream state)
+ (parser-state/n-elements state)
+ (parser-state/next-control-point state)
+ (parser-state/previous-type state))))
-(define (element-stream/head stream)
- (if (not (stream-pair? stream)) (error "not a stream-pair" stream))
- (map-reference-trap (lambda () (stream-car stream))))
+(define (parser/restore-fluid-bindings type elements state)
+ (parser/standard
+ type
+ elements
+ (make-parser-state (parser-state/dynamic-state state)
+ (vector-ref elements 1)
+ (parser-state/interrupt-mask state)
+ (parser-state/history state)
+ (parser-state/previous-history-offset state)
+ (parser-state/previous-history-control-point state)
+ (parser-state/element-stream state)
+ (parser-state/n-elements state)
+ (parser-state/next-control-point state)
+ (parser-state/previous-type state))))
-(define-integrable (element-stream/ref stream index)
- (map-reference-trap (lambda () (stream-ref stream index))))
+(define (parser/restore-interrupt-mask type elements state)
+ (parser/standard
+ type
+ elements
+ (make-parser-state (parser-state/dynamic-state state)
+ (parser-state/fluid-bindingU state)
+ (vector-ref elements 1)
+ (parser-state/history state)
+ (parser-state/previous-history-offset state)
+ (parser-state/previous-history-control-point state)
+ (parser-state/element-stream state)
+ (parser-state/n-elements state)
+ (parser-state/next-control-point state)
+ (parser-state/previous-type state))))
+
+(define (parser/restore-history type elements state)
+ (parser/standard
+ type
+ elements
+ (make-parser-state (parser-state/dynamic-state state)
+ (parser-state/fluid-bindings state)
+ (parser-state/interrupt-mask state)
+ (history-transform (vector-ref elements 1))
+ (vector-ref elements 2)
+ (vector-ref elements 3)
+ (parser-state/element-stream state)
+ (parser-state/n-elements state)
+ (parser-state/next-control-point state)
+ (parser-state/previous-type state))))
\f
;;;; Unparser
(define (verify paranoia-index stream offset)
(or (zero? paranoia-index)
(stream-null? stream)
- (let* ((type (return-address->stack-frame-type
- (element-stream/head stream)
- false))
+ (let* ((type
+ (return-address->stack-frame-type (element-stream/head stream)
+ false))
(length
(let ((length (stack-frame-type/length type)))
(if (exact-nonnegative-integer? length)
((stream-pair? stream)
(stream-tail* (stream-cdr stream) (-1+ n)))
(else
- (error "stream-tail*: not a proper stream" stream))))
-\f
-;;;; Parsers
-
-(define (parser/standard-next type elements state)
- (make-frame type
- elements
- state
- (parser-state/element-stream state)
- (parser-state/n-elements state)))
-
-(define (make-restore-frame type
- elements
- state
- dynamic-state
- fluid-bindings
- interrupt-mask
- history
- previous-history-offset
- previous-history-control-point)
- (parser/standard-next
- type
- elements
- (make-parser-state dynamic-state
- fluid-bindings
- interrupt-mask
- history
- previous-history-offset
- previous-history-control-point
- (parser-state/element-stream state)
- (parser-state/n-elements state)
- (parser-state/next-control-point state)
- false)))
-\f
-(define (parser/restore-dynamic-state type elements state)
- (make-restore-frame type elements state
- ;; Possible problem: the dynamic state really
- ;; consists of all of the state spaces in
- ;; existence. Probably we should have some
- ;; mechanism for keeping track of them all.
- (let ((dynamic-state (vector-ref elements 1)))
- (if (eq? system-state-space
- (state-point/space dynamic-state))
- dynamic-state
- (parser-state/dynamic-state state)))
- (parser-state/fluid-bindings state)
- (parser-state/interrupt-mask state)
- (parser-state/history state)
- (parser-state/previous-history-offset state)
- (parser-state/previous-history-control-point state)))
+ (error "stream-tail*: not a proper stream" stream))))
-(define (parser/restore-fluid-bindings type elements state)
- (make-restore-frame type elements state
- (parser-state/dynamic-state state)
- (vector-ref elements 1)
- (parser-state/interrupt-mask state)
- (parser-state/history state)
- (parser-state/previous-history-offset state)
- (parser-state/previous-history-control-point state)))
-
-(define (parser/restore-interrupt-mask type elements state)
- (make-restore-frame type elements state
- (parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
- (vector-ref elements 1)
- (parser-state/history state)
- (parser-state/previous-history-offset state)
- (parser-state/previous-history-control-point state)))
+(define (element-stream/head stream)
+ (if (not (stream-pair? stream)) (error "not a stream-pair" stream))
+ (map-reference-trap (lambda () (stream-car stream))))
-(define (parser/restore-history type elements state)
- (make-restore-frame type elements state
- (parser-state/dynamic-state state)
- (parser-state/fluid-bindings state)
- (parser-state/interrupt-mask state)
- (history-transform (vector-ref elements 1))
- (vector-ref elements 2)
- (vector-ref elements 3)))
+(define-integrable (element-stream/ref stream index)
+ (map-reference-trap (lambda () (stream-ref stream index))))
\f
;;;; Stack Frame Types
(define-structure (stack-frame-type
(constructor make-stack-frame-type
- (code subproblem?
- history-subproblem?
+ (code subproblem? history-subproblem?
length parser))
(conc-name stack-frame-type/))
(code false read-only true)
(length false read-only true)
(parser false read-only true))
-(define allow-extended-return-addresses?-tag
- "stack-frame-type/allow-extended")
-
-(define (stack-frame-type/allow-extended? type)
- (1d-table/get
- (stack-frame-type/properties type)
- allow-extended-return-addresses?-tag
- false))
+(define allow-extended?-tag "stack-frame-type/allow-extended?")
(define (microcode-return/code->type code)
(if (not (< code (vector-length stack-frame-types)))
(error "return-code too large" code))
(vector-ref stack-frame-types code))
+(define (microcode-return/name->type name)
+ (microcode-return/code->type (microcode-return name)))
+
(define (return-address->stack-frame-type return-address allow-extended?)
(cond ((interpreter-return-address? return-address)
(let ((code (return-address/code return-address)))
(error "return-code has no type" code))
type)))
((compiled-return-address? return-address)
- (if (compiled-continuation/return-to-interpreter?
- return-address)
+ (if (compiled-continuation/return-to-interpreter? return-address)
stack-frame-type/return-to-interpreter
stack-frame-type/compiled-return-address))
((and allow-extended? (compiled-procedure? return-address))
(make-return-address (microcode-return 'REENTER-COMPILED-CODE)))
(set! stack-frame-types (make-stack-frame-types))
(set! stack-frame-type/hardware-trap
- (vector-ref stack-frame-types (microcode-return 'HARDWARE-TRAP)))
+ (microcode-return/name->type 'HARDWARE-TRAP))
(set! stack-frame-type/compiled-return-address
- (make-stack-frame-type false
- true
- false
+ (make-stack-frame-type false true false
length/compiled-return-address
- parser/standard-next))
+ parser/standard))
(set! stack-frame-type/return-to-interpreter
- (make-stack-frame-type false
- false
- true
+ (make-stack-frame-type false false true
1
- parser/standard-next))
+ parser/standard))
(set! stack-frame-type/interrupt-compiled-procedure
- (make-stack-frame-type false
- true
- false
+ (make-stack-frame-type false true false
length/interrupt-compiled-procedure
- parser/standard-next))
+ parser/standard))
(set! stack-frame-type/interrupt-compiled-expression
- (make-stack-frame-type false
- true
- false
+ (make-stack-frame-type false true false
1
- parser/standard-next))
+ parser/standard))
(set! word-size
(let ((initial (system-vector-length (make-bit-string 1 #f))))
(let loop ((size 2))
- (if (= (system-vector-length (make-bit-string size #f))
- initial)
+ (if (= (system-vector-length (make-bit-string size #f)) initial)
(loop (1+ size))
(-1+ size)))))
unspecific)
false
length
(if (default-object? parser)
- parser/standard-next
+ parser/standard
parser)))
(define (standard-subproblem name length)
true
true
length
- parser/standard-next))
+ parser/standard))
(standard-frame 'RESTORE-TO-STATE-POINT 2 parser/restore-dynamic-state)
(standard-frame 'RESTORE-FLUIDS 2 parser/restore-fluid-bindings)
(standard-subproblem 'COMBINATION-APPLY length)
(standard-subproblem 'INTERNAL-APPLY length)
(standard-subproblem 'INTERNAL-APPLY-VAL length))
-\f
+
(let ((compiler-frame
(lambda (name length)
- (stack-frame-type name false true length parser/standard-next)))
+ (stack-frame-type name false true length parser/standard)))
(compiler-subproblem
(lambda (name length)
- (stack-frame-type name true true length parser/standard-next))))
+ (stack-frame-type name true true length parser/standard))))
(let ((length (length/application-frame 4 0)))
(compiler-subproblem 'COMPILER-LOOKUP-APPLY-TRAP-RESTART length)
(compiler-subproblem 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART length))
- (let ((type
- (compiler-frame 'COMPILER-INTERRUPT-RESTART 3)))
+ (let ((type (compiler-frame 'COMPILER-INTERRUPT-RESTART 3)))
(1d-table/put! (stack-frame-type/properties type)
- allow-extended-return-addresses?-tag
+ allow-extended?-tag
true))
(compiler-frame 'COMPILER-LINK-CACHES-RESTART 8)
true
false
length/hardware-trap
- parser/standard-next)
+ parser/standard)
types))
\f
(arity (primitive-procedure-arity primitive))
(nargs
(if (negative? arity)
- (element-stream/ref stream hardware-trap/pc-info2-index)
+ (element-stream/ref stream
+ hardware-trap/pc-info2-index)
arity)))
(if (return-address? (element-stream/ref after-header nargs))
(+ hardware-trap/frame-size nargs)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.9 1990/02/20 16:15:16 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.10 1990/09/11 20:43:59 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(begin (write-string "a ")
(write-string rename)
(write-string " special form"))
- (begin (write-string "the procedure ")
+ (begin (write-string "the procedure: ")
(write-dbg-name name))))
(write-string "an unknown procedure"))))
+(define (show-environment-procedure environment)
+ (let ((scode-lambda (environment-lambda environment)))
+ (if scode-lambda
+ (presentation (lambda () (pretty-print scode-lambda)))
+ (debugger-failure "No procedure for this environment."))))
+
(define (write-dbg-name name)
(if (string? name) (write-string name) (write name)))
(debug/eval (prompt-for-expression "Evaluate expression")
environment)))
(if (undefined-value? value)
- (debugger-message "\n" ";No value")
- (debugger-message "\n" "Value: " value))))
+ (debugger-message "No value")
+ (debugger-message "Value: " value))))
(define (output-to-string length thunk)
(let ((x (with-output-to-truncated-string length thunk)))
(let loop ((environment environment) (depth depth))
(write-string "----------------------------------------")
(show-frame environment depth true)
- (if (environment-has-parent? environment)
+ (if (eq? true (environment-has-parent? environment))
(begin
(newline)
(newline)
(let ((package (environment->package environment)))
(if package
(begin
- (write-string "named ")
+ (write-string "named: ")
(write (package/name package)))
(begin
(write-string "created by ")
(environment-lookup environment name)))
names))))
(cond ((zero? n-bindings)
- (write-string "Has no bindings"))
+ (write-string " has no bindings"))
((and brief? (> n-bindings brief-bindings-limit))
- (write-string "Has ")
+ (write-string " has ")
(write n-bindings)
(write-string " bindings (first ")
(write brief-bindings-limit)
(write-string " shown):")
(finish (list-head names brief-bindings-limit)))
(else
- (write-string "Has bindings:")
+ (write-string " has bindings:")
(finish names))))))
(define brief-bindings-limit
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.11 1990/08/21 04:18:40 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.12 1990/09/11 20:44:34 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
+(define (stack-frame/debugging-info frame)
+ (let ((method
+ (stack-frame-type/debugging-info-method (stack-frame/type frame))))
+ (if (not method)
+ ;; (error "STACK-FRAME/DEBUGGING-INFO: missing method" frame)
+ (values (make-debugging-info/noise
+ (lambda (long?)
+ (with-output-to-string
+ (lambda ()
+ (display "Unknown (methodless) ")
+ (if long?
+ (pp frame)
+ (write frame))))))
+ undefined-environment
+ undefined-expression)
+ (method frame))))
+
(define (debugging-info/undefined-expression? expression)
(or (eq? expression undefined-expression)
(debugging-info/noise? expression)))
(define-integrable (debugging-info/undefined-environment? environment)
(eq? environment undefined-environment))
+(define-integrable (debugging-info/unknown-expression? expression)
+ (eq? expression unknown-expression))
+
(define-integrable (debugging-info/compiled-code? expression)
(eq? expression compiled-code))
-(define (stack-frame/debugging-info frame)
- (let ((method
- (1d-table/get (stack-frame-type/properties (stack-frame/type frame))
- method-tag
- false)))
- (if (not method)
- ;; (error "STACK-FRAME/DEBUGGING-INFO: missing method" frame)
- (values (make-debugging-info/noise
- (lambda (long?)
- (with-output-to-string
- (lambda ()
- (display "Unknown (methodless) ")
- (if long?
- (pp frame)
- (write frame))))))
- undefined-environment)
- (method frame))))
-
(define (make-evaluated-object object)
(if (scode-constant? object)
object
(define-integrable (debugging-info/evaluated-object-value expression)
(cdr expression))
-(define method-tag "stack-frame/debugging-info method")
+(define (validate-subexpression frame subexpression)
+ (if (eq? (stack-frame/previous-type frame) stack-frame-type/pop-return-error)
+ undefined-expression
+ subexpression))
+
(define undefined-expression "undefined expression")
(define undefined-environment "undefined environment")
+(define unknown-expression "unknown expression")
(define compiled-code "compiled code")
(define evaluated-object-tag "evaluated")
+(define stack-frame-type/pop-return-error)
\f
-(define (method/standard frame)
- (values (stack-frame/ref frame 1) (stack-frame/ref frame 2)))
-
(define (method/null frame)
frame
- (values undefined-expression undefined-environment))
-
-(define (method/expression-only frame)
- (values (stack-frame/ref frame 1) undefined-environment))
+ (values undefined-expression undefined-environment undefined-expression))
(define (method/environment-only frame)
- (values undefined-expression (stack-frame/ref frame 2)))
+ (values undefined-expression (stack-frame/ref frame 2) undefined-expression))
-(define (method/compiled-code frame)
- (values
- (let ((object
- (compiled-entry/dbg-object (stack-frame/return-address frame)))
- (lose (lambda () compiled-code)))
- (cond ((not object)
- (lose))
- ((dbg-continuation? object)
- (let ((source-code (dbg-continuation/source-code object)))
- (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))))
- ((dbg-procedure? object)
- (lambda-body (dbg-procedure/source-code object)))
- #|
- ((dbg-expression? object)
- ;; no expression!
- (lose))
- |#
- (else
- (lose))))
- (stack-frame/environment frame undefined-environment)))
+(define ((method/standard select-subexpression) frame)
+ (let ((expression (stack-frame/ref frame 1)))
+ (values expression
+ (stack-frame/ref frame 2)
+ (validate-subexpression frame (select-subexpression expression)))))
+
+(define ((method/expression-only select-subexpression) frame)
+ (let ((expression (stack-frame/ref frame 1)))
+ (values expression
+ undefined-environment
+ (validate-subexpression frame (select-subexpression expression)))))
(define (method/primitive-combination-3-first-operand frame)
- (values (stack-frame/ref frame 1) (stack-frame/ref frame 3)))
+ (let ((expression (stack-frame/ref frame 1)))
+ (values expression
+ (stack-frame/ref frame 3)
+ (validate-subexpression frame (&vector-ref expression 2)))))
+
+(define (method/combination-save-value frame)
+ (let ((expression (stack-frame/ref frame 1)))
+ (values expression
+ (stack-frame/ref frame 2)
+ (validate-subexpression
+ frame
+ (&vector-ref expression (1+ (stack-frame/ref frame 3)))))))
+
+(define (method/eval-error frame)
+ (values (stack-frame/ref frame 1)
+ (stack-frame/ref frame 2)
+ undefined-expression))
(define (method/force-snap-thunk frame)
- (values (%make-combination
- (ucode-primitive force 1)
- (list (make-evaluated-object (stack-frame/ref frame 1))))
- undefined-environment))
+ (let ((promise (stack-frame/ref frame 1)))
+ (values (%make-combination
+ (ucode-primitive force 1)
+ (list (make-evaluated-object promise)))
+ undefined-environment
+ (cond ((promise-forced? promise) undefined-expression)
+ ((promise-non-expression? promise) unknown-expression)
+ (else
+ (validate-subexpression frame
+ (promise-expression promise)))))))
(define ((method/application-frame index) frame)
(values (%make-combination
(make-evaluated-object (stack-frame/ref frame index))
(stack-frame-list frame (1+ index)))
- undefined-environment))
+ undefined-environment
+ undefined-expression))
\f
(define ((method/compiler-reference scode-maker) frame)
(values (scode-maker (stack-frame/ref frame 3))
- (stack-frame/ref frame 2)))
+ (stack-frame/ref frame 2)
+ undefined-expression))
(define ((method/compiler-assignment scode-maker) frame)
(values (scode-maker (stack-frame/ref frame 3)
(make-evaluated-object (stack-frame/ref frame 4)))
- (stack-frame/ref frame 2)))
+ (stack-frame/ref frame 2)
+ undefined-expression))
(define ((method/compiler-reference-trap scode-maker) frame)
(values (scode-maker (stack-frame/ref frame 2))
- (stack-frame/ref frame 3)))
+ (stack-frame/ref frame 3)
+ undefined-expression))
(define ((method/compiler-assignment-trap scode-maker) frame)
(values (scode-maker (stack-frame/ref frame 2)
(make-evaluated-object (stack-frame/ref frame 4)))
- (stack-frame/ref frame 3)))
+ (stack-frame/ref frame 3)
+ undefined-expression))
(define (method/compiler-lookup-apply-restart frame)
(values (%make-combination (stack-frame/ref frame 3)
(stack-frame-list frame 5))
- undefined-environment))
+ undefined-environment
+ undefined-expression))
(define (method/compiler-lookup-apply-trap-restart frame)
(values (%make-combination (make-variable (stack-frame/ref frame 2))
(stack-frame-list frame 6))
- (stack-frame/ref frame 3)))
+ (stack-frame/ref frame 3)
+ undefined-expression))
(define (stack-frame-list frame start)
(let ((end (stack-frame/length frame)))
(define (method/hardware-trap frame)
(values (make-debugging-info/noise (hardware-trap-noise frame))
- undefined-environment))
+ undefined-environment
+ undefined-expression))
(define ((hardware-trap-noise frame) long?)
(with-output-to-string
(lambda ()
(hardware-trap-frame/describe frame long?))))
\f
+(define (method/compiled-code frame)
+ (let ((environment (stack-frame/environment frame undefined-environment)))
+ (let ((object
+ (compiled-entry/dbg-object (stack-frame/return-address frame)))
+ (lose
+ (lambda ()
+ (values compiled-code environment undefined-expression))))
+ (cond ((not object)
+ (lose))
+ ((dbg-continuation? object)
+ (let ((source-code (dbg-continuation/source-code object)))
+ (if (and (vector? source-code)
+ (not (zero? (vector-length source-code))))
+ (let ((expression (vector-ref source-code 1)))
+ (let ((win
+ (lambda (select-subexpression)
+ (values
+ expression
+ environment
+ (validate-subexpression
+ frame
+ (select-subexpression expression))))))
+ (case (vector-ref source-code 0)
+ ((SEQUENCE-2-SECOND)
+ (win &pair-car))
+ ((ASSIGNMENT-CONTINUE
+ DEFINITION-CONTINUE)
+ (win &pair-cdr))
+ ((SEQUENCE-3-SECOND
+ CONDITIONAL-DECIDE)
+ (win &triple-first))
+ ((SEQUENCE-3-THIRD)
+ (win &triple-second))
+ ((COMBINATION-OPERAND)
+ (values
+ expression
+ environment
+ (validate-subexpression
+ frame
+ (list-ref (combination-operands expression)
+ (-1+ (vector-ref source-code 2))))))
+ (else
+ (lose)))))
+ (lose))))
+ ((dbg-procedure? object)
+ (values (lambda-body (dbg-procedure/source-code object))
+ environment
+ undefined-expression))
+ #|
+ ((dbg-expression? object)
+ ;; no expression!
+ (lose))
+ |#
+ (else
+ (lose))))))
+\f
(define (initialize-package!)
- (for-each (lambda (entry)
- (for-each (lambda (name)
- (let ((type
- (or (microcode-return/code->type
- (microcode-return name))
- (error "Missing return type" name))))
- (1d-table/put! (stack-frame-type/properties type)
- method-tag
- (car entry))))
- (cdr entry)))
- `((,method/standard
- ASSIGNMENT-CONTINUE
- COMBINATION-1-PROCEDURE
- COMBINATION-2-FIRST-OPERAND
- COMBINATION-2-PROCEDURE
- COMBINATION-SAVE-VALUE
- CONDITIONAL-DECIDE
- DEFINITION-CONTINUE
- DISJUNCTION-DECIDE
- EVAL-ERROR
- PRIMITIVE-COMBINATION-2-FIRST-OPERAND
- PRIMITIVE-COMBINATION-3-SECOND-OPERAND
- SEQUENCE-2-SECOND
- SEQUENCE-3-SECOND
- SEQUENCE-3-THIRD)
-
- (,method/null
- COMBINATION-APPLY
- GC-CHECK
- MOVE-TO-ADJACENT-POINT
- REENTER-COMPILED-CODE)
-
- (,method/expression-only
- ACCESS-CONTINUE
- IN-PACKAGE-CONTINUE
- PRIMITIVE-COMBINATION-1-APPLY
- PRIMITIVE-COMBINATION-2-APPLY
- PRIMITIVE-COMBINATION-3-APPLY)
-
- (,method/environment-only
- REPEAT-DISPATCH)
-
- (,method/primitive-combination-3-first-operand
- PRIMITIVE-COMBINATION-3-FIRST-OPERAND)
-
- (,method/force-snap-thunk
- FORCE-SNAP-THUNK)
-
- (,(method/application-frame 3)
- INTERNAL-APPLY)
-
- (,(method/application-frame 3)
- INTERNAL-APPLY-VAL)
-
- (,(method/application-frame 1)
- REPEAT-PRIMITIVE)
-
- (,(method/compiler-reference identity-procedure)
- COMPILER-REFERENCE-RESTART
- COMPILER-SAFE-REFERENCE-RESTART)
-
- (,(method/compiler-reference make-variable)
- COMPILER-ACCESS-RESTART)
-
- (,(method/compiler-reference make-unassigned?)
- COMPILER-UNASSIGNED?-RESTART)
-
- (,(method/compiler-reference
- (lambda (name)
- (%make-combination (ucode-primitive lexical-unbound?)
- (list (make-the-environment) name))))
- COMPILER-UNBOUND?-RESTART)
-
- (,(method/compiler-assignment make-assignment-from-variable)
- COMPILER-ASSIGNMENT-RESTART)
-
- (,(method/compiler-assignment make-definition)
- COMPILER-DEFINITION-RESTART)
-
- (,(method/compiler-reference-trap make-variable)
- COMPILER-REFERENCE-TRAP-RESTART
- COMPILER-SAFE-REFERENCE-TRAP-RESTART)
-
- (,(method/compiler-reference-trap make-unassigned?)
- COMPILER-UNASSIGNED?-TRAP-RESTART)
-
- (,(method/compiler-assignment-trap make-assignment)
- COMPILER-ASSIGNMENT-TRAP-RESTART)
-
- (,method/compiler-lookup-apply-restart
- COMPILER-LOOKUP-APPLY-RESTART)
-
- (,method/compiler-lookup-apply-trap-restart
- COMPILER-LOOKUP-APPLY-TRAP-RESTART
- COMPILER-OPERATOR-LOOKUP-TRAP-RESTART)
-
- (,method/hardware-trap
- HARDWARE-TRAP)))
- (for-each
- (lambda (type)
- (1d-table/put!
- (stack-frame-type/properties type)
- method-tag
- method/compiled-code))
- (list
- stack-frame-type/compiled-return-address
- stack-frame-type/interrupt-compiled-procedure
- stack-frame-type/interrupt-compiled-expression)))
\ No newline at end of file
+ (set! stack-frame-type/pop-return-error
+ (microcode-return/name->type 'POP-RETURN-ERROR))
+ (record-method 'COMBINATION-APPLY method/null)
+ (record-method 'GC-CHECK method/null)
+ (record-method 'MOVE-TO-ADJACENT-POINT method/null)
+ (record-method 'REENTER-COMPILED-CODE method/null)
+ (record-method 'REPEAT-DISPATCH method/environment-only)
+ (let ((method (method/standard &pair-car)))
+ (record-method 'DISJUNCTION-DECIDE method)
+ (record-method 'SEQUENCE-2-SECOND method))
+ (let ((method (method/standard &pair-cdr)))
+ (record-method 'ASSIGNMENT-CONTINUE method)
+ (record-method 'COMBINATION-1-PROCEDURE method)
+ (record-method 'DEFINITION-CONTINUE method))
+ (let ((method (method/standard &triple-first)))
+ (record-method 'CONDITIONAL-DECIDE method)
+ (record-method 'SEQUENCE-3-SECOND method))
+ (let ((method (method/standard &triple-second)))
+ (record-method 'COMBINATION-2-PROCEDURE method)
+ (record-method 'SEQUENCE-3-THIRD method))
+ (let ((method (method/standard &triple-third)))
+ (record-method 'COMBINATION-2-FIRST-OPERAND method)
+ (record-method 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND method))
+ (record-method 'PRIMITIVE-COMBINATION-3-SECOND-OPERAND
+ (method/standard &vector-fourth))
+ (let ((method (method/expression-only &pair-car)))
+ (record-method 'ACCESS-CONTINUE method)
+ (record-method 'IN-PACKAGE-CONTINUE method))
+ (record-method 'PRIMITIVE-COMBINATION-1-APPLY
+ (method/expression-only &pair-cdr))
+ (record-method 'PRIMITIVE-COMBINATION-2-APPLY
+ (method/expression-only &triple-second))
+ (record-method 'PRIMITIVE-COMBINATION-3-APPLY
+ (method/expression-only &vector-second))
+ (record-method 'COMBINATION-SAVE-VALUE method/combination-save-value)
+ (record-method 'PRIMITIVE-COMBINATION-3-FIRST-OPERAND
+ method/primitive-combination-3-first-operand)
+ (record-method 'EVAL-ERROR method/eval-error)
+ (record-method 'FORCE-SNAP-THUNK method/force-snap-thunk)
+ (let ((method (method/application-frame 3)))
+ (record-method 'INTERNAL-APPLY method)
+ (record-method 'INTERNAL-APPLY-VAL method))
+ (record-method 'REPEAT-PRIMITIVE (method/application-frame 1))
+ (let ((method (method/compiler-reference identity-procedure)))
+ (record-method 'COMPILER-REFERENCE-RESTART method)
+ (record-method 'COMPILER-SAFE-REFERENCE-RESTART method))
+ (record-method 'COMPILER-ACCESS-RESTART
+ (method/compiler-reference make-variable))
+ (record-method 'COMPILER-UNASSIGNED?-RESTART
+ (method/compiler-reference make-unassigned?))
+ (record-method 'COMPILER-UNBOUND?-RESTART
+ (method/compiler-reference
+ (lambda (name)
+ (%make-combination (ucode-primitive lexical-unbound?)
+ (list (make-the-environment) name)))))
+ (record-method 'COMPILER-ASSIGNMENT-RESTART
+ (method/compiler-assignment make-assignment-from-variable))
+ (record-method 'COMPILER-DEFINITION-RESTART
+ (method/compiler-assignment make-definition))
+ (let ((method (method/compiler-reference-trap make-variable)))
+ (record-method 'COMPILER-REFERENCE-TRAP-RESTART method)
+ (record-method 'COMPILER-SAFE-REFERENCE-TRAP-RESTART method))
+ (record-method 'COMPILER-UNASSIGNED?-TRAP-RESTART
+ (method/compiler-reference-trap make-unassigned?))
+ (record-method 'COMPILER-ASSIGNMENT-TRAP-RESTART
+ (method/compiler-assignment-trap make-assignment))
+ (record-method 'COMPILER-LOOKUP-APPLY-RESTART
+ method/compiler-lookup-apply-restart)
+ (record-method 'COMPILER-LOOKUP-APPLY-TRAP-RESTART
+ method/compiler-lookup-apply-trap-restart)
+ (record-method 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART
+ method/compiler-lookup-apply-trap-restart)
+ (record-method 'HARDWARE-TRAP method/hardware-trap)
+ (set-stack-frame-type/debugging-info-method!
+ stack-frame-type/compiled-return-address
+ method/compiled-code)
+ (set-stack-frame-type/debugging-info-method!
+ stack-frame-type/interrupt-compiled-procedure
+ method/compiled-code)
+ (set-stack-frame-type/debugging-info-method!
+ stack-frame-type/interrupt-compiled-expression
+ method/compiled-code))
+
+(define (&vector-second vector)
+ (&vector-ref vector 1))
+
+(define (&vector-fourth vector)
+ (&vector-ref vector 3))
+
+(define (record-method name method)
+ (set-stack-frame-type/debugging-info-method!
+ (microcode-return/name->type name)
+ method))
+
+(define-integrable (stack-frame-type/debugging-info-method type)
+ (1d-table/get (stack-frame-type/properties type) method-tag false))
+
+(define-integrable (set-stack-frame-type/debugging-info-method! type method)
+ (1d-table/put! (stack-frame-type/properties type) method-tag method))
+
+(define method-tag "stack-frame-type/debugging-info-method")
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.73 1990/08/21 04:18:57 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.74 1990/09/11 20:45:03 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
hardware-trap-frame/print-stack
hardware-trap-frame/code
microcode-return/code->type
+ microcode-return/name->type
stack-frame->continuation
stack-frame-type/code
stack-frame-type/compiled-return-address
stack-frame/next
stack-frame/next-subproblem
stack-frame/offset
+ stack-frame/previous-type
stack-frame/properties
stack-frame/reductions
stack-frame/ref
print-user-friendly-name
show-environment-bindings
show-environment-name
+ show-environment-procedure
show-frame
show-frames
write-dbg-name)
(export (runtime emacs-interface)
+ hook/debugger-failure
+ hook/debugger-message
hook/presentation)
(initialization (initialize-package!)))
(parent ())
(initialization (initialize-package!)))
+(define-package (runtime procedure)
+ (files "uproc")
+ (parent ())
+ (export ()
+ apply-hook-extra
+ apply-hook-procedure
+ apply-hook?
+ compiled-closure->entry
+ compiled-closure/ref
+ compiled-closure/set!
+ compiled-closure?
+ compiled-procedure?
+ compound-procedure?
+ entity-extra
+ entity-procedure
+ entity?
+ implemented-primitive-procedure?
+ make-apply-hook
+ make-entity
+ make-primitive-procedure
+ primitive-procedure-name
+ primitive-procedure?
+ procedure-arity
+ procedure-arity-valid?
+ procedure-components
+ procedure-environment
+ procedure-lambda
+ procedure?
+ set-apply-hook-extra!
+ set-apply-hook-procedure!
+ set-entity-extra!
+ set-entity-procedure!)
+ (export (runtime continuation-parser)
+ compiled-procedure-frame-size))
+
(define-package (runtime environment)
(files "uenvir")
(parent ())
&triple-set-third!
&triple-third
&typed-pair-cons
- &typed-triple-cons))
+ &typed-triple-cons)
+ (export (runtime debugging-info)
+ &pair-car
+ &pair-cdr
+ &triple-first
+ &triple-second
+ &triple-third
+ &vector-ref))
(define-package (runtime scode-scan)
(files "scan")
(parent ())
(export ()
unsyntax
- unsyntax-lambda-list)
+ unsyntax-lambda-list
+ unsyntax-with-substitutions)
(initialization (initialize-package!)))
(define-package (runtime working-directory)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.19 1990/08/21 04:19:12 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.20 1990/09/11 20:45:35 cph Rel $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(define (ic-environment->external environment)
(let ((procedure (select-procedure environment)))
- (if (internal-lambda? (compound-procedure-lambda procedure))
- (compound-procedure-environment procedure)
+ (if (internal-lambda? (procedure-lambda procedure))
+ (procedure-environment procedure)
environment)))
(define-integrable (select-extension environment)
object)))
(define (select-parent environment)
- (compound-procedure-environment (select-procedure environment)))
+ (procedure-environment (select-procedure environment)))
(define (select-lambda environment)
- (compound-procedure-lambda (select-procedure environment)))
+ (procedure-lambda (select-procedure environment)))
(define (ic-environment/extension environment)
(select-extension (ic-environment->external environment)))
(error "Illegal procedure parent block" parent)))))))
\f
(define (stack-ccenv/has-parent? environment)
- (dbg-block/parent (stack-ccenv/block environment)))
+ (if (dbg-block/parent (stack-ccenv/block environment))
+ true
+ 'SIMULATED))
(define (stack-ccenv/parent environment)
(let ((block (stack-ccenv/block environment)))
(let ((parent (dbg-block/parent block)))
- (case (dbg-block/type parent)
- ((STACK)
- (let loop
- ((block block)
- (frame (stack-ccenv/frame environment))
- (index
- (+ (stack-ccenv/start-index environment)
- (vector-length (dbg-block/layout-vector block)))))
- (let ((stack-link (dbg-block/stack-link block)))
- (cond ((not stack-link)
- (with-values
- (lambda ()
- (stack-frame/resolve-stack-address
- frame
- (stack-ccenv/static-link environment)))
- (lambda (frame index)
- (let ((block (dbg-block/parent block)))
- (if (eq? block parent)
- (make-stack-ccenv parent frame index)
- (loop block frame index))))))
- ((eq? stack-link parent)
- (make-stack-ccenv parent frame index))
- (else
- (loop stack-link
- frame
- (+ (vector-length
- (dbg-block/layout-vector stack-link))
- (case (dbg-block/type stack-link)
- ((STACK)
- 0)
- ((CONTINUATION)
- (dbg-continuation/offset
- (dbg-block/procedure stack-link)))
- (else
- (error "illegal stack-link type" stack-link)))
- index)))))))
- ((CLOSURE)
- (make-closure-ccenv (dbg-block/original-parent block)
- parent
- (stack-ccenv/normal-closure environment)))
- ((IC)
- (guarantee-ic-environment
- (if (dbg-block/static-link-index block)
- (stack-ccenv/static-link environment)
- (compiled-code-block/environment
- (compiled-code-address->block
- (stack-frame/return-address
- (stack-ccenv/frame environment)))))))
- (else
- (error "illegal parent block" parent))))))
+ (if parent
+ (case (dbg-block/type parent)
+ ((STACK)
+ (let loop
+ ((block block)
+ (frame (stack-ccenv/frame environment))
+ (index
+ (+ (stack-ccenv/start-index environment)
+ (vector-length (dbg-block/layout-vector block)))))
+ (let ((stack-link (dbg-block/stack-link block)))
+ (cond ((not stack-link)
+ (with-values
+ (lambda ()
+ (stack-frame/resolve-stack-address
+ frame
+ (stack-ccenv/static-link environment)))
+ (lambda (frame index)
+ (let ((block (dbg-block/parent block)))
+ (if (eq? block parent)
+ (make-stack-ccenv parent frame index)
+ (loop block frame index))))))
+ ((eq? stack-link parent)
+ (make-stack-ccenv parent frame index))
+ (else
+ (loop stack-link
+ frame
+ (+ (vector-length
+ (dbg-block/layout-vector stack-link))
+ (case (dbg-block/type stack-link)
+ ((STACK)
+ 0)
+ ((CONTINUATION)
+ (dbg-continuation/offset
+ (dbg-block/procedure stack-link)))
+ (else
+ (error "illegal stack-link type" stack-link)))
+ index)))))))
+ ((CLOSURE)
+ (make-closure-ccenv (dbg-block/original-parent block)
+ parent
+ (stack-ccenv/normal-closure environment)))
+ ((IC)
+ (guarantee-ic-environment
+ (if (dbg-block/static-link-index block)
+ (stack-ccenv/static-link environment)
+ (compiled-code-block/environment
+ (compiled-code-address->block
+ (stack-frame/return-address
+ (stack-ccenv/frame environment)))))))
+ (else
+ (error "illegal parent block" parent)))
+ (let ((environment
+ (compiled-code-block/environment
+ (compiled-code-address->block
+ (stack-frame/return-address
+ (stack-ccenv/frame environment))))))
+ (if (ic-environment? environment)
+ environment
+ system-global-environment))))))
\f
(define (stack-ccenv/lambda environment)
(dbg-block/source-code (stack-ccenv/block environment)))
index)))
(define (closure-ccenv/has-parent? environment)
- (let ((stack-block (closure-ccenv/stack-block environment)))
- (let ((parent (dbg-block/parent stack-block)))
- (and parent
- (case (dbg-block/type parent)
- ((CLOSURE) (dbg-block/original-parent stack-block))
- ((STACK IC) true)
- (else (error "Illegal parent block" parent)))))))
+ (or (let ((stack-block (closure-ccenv/stack-block environment)))
+ (let ((parent (dbg-block/parent stack-block)))
+ (and parent
+ (case (dbg-block/type parent)
+ ((CLOSURE) (dbg-block/original-parent stack-block))
+ ((STACK IC) true)
+ (else (error "Illegal parent block" parent))))))
+ 'SIMULATED))
(define (closure-ccenv/parent environment)
(let ((stack-block (closure-ccenv/stack-block environment))
(closure-block (closure-ccenv/closure-block environment))
(closure (closure-ccenv/closure environment)))
- (let ((parent (dbg-block/parent stack-block)))
- (case (dbg-block/type parent)
- ((STACK)
- (make-closure-ccenv parent closure-block closure))
- ((CLOSURE)
- (make-closure-ccenv (dbg-block/original-parent stack-block)
- closure-block
- closure))
- ((IC)
- (guarantee-ic-environment
- (let ((index (dbg-block/ic-parent-index closure-block)))
- (if index
- (closure/get-value closure closure-block index)
- (compiled-code-block/environment
- (compiled-entry/block closure))))))
- (else
- (error "Illegal parent block" parent))))))
+ (let ((parent (dbg-block/parent stack-block))
+ (use-simulation
+ (lambda ()
+ (let ((environment
+ (compiled-code-block/environment
+ (compiled-entry/block closure))))
+ (if (ic-environment? environment)
+ environment
+ system-global-environment)))))
+ (if parent
+ (case (dbg-block/type parent)
+ ((STACK)
+ (make-closure-ccenv parent closure-block closure))
+ ((CLOSURE)
+ (let ((parent (dbg-block/original-parent stack-block)))
+ (if parent
+ (make-closure-ccenv parent closure-block closure)
+ (use-simulation))))
+ ((IC)
+ (guarantee-ic-environment
+ (let ((index (dbg-block/ic-parent-index closure-block)))
+ (if index
+ (closure/get-value closure closure-block index)
+ (compiled-code-block/environment
+ (compiled-entry/block closure))))))
+ (else
+ (error "Illegal parent block" parent)))
+ (use-simulation)))))
(define (closure-ccenv/lambda environment)
(dbg-block/source-code (closure-ccenv/stack-block environment)))
projects / mit-scheme.git / commitdiff