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 35eb7f44ae7ce4eb6f3f610548a4a59724b43b26..b801b81439e9971fa464ae1bff30d5473304771d 100644 (file)
--- 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*))))
+
+
 \f
 (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))))
+  
+