Change the way first class environments are handled.

There is an extra phase at the front end which translates implicit
environment manipulation operations into explicit ones.

diff --git a/v7/src/compiler/machines/bobcat/dassm1.scm b/v7/src/compiler/machines/bobcat/dassm1.scm
index e08cb65612c02a8610ee3c4f54cdf03888461d14..8b04cb1ff56dec94a50b0f4d8260a72c4c25dcfd 100644 (file)
--- a/v7/src/compiler/machines/bobcat/dassm1.scm
+++ b/v7/src/compiler/machines/bobcat/dassm1.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.3 1988/03/14 19:15:45 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.4 1988/04/15 02:15:37 jinx Exp $
 
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -49,14 +49,36 @@ MIT in each case. |#
   (let ((pathname (->pathname filename)))
     (with-output-to-file (pathname-new-type pathname "lap")
       (lambda ()
-       (disassembler/write-compiled-code-block
-        (compiled-code-block/read-file (pathname-new-type pathname "com"))
-        (let ((pathname (pathname-new-type pathname "binf")))
-          (and (if (unassigned? symbol-table?)
-                   (file-exists? pathname)
-                   symbol-table?)
-               (compiler-info/symbol-table
-                (compiler-info/read-file pathname)))))))))
+       (let ((object (fasload (pathname-new-type pathname "com")))
+             (info (let ((pathname (pathname-new-type pathname "binf")))
+                     (and (if (unassigned? symbol-table?)
+                              (file-exists? pathname)
+                              symbol-table?)
+                          (fasload pathname)))))
+         (cond ((compiled-code-address? object)
+                (disassembler/write-compiled-code-block
+                 (compiled-code-address->block object)
+                 info
+                 false))
+               ((not (scode/comment? object))
+                (error "compiler:write-lap-file : Not a compiled file"
+                       (pathname-new-type pathname "com")))
+               (else
+                (scode/comment-components
+                 object
+                 (lambda (text expression)
+                   expression ;; ignored
+                   (if (and (pair? text)
+                            (eq? (car text) compiler-entries-tag)
+                            (vector? (cadr text)))
+                       (for-each disassembler/write-compiled-code-block
+                                 (vector->list (cadr text))
+                                 (if (false? info)
+                                     (make-list (vector-length (cadr text))
+                                                false)
+                                     (vector->list info)))
+                       (error "compiler:write-lap-file : Not a compiled file"
+                              (pathname-new-type pathname "com"))))))))))))
 
 (define disassembler/base-address)
 
@@ -65,15 +87,13 @@ MIT in each case. |#
     (fluid-let ((disassembler/write-offsets? true)
                (disassembler/write-addresses? true)
                (disassembler/base-address (primitive-datum the-block)))
-      (let ((info
-            (compiler-info/read-file
-             (system-vector-ref the-block
-                                (-  (system-vector-size the-block) 2)))))
-       (newline)
-       (newline)
-       (disassembler/write-compiled-code-block
-        the-block
-        (compiler-info/symbol-table info))))))
+      (newline)
+      (newline)
+      (disassembler/write-compiled-code-block
+       the-block
+       (->compiler-info
+       (system-vector-ref the-block
+                          (-  (system-vector-size the-block) 2)))))))
 \f
 ;;; Operations exported from the disassembler package
 
@@ -82,13 +102,31 @@ MIT in each case. |#
 (define disassembler/instructions/read)
 (define disassembler/lookup-symbol)
 
-(define (disassembler/write-compiled-code-block block symbol-table)
-  (write-string "Code:\n\n")
-  (disassembler/write-instruction-stream
-   symbol-table
-   (disassembler/instructions/compiled-code-block block symbol-table))
-  (write-string "\nConstants:\n\n")
-  (disassembler/write-constants-block block symbol-table))
+(define (write-block block)
+  (write-string "#[COMPILED-CODE-BLOCK ")
+  (write-string
+   (number->string (object-hash block) '(HEUR (RADIX D S))))
+  (write-string " ")
+  (write-string
+   (number->string (primitive-datum block) '(HEUR (RADIX X E))))
+  (write-string "]"))
+
+(define (disassembler/write-compiled-code-block block info #!optional page?)
+  (let ((symbol-table (compiler-info/symbol-table info)))
+    (if (or (unassigned? page?) page?)
+       (begin
+         (write-char #\page)
+         (newline)))
+    (write-string "Disassembly of ")
+    (write-block block)
+    (write-string ":\n")
+    (write-string "Code:\n\n")
+    (disassembler/write-instruction-stream
+     symbol-table
+     (disassembler/instructions/compiled-code-block block symbol-table))
+    (write-string "\nConstants:\n\n")
+    (disassembler/write-constants-block block symbol-table)
+    (newline)))
 
 (define (disassembler/instructions/compiled-code-block block symbol-table)
   (disassembler/instructions block
@@ -143,21 +181,26 @@ MIT in each case. |#
 
 (define (write-constant block symbol-table constant)
   (write-string (cdr (write-to-string constant 60)))
-  (if (lambda? constant)
-      (let ((expression (lambda-body constant)))
-       (if (and (compiled-code-address? expression)
-                (eq? (compiled-code-address->block expression) block))
-           (begin
-             (write-string "  (")
-             (let ((offset (compiled-code-address->offset expression)))
-               (let ((label (disassembler/lookup-symbol symbol-table offset)))
-                 (if label
-                     (write-string (string-downcase label))
-                     (write offset))))
-             (write-string ")"))))))
-
-)
-
+  (cond ((lambda? constant)
+        (let ((expression (lambda-body constant)))
+          (if (and (compiled-code-address? expression)
+                   (eq? (compiled-code-address->block expression) block))
+              (begin
+                (write-string "  (")
+                (let ((offset (compiled-code-address->offset expression)))
+                  (let ((label (disassembler/lookup-symbol symbol-table offset)))
+                    (if label
+                        (write-string (string-downcase label))
+                        (write offset))))
+                (write-string ")")))))
+       ((compiled-code-address? constant)
+        (write-string "  (offset ")
+        (write (compiled-code-address->offset constant))
+        (write-string " in ")
+        (write-block (compiled-code-address->block constant))
+        (write-string ")"))
+       (else false))))
+\f
 (define (disassembler/write-instruction symbol-table offset write-instruction)
   (if symbol-table
       (sorted-vector/for-each symbol-table offset

diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040
index 42b8ed2d3faa1955778023c339797a47dfb7497a..a98d493af23d2e5c3ad3b3e6125fed991fe505a6 100644 (file)
--- a/v7/src/compiler/machines/bobcat/make.scm-68040
+++ b/v7/src/compiler/machines/bobcat/make.scm-68040
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.8 1988/03/25 21:22:06 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.9 1988/04/15 02:16:39 jinx Exp $
 
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -44,11 +44,11 @@ MIT in each case. |#
     (make-environment
       (define :name "Liar (Bobcat 68020)")
       (define :version 4)
-      (define :modification 8)
+      (define :modification 9)
       (define :files)
 
       (define :rcs-header
-       "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.8 1988/03/25 21:22:06 cph Exp $")
+       "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.9 1988/04/15 02:16:39 jinx Exp $")
 
       (define :files-lists
        (list
@@ -117,7 +117,8 @@ MIT in each case. |#
                 ))
 
         (cons fg-generator-package
-              '("fggen/fggen.com"      ;SCode->flow-graph converter
+              '("fggen/canon.com"      ;SCode canonicalizer
+                "fggen/fggen.com"      ;SCode->flow-graph converter
                 "fggen/declar.com"     ;Declaration handling
                 ))