From: Stephen Adams Date: Thu, 19 Jan 1995 04:55:13 +0000 (+0000) Subject: New procedures for X-Git-Tag: 20090517-FFI~6723 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2fe0ee72a018d26fb1c67e44656177edb0d3b6c2;p=mit-scheme.git New procedures for . Making new objects like old ones but with new fields . Copying and updating block structures --- diff --git a/v8/src/compiler/midend/dbgstr.scm b/v8/src/compiler/midend/dbgstr.scm index 35eb7f44a..b801b8143 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.7 1995/01/19 00:10:42 adams Exp $ +$Id: dbgstr.scm,v 1.8 1995/01/19 04:55:13 adams Exp $ Copyright (c) 1994 Massachusetts Institute of Technology @@ -35,23 +35,28 @@ MIT in each case. |# (declare (usual-integrations)) (define-structure - (new-dbg-expression - (conc-name new-dbg-expression/) - (constructor new-dbg-expression/make (expr)) - (constructor new-dbg-expression/make2 (expr block)) - (print-procedure - (standard-unparser-method 'NEW-DBG-EXPRESSION - (lambda (expr port) - (write-char #\Space port) - (display (new-dbg-expression/expr expr) port))))) + (new-dbg-expression + (conc-name new-dbg-expression/) + (constructor new-dbg-expression/make (expr)) + (constructor new-dbg-expression/make2 (expr block)) + (print-procedure + (standard-unparser-method 'NEW-DBG-EXPRESSION + (lambda (expr port) + (write-char #\Space port) + (display (new-dbg-expression/expr expr) port))))) (expr false read-only true) (block false read-only false)) + +(define (new-dbg-expression/new-block dbg-expr block*) + (new-dbg-expression/make2 (new-dbg-expression/expr dbg-expr) + block*)) + (define-structure - (new-dbg-procedure - (conc-name new-dbg-procedure/) - (constructor new-dbg-procedure/make (lam-expr lambda-list)) - (constructor new-dbg-procedure/%make)) + (new-dbg-procedure + (conc-name new-dbg-procedure/) + (constructor new-dbg-procedure/make (lam-expr lambda-list)) + (constructor new-dbg-procedure/%make)) (lam-expr false read-only true) (lambda-list false read-only true) (block false read-only false)) @@ -61,19 +66,32 @@ MIT in each case. |# (new-dbg-procedure/lambda-list dbg-proc) (new-dbg-procedure/block dbg-proc))) +(define (new-dbg-procedure/new-block dbg-proc block*) + (new-dbg-procedure/%make (new-dbg-procedure/lam-expr dbg-proc) + (new-dbg-procedure/lambda-list dbg-proc) + block*)) + (define-structure (new-dbg-continuation (conc-name new-dbg-continuation/) - (constructor new-dbg-continuation/make (type outer inner))) + (constructor new-dbg-continuation/make (type outer inner)) + (constructor new-dbg-continuation/%make)) (type false read-only true) (outer false read-only true) (inner false read-only true) (block false read-only false)) +(define (new-dbg-continuation/new-block dbg-cont block*) + (new-dbg-continuation/%make (new-dbg-continuation/type dbg-cont) + (new-dbg-continuation/outer dbg-cont) + (new-dbg-continuation/inner dbg-cont) + block*)) + (define-structure (new-dbg-variable (conc-name new-dbg-variable/) (constructor new-dbg-variable/make (name block)) + (constructor new-dbg-variable/%make (name expression block extra)) (print-procedure (standard-unparser-method 'NEW-DBG-VARIABLE (lambda (var port) @@ -88,24 +106,58 @@ MIT in each case. |# (block false read-only false) (extra false read-only false)) +(define (new-dbg-variable/new-expression&block variable expression* block*) + (new-dbg-variable/%make (new-dbg-variable/name variable) + expression* + block* + (new-dbg-variable/extra variable))) + (define-structure (new-dbg-block (conc-name new-dbg-block/) (constructor new-dbg-block/make (type parent)) + (constructor new-dbg-block/%make) (print-procedure (standard-unparser-method 'NEW-DBG-BLOCK (lambda (block port) (write-char #\Space port) (write (new-dbg-block/type block) port) - (write-string " vars:" port) - (for-each (lambda (var) - (write-char #\Space port) - (write (new-dbg-variable/name var) port)) - (new-dbg-block/variables block)))))) + (if (null? (new-dbg-block/variables block)) + (write-string " (no vars)") + (begin + (write-string " vars:" port) + (for-each (lambda (var) + (write-char #\Space port) + (write (new-dbg-variable/name var) port)) + (new-dbg-block/variables block)))))))) (type false read-only false) (variables '() read-only false) (parent false read-only false) (flattened false read-only false)) + +(define (new-dbg-block/copy-transforming expression-copier block) + ;; Copy entire environmnet model structure whilst transforming the + ;; variable expressions. + (define (new-variables variables block*) + (map (lambda (variable) + (new-dbg-variable/new-expression&block + variable + (expression-copier (new-dbg-variable/expression variable)) + block*)) + variables)) + (let copy-block ((block block)) + (and block + (let ((block* (new-dbg-block/%make + (new-dbg-block/type block) + '() + (copy-block (new-dbg-block/parent block)) + (new-dbg-block/flattened block)))) + (set-new-dbg-block/variables! + block* + (new-variables (new-dbg-block/variables block) block*)) + block*)))) + + (define (new-dbg-expression->old-dbg-expression label new-info) ;; The old info format does not contain source for expressions! @@ -168,4 +220,22 @@ MIT in each case. |# (define (new-dbg-block->old-dbg-block block) ;; For now block ; ignored - false) \ No newline at end of file + false) + + +(define (new-dbg-form/block object) + (cond ((new-dbg-expression? object) (new-dbg-expression/block object)) + ((new-dbg-procedure? object) (new-dbg-procedure/block object)) + ((new-dbg-continuation? object) (new-dbg-continuation/block object)) + (else (internal-error "Not a dbg expression or procedure" object)))) + +(define (new-dbg-form/new-block object block*) + (cond ((new-dbg-expression? object) + (new-dbg-expression/new-block object block*)) + ((new-dbg-procedure? object) + (new-dbg-procedure/new-block object block*)) + ((new-dbg-continuation? object) + (new-dbg-continuation/new-block object block*)) + (else (internal-error "Not a dbg expression or procedure" object)))) + +