From be47847dcd7b73f23a0b07a4f5b00a3751e8b76d Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 11 Sep 1990 20:46:01 +0000 Subject: [PATCH] * Advice package now signals error if the user attempts to advise 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. --- v7/src/runtime/advice.scm | 57 +-- v7/src/runtime/conpar.scm | 368 ++++++++++---------- v7/src/runtime/dbgcmd.scm | 11 +- v7/src/runtime/dbgutl.scm | 26 +- v7/src/runtime/debug.scm | 687 +++++++++++++++++++++---------------- v7/src/runtime/emacs.scm | 40 ++- v7/src/runtime/framex.scm | 423 +++++++++++++---------- v7/src/runtime/lambda.scm | 147 ++++---- v7/src/runtime/pp.scm | 23 +- v7/src/runtime/runtime.pkg | 54 ++- v7/src/runtime/syntax.scm | 83 +++-- v7/src/runtime/udata.scm | 194 +---------- v7/src/runtime/uenvir.scm | 183 +++++----- v7/src/runtime/unpars.scm | 8 +- v7/src/runtime/unsyn.scm | 159 ++++++--- v7/src/runtime/where.scm | 89 ++--- v8/src/runtime/conpar.scm | 368 ++++++++++---------- v8/src/runtime/dbgutl.scm | 26 +- v8/src/runtime/framex.scm | 423 +++++++++++++---------- v8/src/runtime/runtime.pkg | 54 ++- v8/src/runtime/uenvir.scm | 183 +++++----- 21 files changed, 1990 insertions(+), 1616 deletions(-) diff --git a/v7/src/runtime/advice.scm b/v7/src/runtime/advice.scm index 0edc7a9ef..9b5ac7167 100644 --- a/v7/src/runtime/advice.scm +++ b/v7/src/runtime/advice.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -434,33 +434,38 @@ MIT in each case. |# ;;;; 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) diff --git a/v7/src/runtime/conpar.scm b/v7/src/runtime/conpar.scm index ff9eb51f9..072c2ade6 100644 --- a/v7/src/runtime/conpar.scm +++ b/v7/src/runtime/conpar.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -45,7 +45,7 @@ MIT in each case. |# 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) @@ -56,6 +56,10 @@ MIT in each case. |# (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 @@ -73,7 +77,7 @@ MIT in each case. |# (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))) @@ -141,35 +145,39 @@ MIT in each case. |# (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) @@ -178,13 +186,22 @@ MIT in each case. |# ((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))))))) -(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 @@ -194,53 +211,122 @@ MIT in each case. |# (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)))) + +(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)))) ;;;; Unparser @@ -325,9 +411,9 @@ MIT in each case. |# (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) @@ -346,90 +432,20 @@ MIT in each case. |# ((stream-pair? stream) (stream-tail* (stream-cdr stream) (-1+ n))) (else - (error "stream-tail*: not a proper stream" stream)))) - -;;;; 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))) - -(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)))) ;;;; 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) @@ -439,20 +455,16 @@ MIT in each case. |# (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))) @@ -461,8 +473,7 @@ MIT in each case. |# (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)) @@ -479,37 +490,28 @@ MIT in each case. |# (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) @@ -540,7 +542,7 @@ MIT in each case. |# false length (if (default-object? parser) - parser/standard-next + parser/standard parser))) (define (standard-subproblem name length) @@ -548,7 +550,7 @@ MIT in each case. |# 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) @@ -592,22 +594,21 @@ MIT in each case. |# (standard-subproblem 'COMBINATION-APPLY length) (standard-subproblem 'INTERNAL-APPLY length) (standard-subproblem 'INTERNAL-APPLY-VAL length)) - + (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) @@ -631,7 +632,7 @@ MIT in each case. |# true false length/hardware-trap - parser/standard-next) + parser/standard) types)) @@ -662,7 +663,8 @@ MIT in each case. |# (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) diff --git a/v7/src/runtime/dbgcmd.scm b/v7/src/runtime/dbgcmd.scm index 7ed546f11..7eb1228e4 100644 --- a/v7/src/runtime/dbgcmd.scm +++ b/v7/src/runtime/dbgcmd.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.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 @@ -121,10 +121,15 @@ MIT in each case. |# (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)))) diff --git a/v7/src/runtime/dbgutl.scm b/v7/src/runtime/dbgutl.scm index ed01a3ca3..40c1c47f4 100644 --- a/v7/src/runtime/dbgutl.scm +++ b/v7/src/runtime/dbgutl.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgutl.scm,v 14.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 @@ -45,10 +45,16 @@ MIT in each case. |# (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))) @@ -57,8 +63,8 @@ MIT in each case. |# (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))) @@ -72,7 +78,7 @@ MIT in each case. |# (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) @@ -95,7 +101,7 @@ MIT in each case. |# (let ((package (environment->package environment))) (if package (begin - (write-string "named ") + (write-string "named: ") (write (package/name package))) (begin (write-string "created by ") @@ -112,16 +118,16 @@ MIT in each case. |# (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 diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index 9df335c94..0e658760c 100644 --- a/v7/src/runtime/debug.scm +++ b/v7/src/runtime/debug.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -37,8 +37,11 @@ MIT in each case. |# (declare (usual-integrations)) -(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 @@ -47,23 +50,42 @@ MIT in each case. |# (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) @@ -74,18 +96,31 @@ MIT in each case. |# (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))) (define (initialize-package!) (set! @@ -93,110 +128,190 @@ MIT in each case. |# (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) -(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#")) + +(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"))))))) - + (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 () @@ -204,7 +319,7 @@ MIT in each case. |# (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))) @@ -212,33 +327,11 @@ MIT in each case. |# (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)) -;;;; 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) @@ -251,27 +344,13 @@ MIT in each case. |# (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) @@ -306,72 +385,44 @@ MIT in each case. |# (else ";undefined expression")))) -;;;; 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)))) - -;;;; 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 () @@ -393,20 +444,9 @@ MIT in each case. |# (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 @@ -418,14 +458,89 @@ MIT in each case. |# " 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))))) +;;;; 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"))))))) + ;;;; Environment motion and display (define (command/show-current-frame dstate) @@ -443,14 +558,14 @@ MIT in each case. |# (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))) @@ -458,7 +573,7 @@ MIT in each case. |# (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))))) @@ -473,7 +588,8 @@ MIT in each case. |# (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) @@ -522,7 +638,7 @@ MIT in each case. |# (write-string " Formatted output:") (newline) ((condition/reporter condition) condition port)))) - (debugger-failure "No error to report"))) + (debugger-failure "No error to report."))) ;;;; Advanced hacking commands @@ -549,7 +665,7 @@ MIT in each case. |# (unsyntax (dstate/expression dstate)) expression)) environment))) - (if print-return-values? + (if debugger:print-return-values? (begin (newline) (write-string "That evaluates to:") @@ -564,7 +680,8 @@ MIT in each case. |# (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) @@ -574,83 +691,63 @@ MIT in each case. |# (write (dstate/subproblem dstate)) (for-each (lambda (element) (newline) - (pretty-print element)) + (debugger-pp element 0)) (named-structure/description (dstate/subproblem dstate)))))) ;;;; 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)) ;;;; Utilities @@ -660,6 +757,12 @@ MIT in each case. |# (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)) @@ -682,7 +785,8 @@ MIT in each case. |# (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) @@ -692,4 +796,7 @@ MIT in each case. |# (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 diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm index d43c8b8f7..d098466f3 100644 --- a/v7/src/runtime/emacs.scm +++ b/v7/src/runtime/emacs.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -117,6 +117,30 @@ MIT in each case. |# ("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))) (define (emacs/error-decision) (transmit-signal-without-gc #\z) @@ -199,6 +223,8 @@ MIT in each case. |# (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) @@ -218,7 +244,9 @@ MIT in each case. |# (set! normal/^G-interrupt hook/^G-interrupt) (set! normal/set-working-directory-pathname! hook/set-working-directory-pathname!) - ;;(set! normal/presentation hook/presentation) + (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!)) @@ -244,7 +272,9 @@ MIT in each case. |# (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) @@ -264,6 +294,8 @@ MIT in each case. |# (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 diff --git a/v7/src/runtime/framex.scm b/v7/src/runtime/framex.scm index 7c5449668..45bfd998b 100644 --- a/v7/src/runtime/framex.scm +++ b/v7/src/runtime/framex.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.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 @@ -37,6 +37,23 @@ MIT in each case. |# (declare (usual-integrations)) +(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))) @@ -54,27 +71,12 @@ MIT in each case. |# (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 @@ -87,101 +89,108 @@ MIT in each case. |# (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) -(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)) (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))) @@ -193,119 +202,169 @@ MIT in each case. |# (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?)))) +(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)))))) + (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 diff --git a/v7/src/runtime/lambda.scm b/v7/src/runtime/lambda.scm index 7a79743f3..8fa99d703 100644 --- a/v7/src/runtime/lambda.scm +++ b/v7/src/runtime/lambda.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -54,7 +54,7 @@ MIT in each case. |# (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!) @@ -200,37 +200,31 @@ MIT in each case. |# (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) @@ -250,40 +244,46 @@ MIT in each case. |# (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) @@ -303,19 +303,19 @@ MIT in each case. |# (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)) @@ -333,27 +333,39 @@ MIT in each case. |# (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)))) ;;;; Generic Lambda @@ -363,6 +375,13 @@ MIT in each case. |# (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) @@ -391,6 +410,12 @@ MIT in each case. |# (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))))) (define ((dispatch-0 op-name clambda-op clexpr-op xlambda-op) lambda) ((cond ((slambda? lambda) clambda-op) @@ -440,6 +465,10 @@ MIT in each case. |# (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)) diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm index b185f66d2..3e3f13617 100644 --- a/v7/src/runtime/pp.scm +++ b/v7/src/runtime/pp.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.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 @@ -36,7 +36,7 @@ MIT in each case. |# ;;; package: (runtime pretty-printer) (declare (usual-integrations)) - + (define (initialize-package!) (set! forced-indentation (special-printer kernel/forced-indentation)) (set! pressured-indentation (special-printer kernel/pressured-indentation)) @@ -76,12 +76,14 @@ MIT in each case. |# (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) @@ -89,17 +91,20 @@ MIT in each case. |# `(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) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index f7bf69949..ccc798afb 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.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 @@ -313,6 +313,7 @@ MIT in each case. |# 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 @@ -327,6 +328,7 @@ MIT in each case. |# stack-frame/next stack-frame/next-subproblem stack-frame/offset + stack-frame/previous-type stack-frame/properties stack-frame/reductions stack-frame/ref @@ -398,10 +400,13 @@ MIT in each case. |# 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!))) @@ -442,6 +447,41 @@ MIT in each case. |# (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 ()) @@ -1668,7 +1708,14 @@ MIT in each case. |# &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") @@ -1938,7 +1985,8 @@ MIT in each case. |# (parent ()) (export () unsyntax - unsyntax-lambda-list) + unsyntax-lambda-list + unsyntax-with-substitutions) (initialization (initialize-package!))) (define-package (runtime working-directory) diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm index f7415e22c..f4a35daee 100644 --- a/v7/src/runtime/syntax.scm +++ b/v7/src/runtime/syntax.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -85,8 +85,7 @@ MIT in each case. |# (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)) ;;;; Top Level Syntaxers @@ -127,6 +126,8 @@ MIT in each case. |# (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))) @@ -285,21 +286,35 @@ MIT in each case. |# ((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)) @@ -379,6 +394,9 @@ MIT in each case. |# (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 @@ -613,18 +631,26 @@ MIT in each case. |# (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]")) @@ -671,15 +697,22 @@ MIT in each case. |# (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))) - + ;;;; Scan Defines (define (make-sequence/scan actions) diff --git a/v7/src/runtime/udata.scm b/v7/src/runtime/udata.scm index 0c7021a17..f9c81e7c5 100644 --- a/v7/src/runtime/udata.scm +++ b/v7/src/runtime/udata.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -83,21 +83,11 @@ MIT in each case. |# (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)) @@ -119,29 +109,6 @@ MIT in each case. |# ((1) 'COMPILED-RETURN-ADDRESS) ((2) 'COMPILED-EXPRESSION) (else 'COMPILED-ENTRY))) - -(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 @@ -159,28 +126,6 @@ MIT in each case. |# (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) ;;;; Compiled Code Blocks @@ -282,7 +227,7 @@ that you cannot just vector-ref into. (else (cons (car aux-list) (filter-potentially-dangerous (cdr aux-list))))))) - + ;;;; Promises (define-integrable (promise? object) @@ -311,137 +256,4 @@ that you cannot just vector-ref into. (error "Promise already forced" promise)) (if (promise-non-expression? promise) (error "Promise has no environment" promise)) - (system-pair-car promise)) - -;;;; 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) - -(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 diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm index 0eadd99ca..7c9aa56ca 100644 --- a/v7/src/runtime/uenvir.scm +++ b/v7/src/runtime/uenvir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.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 @@ -246,8 +246,8 @@ MIT in each case. |# (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) @@ -260,10 +260,10 @@ MIT in each case. |# 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))) @@ -339,61 +339,72 @@ MIT in each case. |# (error "Illegal procedure parent block" parent))))))) (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)))))) (define (stack-ccenv/lambda environment) (dbg-block/source-code (stack-ccenv/block environment))) @@ -543,35 +554,47 @@ MIT in each case. |# 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))) diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm index b7803aa80..1040ab2f9 100644 --- a/v7/src/runtime/unpars.scm +++ b/v7/src/runtime/unpars.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -554,6 +554,8 @@ MIT in each case. |# (*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 diff --git a/v7/src/runtime/unsyn.scm b/v7/src/runtime/unsyn.scm index 1d896c70d..39a200300 100644 --- a/v7/src/runtime/unsyn.scm +++ b/v7/src/runtime/unsyn.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -68,11 +68,31 @@ MIT in each case. |# (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) @@ -108,15 +128,17 @@ MIT in each case. |# (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)) @@ -127,7 +149,9 @@ MIT in each case. |# `(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) @@ -155,28 +179,41 @@ MIT in each case. |# (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)))) @@ -190,7 +227,7 @@ MIT in each case. |# (define (unsyntax-THE-ENVIRONMENT-object object) object `(THE-ENVIRONMENT)) - + (define (unsyntax-DISJUNCTION-object object) `(OR ,@(disjunction-components object (if unsyntaxer:macroize? @@ -204,7 +241,7 @@ MIT in each case. |# ,@(if (disjunction? alternative) (disjunction-components alternative unexpand-disjunction) `(,(unsyntax-object alternative))))) - + (define (unsyntax-CONDITIONAL-object conditional) (conditional-components conditional (if unsyntaxer:macroize? @@ -225,7 +262,8 @@ MIT in each case. |# ((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))) @@ -241,15 +279,22 @@ MIT in each case. |# ,@(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) @@ -320,12 +365,14 @@ MIT in each case. |# (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))))) @@ -363,7 +410,7 @@ MIT in each case. |# (define (unsyntax-let-binding name value) `(,name ,@(unexpand-binding-value value))) - + (define (rewrite-named-let expression) (if (and (pair? expression) (let ((expression (car expression))) @@ -389,7 +436,7 @@ MIT in each case. |# (cdr expression)) ,@(cddr (caddr (car expression)))) expression)) - + (define (unsyntax-ERROR-COMBINATION-object combination) (if unsyntaxer:macroize? (unsyntax-error-like-form (combination-operands combination) 'ERROR) @@ -397,10 +444,11 @@ MIT in each case. |# (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) @@ -412,21 +460,36 @@ MIT in each case. |# (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))))))) (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 @@ -457,7 +520,7 @@ MIT in each case. |# (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" diff --git a/v7/src/runtime/where.scm b/v7/src/runtime/where.scm index dc9b4186e..50d32372c 100644 --- a/v7/src/runtime/where.scm +++ b/v7/src/runtime/where.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -38,45 +38,52 @@ MIT in each case. |# (declare (usual-integrations)) (define (where #!optional environment) - (let ((environment - (if (default-object? environment) - (nearest-repl/environment) - (->environment environment)))) - (hook/repl-environment (nearest-repl) environment) - (letter-commands command-set - (cmdl-message/standard "Environment Inspector") - "Where-->" - (make-wstate (list environment))))) + (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) @@ -97,7 +104,7 @@ MIT in each case. |# (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)) @@ -114,11 +121,8 @@ MIT in each case. |# (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"))) @@ -127,7 +131,8 @@ MIT in each case. |# (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) diff --git a/v8/src/runtime/conpar.scm b/v8/src/runtime/conpar.scm index d2a8517e7..66c750838 100644 --- a/v8/src/runtime/conpar.scm +++ b/v8/src/runtime/conpar.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -45,7 +45,7 @@ MIT in each case. |# 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) @@ -56,6 +56,10 @@ MIT in each case. |# (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 @@ -73,7 +77,7 @@ MIT in each case. |# (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))) @@ -141,35 +145,39 @@ MIT in each case. |# (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) @@ -178,13 +186,22 @@ MIT in each case. |# ((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))))))) -(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 @@ -194,53 +211,122 @@ MIT in each case. |# (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)))) + +(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)))) ;;;; Unparser @@ -325,9 +411,9 @@ MIT in each case. |# (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) @@ -346,90 +432,20 @@ MIT in each case. |# ((stream-pair? stream) (stream-tail* (stream-cdr stream) (-1+ n))) (else - (error "stream-tail*: not a proper stream" stream)))) - -;;;; 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))) - -(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)))) ;;;; 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) @@ -439,20 +455,16 @@ MIT in each case. |# (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))) @@ -461,8 +473,7 @@ MIT in each case. |# (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)) @@ -479,37 +490,28 @@ MIT in each case. |# (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) @@ -540,7 +542,7 @@ MIT in each case. |# false length (if (default-object? parser) - parser/standard-next + parser/standard parser))) (define (standard-subproblem name length) @@ -548,7 +550,7 @@ MIT in each case. |# 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) @@ -592,22 +594,21 @@ MIT in each case. |# (standard-subproblem 'COMBINATION-APPLY length) (standard-subproblem 'INTERNAL-APPLY length) (standard-subproblem 'INTERNAL-APPLY-VAL length)) - + (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) @@ -631,7 +632,7 @@ MIT in each case. |# true false length/hardware-trap - parser/standard-next) + parser/standard) types)) @@ -662,7 +663,8 @@ MIT in each case. |# (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) diff --git a/v8/src/runtime/dbgutl.scm b/v8/src/runtime/dbgutl.scm index 1071767ba..9a47b8e9c 100644 --- a/v8/src/runtime/dbgutl.scm +++ b/v8/src/runtime/dbgutl.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.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 @@ -45,10 +45,16 @@ MIT in each case. |# (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))) @@ -57,8 +63,8 @@ MIT in each case. |# (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))) @@ -72,7 +78,7 @@ MIT in each case. |# (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) @@ -95,7 +101,7 @@ MIT in each case. |# (let ((package (environment->package environment))) (if package (begin - (write-string "named ") + (write-string "named: ") (write (package/name package))) (begin (write-string "created by ") @@ -112,16 +118,16 @@ MIT in each case. |# (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 diff --git a/v8/src/runtime/framex.scm b/v8/src/runtime/framex.scm index 8ce3c1221..68370c1fc 100644 --- a/v8/src/runtime/framex.scm +++ b/v8/src/runtime/framex.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.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 @@ -37,6 +37,23 @@ MIT in each case. |# (declare (usual-integrations)) +(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))) @@ -54,27 +71,12 @@ MIT in each case. |# (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 @@ -87,101 +89,108 @@ MIT in each case. |# (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) -(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)) (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))) @@ -193,119 +202,169 @@ MIT in each case. |# (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?)))) +(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)))))) + (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 diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 2f5d57c63..7e9f053d1 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.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 @@ -313,6 +313,7 @@ MIT in each case. |# 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 @@ -327,6 +328,7 @@ MIT in each case. |# stack-frame/next stack-frame/next-subproblem stack-frame/offset + stack-frame/previous-type stack-frame/properties stack-frame/reductions stack-frame/ref @@ -398,10 +400,13 @@ MIT in each case. |# 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!))) @@ -442,6 +447,41 @@ MIT in each case. |# (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 ()) @@ -1668,7 +1708,14 @@ MIT in each case. |# &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") @@ -1938,7 +1985,8 @@ MIT in each case. |# (parent ()) (export () unsyntax - unsyntax-lambda-list) + unsyntax-lambda-list + unsyntax-with-substitutions) (initialization (initialize-package!))) (define-package (runtime working-directory) diff --git a/v8/src/runtime/uenvir.scm b/v8/src/runtime/uenvir.scm index 98dfcc165..3f87848b8 100644 --- a/v8/src/runtime/uenvir.scm +++ b/v8/src/runtime/uenvir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.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 @@ -246,8 +246,8 @@ MIT in each case. |# (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) @@ -260,10 +260,10 @@ MIT in each case. |# 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))) @@ -339,61 +339,72 @@ MIT in each case. |# (error "Illegal procedure parent block" parent))))))) (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)))))) (define (stack-ccenv/lambda environment) (dbg-block/source-code (stack-ccenv/block environment))) @@ -543,35 +554,47 @@ MIT in each case. |# 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))) -- 2.25.1