From: Stephen Adams Date: Fri, 18 Aug 1995 23:54:03 +0000 (+0000) Subject: NEW-DBG-EXPRESSIONs now have a pointer to the scode for their X-Git-Tag: 20090517-FFI~6029 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5520d73d5186a6c79eba502788d7f3b01ae55b48;p=mit-scheme.git NEW-DBG-EXPRESSIONs now have a pointer to the scode for their containing combination. This is to assist in creating NEW-DBG-CONTINUATIONs for continuations that did not previously exist in the user's program. --- diff --git a/v8/src/compiler/midend/dbgstr.scm b/v8/src/compiler/midend/dbgstr.scm index 22f958fe6..efcb1b737 100644 --- a/v8/src/compiler/midend/dbgstr.scm +++ b/v8/src/compiler/midend/dbgstr.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: dbgstr.scm,v 1.16 1995/07/27 14:25:55 adams Exp $ +$Id: dbgstr.scm,v 1.17 1995/08/18 23:53:54 adams Exp $ Copyright (c) 1994-1995 Massachusetts Institute of Technology @@ -41,8 +41,8 @@ MIT in each case. |# ((ucode-primitive string->symbol) "#[(runtime compiler-info)new-dbg-expression]")) (conc-name new-dbg-expression/) - (constructor new-dbg-expression/make (source-code)) - (constructor new-dbg-expression/make2 (source-code block)) + (constructor new-dbg-expression/make (source-code outer)) + (constructor new-dbg-expression/make2 (source-code block outer)) (print-procedure (standard-unparser-method 'NEW-DBG-EXPRESSION (lambda (expr port) @@ -50,12 +50,14 @@ MIT in each case. |# (display (new-dbg-expression/source-code expr) port))))) (block false read-only false) (label false) - (source-code false)) + (source-code false) ; SCode + (outer false)) ; SCode countaining form, or #F (define (new-dbg-expression/new-block dbg-expr block*) (new-dbg-expression/make2 (new-dbg-expression/source-code dbg-expr) - block*)) + block* + (new-dbg-expression/outer dbg-expr))) (define-structure (new-dbg-procedure @@ -211,20 +213,29 @@ MIT in each case. |# element))))) (define (new-dbg-continuation->old-dbg-continuation label frame-size new-info) - frame-size + frame-size ; ignored (and new-info - (new-dbg-continuation/outer new-info) + ;;(new-dbg-continuation/outer new-info) (new-dbg-continuation/inner new-info) - (let ((aggregate - (new-dbg-expression/source-code - (new-dbg-continuation/outer new-info))) - (element - (new-dbg-expression/source-code - (new-dbg-continuation/inner new-info)))) - (set-new-dbg-continuation/label! new-info label) - (set-new-dbg-continuation/outer! new-info aggregate) - (set-new-dbg-continuation/inner! new-info element) - new-info))) + (let* ((element + (new-dbg-expression/source-code + (new-dbg-continuation/inner new-info))) + (aggregate + ;; This condition is true when a user level form has internal + ;; invisible continuations + (if (or (not (new-dbg-continuation/outer new-info)) + (eq? (new-dbg-continuation/outer new-info) + (new-dbg-continuation/inner new-info))) + (new-dbg-expression/outer + (new-dbg-continuation/inner new-info)) + (new-dbg-expression/source-code + (new-dbg-continuation/outer new-info))))) + (and aggregate + (begin + (set-new-dbg-continuation/label! new-info label) + (set-new-dbg-continuation/outer! new-info aggregate) + (set-new-dbg-continuation/inner! new-info element) + new-info))))) (define (new-dbg-form/block object) diff --git a/v8/src/compiler/midend/expand.scm b/v8/src/compiler/midend/expand.scm index e763deb70..c786031e9 100644 --- a/v8/src/compiler/midend/expand.scm +++ b/v8/src/compiler/midend/expand.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: expand.scm,v 1.5 1995/04/29 00:57:30 adams Exp $ +$Id: expand.scm,v 1.6 1995/08/18 23:53:47 adams Exp $ Copyright (c) 1994-1995 Massachusetts Institute of Technology @@ -97,7 +97,8 @@ MIT in each case. |# (expand/remember* new-form (new-dbg-expression/make2 false - (new-dbg-procedure/block info)))))) + (new-dbg-procedure/block info) + (new-dbg-procedure/outer info)))))) (define-expander LET (bindings body) (expand/let* expand/letify bindings body)) diff --git a/v8/src/compiler/midend/inlate.scm b/v8/src/compiler/midend/inlate.scm index 5340858a7..b9087dce6 100644 --- a/v8/src/compiler/midend/inlate.scm +++ b/v8/src/compiler/midend/inlate.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: inlate.scm,v 1.5 1995/07/08 15:01:34 adams Exp $ +$Id: inlate.scm,v 1.6 1995/08/18 23:54:03 adams Exp $ Copyright (c) 1994-1995 Massachusetts Institute of Technology @@ -38,19 +38,19 @@ MIT in each case. |# (declare (usual-integrations)) (define (inlate/top-level scode) - (inlate/remember (inlate/scode scode) - (new-dbg-expression/make scode))) + (inlate/remember (inlate/scode scode #F) + (new-dbg-expression/make scode #F))) (define-macro (define-inlator scode-type components . body) (let ((proc-name (symbol-append 'INLATE/ scode-type)) (destructor (symbol-append scode-type '-COMPONENTS))) - `(define ,proc-name - (let ((handler (lambda ,components ,@body))) - (named-lambda (,proc-name form) - (inlate/remember (,destructor form handler) - (new-dbg-expression/make form))))))) + `(DEFINE ,proc-name + (NAMED-LAMBDA (,proc-name FORM OUTER-FORM) + (LET ((HANDLER (LAMBDA ,components ,@body))) + (INLATE/REMEMBER (,destructor FORM HANDLER) + (NEW-DBG-EXPRESSION/MAKE FORM OUTER-FORM))))))) -(define (inlate/sequence+ form) +(define (inlate/sequence+ form outer-form) ;; Kludge (if (not (open-block? form)) (inlate/sequence form) @@ -59,11 +59,13 @@ MIT in each case. |# (if (sequence? form*) (beginnify (inlate/map-declarations - (map inlate/scode (sequence-actions form*)))) - (inlate/scode form*))) - (new-dbg-expression/make form)))) + (map (lambda (action) (inlate/scode action form)) + (sequence-actions form*)))) + (inlate/scode form* form))) + (new-dbg-expression/make form outer-form)))) -(define (inlate/constant object) +(define (inlate/constant object outer-form) + outer-form `(QUOTE ,(if (unassigned-reference-trap? object) %unassigned object))) (define (inlate/map-declarations exprs) @@ -80,15 +82,16 @@ MIT in each case. |# `(LOOKUP ,name)) (define-inlator ASSIGNMENT (name svalue) - `(SET! ,name ,(inlate/scode svalue))) + `(SET! ,name ,(inlate/scode svalue form))) (define-inlator DEFINITION (name svalue) - `(DEFINE ,name ,(inlate/scode svalue))) + `(DEFINE ,name ,(inlate/scode svalue form))) (define-inlator THE-ENVIRONMENT () `(THE-ENVIRONMENT)) -(define (inlate/lambda form) +(define (inlate/lambda form outer-form) + outer-form ; ignored (lambda-components form (lambda (name req opt rest aux decls sbody) name ; Not used @@ -105,7 +108,7 @@ MIT in each case. |# (cons '#!AUX aux)))) (new `(LAMBDA ,(cons (new-continuation-variable) lambda-list) - ,(let ((body (inlate/scode sbody))) + ,(let ((body (inlate/scode sbody #F))) (if (null? decls) body (beginnify @@ -134,8 +137,8 @@ MIT in each case. |# |# (define-inlator IN-PACKAGE (environment expression) - `(IN-PACKAGE ,(inlate/scode environment) - ,(inlate/scode expression))) + `(IN-PACKAGE ,(inlate/scode environment form) + ,(inlate/scode expression #F))) (define-inlator COMBINATION (rator rands) (let-syntax ((ucode-primitive @@ -153,31 +156,34 @@ MIT in each case. |# (not (null? (cdr rands))) (symbol? (cadr rands))) `(UNASSIGNED? ,(cadr rands)) - `(CALL ,(inlate/scode rator) + `(CALL ,(inlate/scode rator form) (QUOTE #F) ; continuation - ,@(map inlate/scode rands)))))) + ,@(map (lambda (rand) (inlate/scode rand form)) + rands)))))) (define-inlator COMMENT (text body) text ; ignored - (inlate/scode body)) + (inlate/scode body form)) (define-inlator SEQUENCE (actions) - (beginnify (map inlate/scode actions))) + (beginnify + (map (lambda (action) (inlate/scode action form)) + actions))) (define-inlator CONDITIONAL (pred conseq alt) - `(IF ,(inlate/scode pred) - ,(inlate/scode conseq) - ,(inlate/scode alt))) + `(IF ,(inlate/scode pred form) + ,(inlate/scode conseq form) + ,(inlate/scode alt form))) (define-inlator DISJUNCTION (pred alt) - `(OR ,(inlate/scode pred) - ,(inlate/scode alt))) + `(OR ,(inlate/scode pred form) + ,(inlate/scode alt form))) (define-inlator ACCESS (environment name) - `(ACCESS ,name ,(inlate/scode environment))) + `(ACCESS ,name ,(inlate/scode environment form))) (define-inlator DELAY (expression) - `(DELAY ,(inlate/scode expression))) + `(DELAY ,(inlate/scode expression form))) (define inlate/scode (let ((dispatch-vector @@ -187,8 +193,8 @@ MIT in each case. |# ((dispatch-entry (macro (type handler) `(VECTOR-SET! DISPATCH-VECTOR ,(microcode-type type) - (LAMBDA (EXPR) - (,handler EXPR)))))) + (LAMBDA (EXPR OUTER-FORM) + (,handler EXPR OUTER-FORM)))))) (let-syntax ((dispatch-entries @@ -220,9 +226,10 @@ MIT in each case. |# (dispatch-entries (lambda lexpr extended-lambda) inlate/lambda) (dispatch-entries (sequence-2 sequence-3) inlate/sequence+)) - (named-lambda (inlate/expression expression) + (named-lambda (inlate/expression expression outer-form) ((vector-ref dispatch-vector (object-type expression)) - expression))))) + expression + outer-form))))) ;; Utilities