From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 13 Mar 1987 04:14:48 +0000 (+0000)
Subject: Externs files now are dumped in an internal form rather than by
X-Git-Tag: 20090517-FFI~13673
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=80f1c82dca85b3290fa4a916fa64bc28f040213c;p=mit-scheme.git

Externs files now are dumped in an internal form rather than by
converting them to SCode first.  This speeds up the process of
re-interning them.

Also, `sf' now maintains a database which allows the user to
programmatically specify syntax table and global declarations on a
per-filename basis.  This is used to eliminate `using-syntax' and
`integrate-external' occurrences in each file.
---

diff --git a/v7/src/sf/cgen.scm b/v7/src/sf/cgen.scm
index a51ce050c..abc6177b3 100644
--- a/v7/src/sf/cgen.scm
+++ b/v7/src/sf/cgen.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/cgen.scm,v 3.1 1987/03/10 14:56:46 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/cgen.scm,v 3.2 1987/03/13 04:11:49 cph Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -34,8 +34,7 @@ MIT in each case. |#
 
 ;;;; SCode Optimizer: Generate SCode from Expression
 
-(declare (usual-integrations)
-	 (integrate-external (access integrations package/scode-optimizer)))
+(declare (usual-integrations))
 
 (define (cgen/external quotation)
   (fluid-let ((flush-declarations? true))
diff --git a/v7/src/sf/copy.scm b/v7/src/sf/copy.scm
index fae959a51..d0e5fcfae 100644
--- a/v7/src/sf/copy.scm
+++ b/v7/src/sf/copy.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 3.1 1987/03/10 14:57:17 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 3.2 1987/03/13 04:12:02 cph Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -34,12 +34,25 @@ MIT in each case. |#
 
 ;;;; SCode Optimizer: Copy Expression
 
-(declare (usual-integrations)
-	 (integrate-external (access integrations package/scode-optimizer)))
+(declare (usual-integrations))
 
-(define (copy/external block expression)
-  (fluid-let ((root-block block))
-    (copy/expression block (environment/make) expression)))
+(define root-block)
+
+(define (copy/external/intern block expression uninterned)
+  (fluid-let ((root-block block)
+	      (copy/variable/free copy/variable/free/intern)
+	      (copy/declarations copy/declarations/intern))
+    (copy/expression root-block
+		     (environment/rebind block (environment/make) uninterned)
+		     expression)))
+
+(define (copy/external/extern expression)
+  (fluid-let ((root-block (block/make false false))
+	      (copy/variable/free copy/variable/free/extern)
+	      (copy/declarations copy/declarations/extern))
+    (let ((expression
+	   (copy/expression root-block (environment/make) expression)))
+      (return-2 root-block expression))))
 
 (define (copy/expressions block environment expressions)
   (map (lambda (expression)
@@ -63,7 +76,102 @@ MIT in each case. |#
 		      (copy/expression block
 				       (environment/make)
 				       (quotation/expression quotation))))))
+
+(define (copy/block parent environment block)
+  (let ((result (block/make parent (block/safe? block)))
+	(old-bound (block/bound-variables block)))
+    (let ((new-bound
+	   (map (lambda (variable)
+		  (variable/make result (variable/name variable)))
+		old-bound)))
+      (let ((environment (environment/bind environment old-bound new-bound)))
+	(block/set-bound-variables! result new-bound)
+	(block/set-declarations!
+	 result
+	 (copy/declarations block environment (block/declarations block)))
+	(return-2 result environment)))))
+
+(define copy/variable/free)
+
+(define (copy/variable block environment variable)
+  (environment/lookup environment variable
+    identity-procedure
+    (copy/variable/free variable)))
+
+(define (copy/variable/free/intern variable)
+  (lambda ()
+    (let ((name (variable/name variable)))
+      (let loop ((block root-block))
+	(let ((variable* (variable/assoc name (block/bound-variables block))))
+	  (cond ((eq? variable variable*)
+		 variable)
+		((not (block/parent block))
+		 (error "Unable to find free variable during copy" name))
+		((not variable*)
+		 (loop (block/parent block)))
+		((block/safe? (variable/block variable*))
+		 (variable/set-name! variable* (rename-symbol name))
+		 (loop (block/parent block)))
+		(else
+		 (error "Integration requires renaming unsafe variable"
+			name))))))))
+
+(define (rename-symbol symbol)
+  (string->uninterned-symbol (symbol->string symbol)))
+
+(define (copy/variable/free/extern variable)
+  (lambda ()
+    (block/lookup-name root-block (variable/name variable))))
+
+(define copy/declarations)
+
+(define (copy/declarations/intern block environment declarations)
+  (if (null? declarations)
+      '()
+      (declarations/map declarations
+	(lambda (variable)
+	  (environment/lookup environment variable
+	    identity-procedure
+	    (lambda () variable)))
+	identity-procedure)))
 
+(define (copy/declarations/extern block environment declarations)
+  (if (null? declarations)
+      '()
+      (declarations/map declarations
+	(lambda (variable)
+	  (environment/lookup environment variable
+	    identity-procedure
+	    (lambda ()
+	      (block/lookup-name root-block variable))))
+	(lambda (expression)
+	  (copy/expression block environment expression)))))
+
+(define (environment/make)
+  '())
+
+(define (environment/bind environment variables values)
+  (map* environment cons variables values))
+
+(define (environment/lookup environment variable if-found if-not)
+  (let ((association (assq variable environment)))
+    (if association
+	(if-found (cdr association))
+	(if-not))))
+
+(define (environment/rebind block environment variables)
+  (environment/bind environment
+		    variables
+		    (map (lambda (variable)
+			   (block/lookup-name block (variable/name variable)))
+			 variables)))
+
+(define (make-renamer environment)
+  (lambda (variable)
+    (environment/lookup environment variable
+      identity-procedure
+      (lambda () (error "Missing variable during copy operation" variable)))))
+
 (define-method/copy 'ACCESS
   (lambda (block environment expression)
     (access/make (copy/expression block environment
@@ -94,11 +202,12 @@ MIT in each case. |#
 (define-method/copy 'CONSTANT
   (lambda (block environment expression)
     expression))
-
+
 (define-method/copy 'DECLARATION
   (lambda (block environment expression)
     (declaration/make
-     (copy/declarations environment (declaration/declarations expression))
+     (copy/declarations block environment
+			(declaration/declarations expression))
      (copy/expression block environment (declaration/expression expression)))))
 
 (define-method/copy 'DELAY
@@ -112,7 +221,7 @@ MIT in each case. |#
      (copy/expression block environment (disjunction/predicate expression))
      (copy/expression block environment
 		      (disjunction/alternative expression)))))
-
+
 (define-method/copy 'IN-PACKAGE
   (lambda (block environment expression)
     (in-package/make
@@ -130,28 +239,23 @@ MIT in each case. |#
 			  (map rename (procedure/optional procedure))
 			  (let ((rest (procedure/rest procedure)))
 			    (and rest (rename rest)))
-			  (copy/expression block
-					   environment
+			  (copy/expression block environment
 					   (procedure/body procedure))))))))
-
+
 (define-method/copy 'OPEN-BLOCK
   (lambda (block environment expression)
     (transmit-values
 	(copy/block block environment (open-block/block expression))
       (lambda (block environment)
-	(open-block/make block
-			 (map (make-renamer environment)
-			      (open-block/variables expression))
-			 (copy/expressions block
-					   environment
-					   (open-block/values expression))
-			 (map (lambda (action)
-				(if (eq? action open-block/value-marker)
-				    action
-				    (copy/expression block
-						     environment
-						     action)))
-			      (open-block/actions expression)))))))
+	(open-block/make
+	 block
+	 (map (make-renamer environment) (open-block/variables expression))
+	 (copy/expressions block environment (open-block/values expression))
+	 (map (lambda (action)
+		(if (eq? action open-block/value-marker)
+		    action
+		    (copy/expression block environment action)))
+	      (open-block/actions expression)))))))
 
 (define-method/copy 'QUOTATION
   (lambda (block environment expression)
@@ -160,8 +264,7 @@ MIT in each case. |#
 (define-method/copy 'REFERENCE
   (lambda (block environment expression)
     (reference/make block
-		    (copy/variable block
-				   environment
+		    (copy/variable block environment
 				   (reference/variable expression)))))
 
 (define-method/copy 'SEQUENCE
@@ -171,71 +274,4 @@ MIT in each case. |#
 
 (define-method/copy 'THE-ENVIRONMENT
   (lambda (block environment expression)
-    (error "Attempt to integrate expression containing (THE-ENVIRONMENT)")))
-
-(define (copy/block parent environment block)
-  (let ((result (block/make parent (block/safe? block)))
-	(old-bound (block/bound-variables block)))
-    (let ((new-bound
-	   (map (lambda (variable)
-		  (variable/make result (variable/name variable)))
-		old-bound)))
-      (let ((environment (environment/bind environment old-bound new-bound)))
-	(block/set-bound-variables! result new-bound)
-	(block/set-declarations!
-	 result
-	 (copy/declarations environment (block/declarations block)))
-	(return-2 result environment)))))
-
-(define (copy/declarations environment declarations)
-  (if (null? declarations)
-      '()
-      (declarations/rename declarations
-	(lambda (variable)
-	  (environment/lookup environment variable
-	    identity-procedure
-	    (lambda () variable))))))
-
-(define root-block)
-
-(define (copy/variable block environment variable)
-  (environment/lookup environment variable
-    identity-procedure
-    (lambda ()
-      (for-each rename-variable!
-		(let ((name (variable/name variable)))
-		  (let loop ((block root-block))
-		    (let ((variable*
-			   (variable/assoc name
-					   (block/bound-variables block))))
-		      (cond ((not variable*) (loop (block/parent block)))
-			    ((eq? variable variable*) '())
-			    (else
-			     (cons variable* (loop (block/parent block)))))))))
-      variable)))
-
-(define (rename-variable! variable)
-  (if (block/safe? (variable/block variable))
-      (variable/set-name! variable (rename (variable/name variable)))
-      (error "Integration requires renaming unsafe variable" variable)))
-
-(define (rename name)
-  (string->uninterned-symbol (symbol->string name)))
-
-(define (environment/make)
-  '())
-
-(define (environment/bind environment variables values)
-  (map* environment cons variables values))
-
-(define (environment/lookup environment variable if-found if-not)
-  (let ((association (assq variable environment)))
-    (if association
-	(if-found (cdr association))
-	(if-not))))
-
-(define (make-renamer environment)
-  (lambda (variable)
-    (environment/lookup environment variable
-      identity-procedure
     (error "Attempt to integrate expression containing (THE-ENVIRONMENT)")))
\ No newline at end of file
diff --git a/v7/src/sf/emodel.scm b/v7/src/sf/emodel.scm
index 14b336103..2032dab2c 100644
--- a/v7/src/sf/emodel.scm
+++ b/v7/src/sf/emodel.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/emodel.scm,v 3.1 1987/03/10 14:53:32 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/emodel.scm,v 3.2 1987/03/13 04:12:19 cph Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -34,8 +34,7 @@ MIT in each case. |#
 
 ;;;; SCode Optimizer: Environment Model
 
-(declare (usual-integrations)
-	 (integrate-external (access integrations package/scode-optimizer)))
+(declare (usual-integrations))
 
 (define variable/assoc
   (association-procedure eq? variable/name))
diff --git a/v7/src/sf/free.scm b/v7/src/sf/free.scm
index 33218ecbd..82cb45a88 100644
--- a/v7/src/sf/free.scm
+++ b/v7/src/sf/free.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/free.scm,v 3.1 1987/03/10 14:54:17 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/free.scm,v 3.2 1987/03/13 04:12:30 cph Rel $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -34,8 +34,7 @@ MIT in each case. |#
 
 ;;;; SCode Optimizer: Free Variable Analysis
 
-(declare (usual-integrations)
-	 (integrate-external (access integrations package/scode-optimizer)))
+(declare (usual-integrations))
 
 (define (free/expressions expressions)
   (if (null? expressions)
diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm
index 89c61a2a5..bb9ff130b 100644
--- a/v7/src/sf/make.scm
+++ b/v7/src/sf/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 3.2 1987/03/10 14:54:48 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 3.3 1987/03/13 04:12:41 cph Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -38,6 +38,8 @@ MIT in each case. |#
 (declare (usual-integrations))
 
 (define sf)
+(define sf/set-file-syntax-table!)
+(define sf/add-file-declarations!)
 (load "$zcomp/base/load" system-global-environment)
 
 (load-system system-global-environment
@@ -45,51 +47,55 @@ MIT in each case. |#
 	     '(SYSTEM-GLOBAL-ENVIRONMENT)
 	     '(
 	       (PACKAGE/SCODE-OPTIMIZER
-		"mvalue.bin"		;Multiple Value Support
-		"eqsets.bin"		;Set Data Abstraction
-
-		"object.bin"		;Data Structures
-		"emodel.bin"		;Environment Model
-		"gconst.bin"		;Global Primitives List
-		"usicon.bin"		;Usual Integrations: Constants
-		"tables.bin"		;Table Abstractions
-		"packag.bin"		;Global packaging
+		"mvalue"		;Multiple Value Support
+		"eqsets"		;Set Data Abstraction
+
+		"object"		;Data Structures
+		"emodel"		;Environment Model
+		"gconst"		;Global Primitives List
+		"usicon"		;Usual Integrations: Constants
+		"tables"		;Table Abstractions
+		"packag"		;Global packaging
 		)
 
 	       (PACKAGE/TOP-LEVEL
-		"toplev.bin"		;Top Level
+		"toplev"		;Top Level
 		)
 
 	       (PACKAGE/TRANSFORM
-		"xform.bin"		;SCode -> Internal
+		"xform"			;SCode -> Internal
 		)
 
 	       (PACKAGE/INTEGRATE
-		"subst.bin"		;Beta Substitution Optimizer
+		"subst"			;Beta Substitution Optimizer
 		)
 
 	       (PACKAGE/CGEN
-		"cgen.bin"		;Internal -> SCode
+		"cgen"			;Internal -> SCode
 		)
 
 	       (PACKAGE/EXPANSION
-		"usiexp.bin"		;Usual Integrations: Expanders
+		"usiexp"		;Usual Integrations: Expanders
 		)
 
-	       (PACKAGE/DECLARATION-PARSER
-		"pardec.bin"		;Declaration Parser
+	       (PACKAGE/DECLARATIONS
+		"pardec"		;Declaration Parser
 		)
 
 	       (PACKAGE/COPY
-		"copy.bin"		;Copy Expressions
+		"copy"			;Copy Expressions
 		)
 
 	       (PACKAGE/FREE
-		"free.bin"		;Free Variable Analysis
+		"free"			;Free Variable Analysis
 		)
 
 	       (PACKAGE/SAFE?
-		"safep.bin"		;Safety Analysis
+		"safep"			;Safety Analysis
+		)
+
+	       (PACKAGE/CHANGE-TYPE
+		"chtype"		;Type interning
 		)
 
 	       ))
@@ -102,7 +108,7 @@ MIT in each case. |#
     (make-environment
       (define :name "SF")
       (define :version 3)
-      (define :modification 1)))
+      (define :modification 2)))
 
   (add-system! scode-optimizer/system)
 
diff --git a/v7/src/sf/object.scm b/v7/src/sf/object.scm
index fef262d60..8bf2f284d 100644
--- a/v7/src/sf/object.scm
+++ b/v7/src/sf/object.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/object.scm,v 3.0 1987/03/10 13:25:07 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/object.scm,v 3.1 1987/03/13 04:12:53 cph Rel $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -43,7 +43,9 @@ MIT in each case. |#
     (let ((enumerand (symbol-append name '/ENUMERAND)))
       `(BEGIN
 	 (DEFINE ,enumerand
-	   (NAME->ENUMERAND ,(symbol-append 'ENUMERATION/ enumeration) ',name))
+	   (ENUMERATION/NAME->ENUMERAND ,(symbol-append 'ENUMERATION/
+							enumeration)
+					',name))
 	 ((ACCESS ADD-UNPARSER-SPECIAL-OBJECT! UNPARSER-PACKAGE) ,enumerand
 	  (LAMBDA (OBJECT)
 	    (UNPARSE-WITH-BRACKETS
@@ -75,9 +77,11 @@ MIT in each case. |#
 		(DECLARE (INTEGRATE ,@slots))
 		(OBJECT/ALLOCATE ,(symbol-append name '/ENUMERAND) ,@slots))
 	      (DEFINE-TYPE ,name ,enumeration ,slots)))))
+
+;;;; Objects
 
 (declare (integrate object/allocate)
-	 (integrate-operator object/enumerand))
+	 (integrate-operator object/enumerand object/set-enumerand!))
 
 (define object/allocate vector)
 
@@ -85,6 +89,10 @@ MIT in each case. |#
   (declare (integrate object))
   (vector-ref object 0))
 
+(define (object/set-enumerand! object enumerand)
+  (declare (integrate object enumerand))
+  (vector-set! object 0 enumerand))
+
 (define (object/predicate enumerand)
   (lambda (object)
     (and (vector? object)
@@ -94,18 +102,25 @@ MIT in each case. |#
 ;;;; Enumerations
 
 (define (enumeration/make names)
-  (let ((enumeration (make-vector (length names))))
-    (let loop ((names names) (index 0))
-      (if (not (null? names))
-	  (begin
-	    (vector-set! enumeration index
-			 (vector enumeration (car names) index))
-	    (loop (cdr names) (1+ index)))))
-    enumeration))
+  (let ((enumerands 
+	 (let loop ((names names) (index 0))
+	   (if (null? names)
+	       '()
+	       (cons (vector false (car names) index)
+		     (loop (cdr names) (1+ index)))))))
+    (let ((enumeration
+	   (cons (list->vector enumerands)
+		 (map (lambda (enumerand)
+			(cons (enumerand/name enumerand) enumerand))
+		      enumerands))))
+      (for-each (lambda (enumerand)
+		  (vector-set! enumerand 0 enumeration))
+		enumerands)
+      enumeration)))
 
 (declare (integrate-operator enumerand/enumeration enumerand/name
 			     enumerand/index enumeration/cardinality
-			     index->enumerand))
+			     enumeration/index->enumerand))
 
 (define (enumerand/enumeration enumerand)
   (declare (integrate enumerand))
@@ -121,20 +136,18 @@ MIT in each case. |#
 
 (define (enumeration/cardinality enumeration)
   (declare (integrate enumeration))
-  (vector-length enumeration))
-
-(define (index->enumerand enumerand index)
-  (declare (integrate enumerand index))
-  (vector-ref enumerand index))
-
-(define (name->enumerand enumeration name)
-  (let ((length (enumeration/cardinality enumeration)))
-    (let loop ((index 0))
-      (and (< index length)
-	   (let ((enumerand (index->enumerand enumeration index)))
-	     (if (eqv? name (enumerand/name enumerand))
-		 enumerand
-		 (loop (1+ index))))))))
+  (vector-length (car enumeration)))
+
+(define (enumeration/index->enumerand enumeration index)
+  (declare (integrate enumeration index))
+  (vector-ref (car enumeration) index))
+
+(define (enumeration/name->enumerand enumeration name)
+  (cdr (or (assq name (cdr enumeration))
+	   (error "Unknown enumeration name" name))))
+
+(define (enumeration/name->index enumeration name)
+  (enumerand/index (enumeration/name->enumerand enumeration name)))
 
 ;;;; Random Types
 
@@ -146,12 +159,12 @@ MIT in each case. |#
      )))
 
 (define-type block random
-  (parent children safe? declarations bound-variables expression))
+  (parent children safe? declarations bound-variables))
 
 (define (block/make parent safe?)
   (let ((block
-	 (object/allocate block/enumerand parent '() safe? '() '()
-			  false)))
+	 (object/allocate block/enumerand parent '() safe?
+			  (declarations/make-null) '())))
     (if parent
 	(block/set-children! parent (cons block (block/children parent))))
     block))
@@ -159,7 +172,10 @@ MIT in each case. |#
 (define-type delayed-integration random
   (state environment operations value))
 
+(declare (integrate-operator delayed-integration/make))
+
 (define (delayed-integration/make operations expression)
+  (declare (integrate operations expression))
   (object/allocate delayed-integration/enumerand 'NOT-INTEGRATED false
 		   operations expression))
 
@@ -174,7 +190,9 @@ MIT in each case. |#
     variable))
 
 (define open-block/value-marker
-  "value marker")
+  ;; This must be an interned object because we will fasdump it and
+  ;; fasload it back in.
+  (make-named-tag "open-block/value-marker"))
 
 ;;;; Expression Types
 
@@ -203,8 +221,7 @@ MIT in each case. |#
 (define (expression/make-method-definer dispatch-vector)
   (lambda (type-name method)
     (vector-set! dispatch-vector
-		 (enumerand/index
-		  (name->enumerand enumeration/expression type-name))
+		 (enumeration/name->index enumeration/expression type-name)
 		 method)))
 
 (declare (integrate-operator expression/method name->method))
@@ -217,7 +234,7 @@ MIT in each case. |#
   ;; Useful for debugging
   (declare (integrate dispatch-vector name))
   (vector-ref dispatch-vector
-	      (enumerand/index (name->enumerand enumeration/expression name))))
+	      (enumeration/name->index enumeration/expression name)))
 
 (define-simple-type access expression (environment name))
 (define-simple-type assignment expression (block variable value))
diff --git a/v7/src/sf/pardec.scm b/v7/src/sf/pardec.scm
index 7c35a7de6..23428198c 100644
--- a/v7/src/sf/pardec.scm
+++ b/v7/src/sf/pardec.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 3.0 1987/03/10 13:25:13 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 3.1 1987/03/13 04:13:19 cph Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -36,96 +36,55 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 
-(define (declarations/known? declaration)
-  (assq (car declaration) known-declarations))
+(define (declarations/make-null)
+  (declarations/make '() '() '()))
 
 (define (declarations/parse block declarations)
-  (return-2
-   declarations
-   (accumulate
-    (lambda (declaration bindings)
-      (let ((association (assq (car declaration) known-declarations)))
-	(if (not association)
-	    bindings
-	    (transmit-values (cdr association)
-	      (lambda (before-bindings? parser)
-		(let ((block
-		       (if before-bindings?
-			   (let ((block (block/parent block)))
-			     (if (block/parent block)
-				 (warn "Declaration not at top level"
-				       declaration))
-			     block)
-			   block)))
-		  (parser block (bindings/cons block before-bindings?) bindings
-			  (cdr declaration))))))))
-    (return-2 '() '())
-    declarations)))
-
-(define (declarations/rename declarations rename)
-  (declarations/map declarations
-    (lambda (bindings)
-      (map (lambda (binding)
-	     (transmit-values binding
-	       (lambda (applicator binder names)
-		 (return-3 applicator binder (map rename names)))))
-	   bindings))))
-
-(define (declarations/binders declarations)
-  (transmit-values declarations
-    (lambda (original bindings)
-      (call-multiple (lambda (bindings)
-		       (lambda (operations)
-			 (accumulate (lambda (binding operations)
-				       (transmit-values binding
-					 (lambda (applicator binder names)
-					   (applicator binder operations
-						       names))))
-				     operations bindings)))
-		     bindings))))
-
-(define (declarations/original declarations)
-  (transmit-values declarations
-    (lambda (original bindings)
-      original)))
-
-(define (declarations/map declarations procedure)
-  (transmit-values declarations
-    (lambda (original bindings)
-      (return-2 original (call-multiple procedure bindings)))))
+  (transmit-values
+      (accumulate
+       (lambda (declaration bindings)
+	 (let ((association (assq (car declaration) known-declarations)))
+	   (if (not association)
+	       bindings
+	       (transmit-values (cdr association)
+		 (lambda (before-bindings? parser)
+		   (let ((block
+			  (if before-bindings?
+			      (let ((block (block/parent block)))
+				(if (block/parent block)
+				    (warn "Declaration not at top level"
+					  declaration))
+				block)
+			      block)))
+		     (parser block
+			     (bindings/cons block before-bindings?)
+			     bindings
+			     (cdr declaration))))))))
+       (return-2 '() '())
+       declarations)
+    (lambda (before after)
+      (declarations/make declarations before after))))
 
 (define (bindings/cons block before-bindings?)
-  (lambda (bindings applicator names global?)
+  (lambda (bindings global? operation export? names values)
     (let ((result
-	   (if global?
-	       (return-3 applicator operations/bind-global names)
-	       (return-3 applicator operations/bind
-			 (block/lookup-names block names)))))
+	   (binding/make global? operation export?
+			 (if global? names (block/lookup-names block names))
+			 values)))
       (transmit-values bindings
-	(lambda (before-bindings after-bindings)
+	(lambda (before after)
 	  (if before-bindings?
-	      (return-2 (cons result before-bindings) after-bindings)
-	      (return-2 before-bindings (cons result after-bindings))))))))
+	      (return-2 (cons result before) after)
+	      (return-2 before (cons result after))))))))
 
 (define (bind/values table/cons table operation export? names values)
-  (table/cons table
-	      (lambda (binder operations names)
-		(binder operations operation export? names values))
-	      names
-	      (not export?)))
+  (table/cons table (not export?) operation export? names values))
 
 (define (bind/no-values table/cons table operation export? names)
-  (table/cons table
-	      (lambda (binder operations names)
-		(binder operations operation export? names))
-	      names
-	      false))
-
-(define (accumulate cons table items)
-  (let loop ((table table) (items items))
-    (if (null? items)
-	table
-	(loop (cons (car items) table) (cdr items)))))
+  (table/cons table false operation export? names 'NO-VALUES))
+
+(define (declarations/known? declaration)
+  (assq (car declaration) known-declarations))
 
 (define (define-declaration name before-bindings? parser)
   (let ((entry (assq name known-declarations)))
@@ -137,6 +96,111 @@ MIT in each case. |#
 
 (define known-declarations
   '())
+
+(define (accumulate cons table items)
+  (let loop ((table table) (items items))
+    (if (null? items)
+	table
+	(loop (cons (car items) table) (cdr items)))))
+
+(define (declarations/binders declarations)
+  (let ((procedure
+	 (lambda (bindings)
+	   (lambda (operations)
+	     (accumulate (lambda (binding operations)
+			   ((if (binding/global? binding)
+				operations/bind-global
+				operations/bind)
+			    operations
+			    (binding/operation binding)
+			    (binding/export? binding)
+			    (binding/names binding)
+			    (binding/values binding)))
+			 operations
+			 bindings)))))
+    (return-2 (procedure (declarations/before declarations))
+	      (procedure (declarations/after declarations)))))
+
+(define (declarations/for-each-variable declarations procedure)
+  (declarations/for-each-binding declarations
+    (lambda (binding)
+      (if (not (binding/global? binding))
+	  (for-each procedure (binding/names binding))))))
+
+(define (declarations/for-each-binding declarations procedure)
+  (let ((procedure
+	 (lambda (bindings)
+	   (for-each procedure bindings))))
+    (procedure (declarations/before declarations))
+    (procedure (declarations/after declarations))))
+
+(define (declarations/map declarations per-name per-value)
+  (declarations/map-binding declarations
+    (lambda (binding)
+      (let ((global? (binding/global? binding))
+	    (names (binding/names binding))
+	    (values (binding/values binding)))
+	(binding/make global?
+		      (binding/operation binding)
+		      (binding/export? binding)
+		      (if global? names (map per-name names))
+		      (if (eq? values 'NO-VALUES)
+			  values
+			  (map per-value values)))))))
+
+(define (declarations/map-binding declarations procedure)
+  (let ((procedure
+	 (lambda (bindings)
+	   (map procedure bindings))))
+    (declarations/make (declarations/original declarations)
+		       (procedure (declarations/before declarations))
+		       (procedure (declarations/after declarations)))))
+
+(declare (integrate-operator declarations/make declarations/original
+			     declarations/before declarations/after))
+
+(define (declarations/make original before after)
+  (declare (integrate original before after))
+  (vector original before after))
+
+(define (declarations/original declarations)
+  (declare (integrate declarations))
+  (vector-ref declarations 0))
+
+(define (declarations/before declarations)
+  (declare (integrate declarations))
+  (vector-ref declarations 1))
+
+(define (declarations/after declarations)
+  (declare (integrate declarations))
+  (vector-ref declarations 2))
+
+(declare (integrate-operator binding/make binding/global? binding/operation
+			     binding/export? binding/names binding/values))
+
+(define (binding/make global? operation export? names values)
+  (declare (integrate global? operation export? names values))
+  (vector global? operation export? names values))
+
+(define (binding/global? binding)
+  (declare (integrate binding))
+  (vector-ref binding 0))
+
+(define (binding/operation binding)
+  (declare (integrate binding))
+  (vector-ref binding 1))
+
+(define (binding/export? binding)
+  (declare (integrate binding))
+  (vector-ref binding 2))
+
+(define (binding/names binding)
+  (declare (integrate binding))
+  (vector-ref binding 3))
+
+(define (binding/values binding)
+  (declare (integrate binding))
+  (vector-ref binding 4))
 
 ;;;; Integration of System Constants
 
@@ -182,8 +246,8 @@ MIT in each case. |#
   (let ((finish
 	 (lambda (variable-name primitive-name)
 	   (return-2 (block/lookup-name block variable-name)
-		     (make-primitive-procedure
-		      (constant->integration-info primitive-name))))))
+		     (constant->integration-info
+		      (make-primitive-procedure primitive-name))))))
     (cond ((and (pair? specification)
 		(symbol? (car specification))
 		(pair? (cdr specification))
@@ -210,10 +274,8 @@ MIT in each case. |#
        (bind/values table/cons table (vector-ref extern 1) false
 		    (list (vector-ref extern 0))
 		    (list
-		     (expression->integration-info
-		      (transform/expression-with-block
-		       block
-		       (vector-ref extern 2))))))
+		     (intern-type (vector-ref extern 2)
+				  (vector-ref extern 3)))))
      table
      (mapcan read-externs-file
 	     (mapcan specification->pathnames specifications)))))
@@ -226,19 +288,18 @@ MIT in each case. |#
 	(map ->pathname value)
 	(list (->pathname value)))))
 
-(define (expression->integration-info expression)
-  (lambda ()
-    expression))
-
 (define (operations->external operations environment)
   (operations/extract-external operations
     (lambda (variable operation info if-ok if-not)
       (let ((finish
 	     (lambda (value)
 	       (if-ok
-		(vector (variable/name variable)
-			operation
-			(cgen/expression-with-declarations value))))))
+		(transmit-values (copy/expression/extern value)
+		  (lambda (block expression)
+		    (vector (variable/name variable)
+			    operation
+			    block
+			    expression)))))))
 	(if info
 	    (finish info)
 	    (variable/final-value variable environment finish if-not))))))
\ No newline at end of file
diff --git a/v7/src/sf/subst.scm b/v7/src/sf/subst.scm
index 14b7b1fba..aa336045b 100644
--- a/v7/src/sf/subst.scm
+++ b/v7/src/sf/subst.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 3.1 1987/03/10 14:57:38 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 3.2 1987/03/13 04:13:46 cph Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -34,8 +34,7 @@ MIT in each case. |#
 
 ;;;; SCode Optimizer: Beta Substitution
 
-(declare (usual-integrations)
-	 (integrate-external (access integrations package/scode-optimizer)))
+(declare (usual-integrations))
 
 (define (integrate/top-level block expression)
   (let ((operations (operations/bind-block (operations/make) block))
@@ -310,17 +309,17 @@ MIT in each case. |#
 (define (integrate/name reference info environment)
   (let ((variable (reference/variable reference)))
     (let ((finish
-	   (lambda (value)
-	     (copy/expression (reference/block reference) value))))
+	   (lambda (value uninterned)
+	     (copy/expression (reference/block reference) value uninterned))))
       (if info
-	  (finish (info))
+	  (transmit-values info finish)
 	  (environment/lookup environment variable
 	    (lambda (value)
 	      (if (delayed-integration? value)
 		  (if (delayed-integration/in-progress? value)
 		      reference
-		      (finish (delayed-integration/force value)))
-		  (finish value)))
+		      (finish (delayed-integration/force value) '()))
+		  (finish value '())))
 	    (lambda () reference))))))
 
 (define (variable/final-value variable environment if-value if-not)
diff --git a/v7/src/sf/tables.scm b/v7/src/sf/tables.scm
index 5fd4b22f7..50de2dbbd 100644
--- a/v7/src/sf/tables.scm
+++ b/v7/src/sf/tables.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/tables.scm,v 3.0 1987/03/10 13:25:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/tables.scm,v 3.1 1987/03/13 04:14:10 cph Rel $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -65,11 +65,11 @@ MIT in each case. |#
 		(cons name (vector export? operation value)))
 	      names values)))
 
-(define (operations/bind operations operation export? names #!optional values)
+(define (operations/bind operations operation export? names values)
   (cons (let ((make-binding
 	       (lambda (name value)
 		 (cons name (vector export? operation value)))))
-	  (if (unassigned? values)
+	  (if (eq? values 'NO-VALUES)
 	      (map* (car operations)
 		    (lambda (name) (make-binding name false))
 		    names)
diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm
index 5569392fc..bf1a5c79b 100644
--- a/v7/src/sf/toplev.scm
+++ b/v7/src/sf/toplev.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 3.0 1987/03/10 13:25:25 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 3.1 1987/03/13 04:14:20 cph Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -53,8 +53,10 @@ Currently this optimization is not implemented.")
 		      environment)))
       (error "INTEGRATE/PROCEDURE: Not a compound procedure" procedure)))
 
-(define (integrate/sexp s-expression declarations receiver)
-  (integrate/simple phase:syntax (list s-expression) declarations receiver))
+(define (integrate/sexp s-expression syntax-table declarations receiver)
+  (integrate/simple (lambda (s-expressions)
+		      (phase:syntax s-expressions syntax-table))
+		    (list s-expression) declarations receiver))
 
 (define (integrate/scode scode declarations receiver)
   (integrate/simple identity-procedure scode declarations receiver))
@@ -72,6 +74,52 @@ Currently only the 68000 implementation needs this."
   (fluid-let ((wrapping-hook wrap-with-control-point))
     (syntax-file input-string bin-string spec-string)))
 
+(define (sf/set-file-syntax-table! pathname syntax-table)
+  (let ((pathname (pathname->absolute-pathname (->pathname pathname))))
+    (let ((association (find-file-info/assoc pathname)))
+      (if association
+	  (set-cdr! association
+		    (transmit-values (cdr association)
+		      (lambda (ignore declarations)
+			(return-2 syntax-table declarations))))
+	  (set! file-info
+		(cons (cons pathname (return-2 syntax-table '()))
+		      file-info))))))
+
+(define (sf/add-file-declarations! pathname declarations)
+  (let ((pathname (pathname->absolute-pathname (->pathname pathname))))
+    (let ((association (find-file-info/assoc pathname)))
+      (if association
+	  (set-cdr! association
+		    (transmit-values (cdr association)
+		      (lambda (syntax-table declarations*)
+			(return-2 syntax-table
+				  (append! declarations*
+					   (list-copy declarations))))))
+	  (set! file-info
+		(cons (cons pathname (return-2 false declarations))
+		      file-info))))))
+
+(define file-info
+  '())
+
+(define (find-file-info pathname)
+  (let ((association
+	 (find-file-info/assoc (pathname->absolute-pathname pathname))))
+    (if association
+	(cdr association)
+	(return-2 false '()))))
+
+(define (find-file-info/assoc pathname)
+  (list-search-positive file-info
+    (lambda (entry)
+      (pathname=? (car entry) pathname))))
+
+(define (pathname=? x y)
+  (and (equal? (pathname-device x) (pathname-device y))
+       (equal? (pathname-directory x) (pathname-directory y))
+       (equal? (pathname-name x) (pathname-name y))))
+
 ;;;; File Syntaxer
 
 (define sf/default-input-pathname
@@ -129,7 +177,11 @@ Currently only the 68000 implementation needs this."
     (write bin-filename)
     (write-string " ")
     (write spec-filename)
-    (transmit-values (integrate/file input-pathname '() spec-pathname)
+    (transmit-values
+	(transmit-values (find-file-info input-pathname)
+	  (lambda (syntax-table declarations)
+	    (integrate/file input-pathname syntax-table declarations
+			    spec-pathname)))
       (lambda (expression externs events)
 	(fasdump (wrapping-hook
 		  (make-comment `((SOURCE-FILE . ,input-filename)
@@ -168,8 +220,10 @@ Currently only the 68000 implementation needs this."
 			    sf/default-externs-pathname)))
 
 (define (write-externs-file pathname externs)
-  (if (not (null? externs))
-      (fasdump externs pathname)))
+  (cond ((not (null? externs))
+	 (fasdump externs pathname))
+	((file-exists? pathname)
+	 (delete-file pathname))))
 
 (define (print-spec identifier names)
   (newline)
@@ -214,9 +268,9 @@ Currently only the 68000 implementation needs this."
 
 ;;;; Optimizer Top Level
 
-(define (integrate/file file-name declarations compute-free?)
+(define (integrate/file file-name syntax-table declarations compute-free?)
   (integrate/kernel (lambda ()
-		      (phase:syntax (phase:read file-name)))
+		      (phase:syntax (phase:read file-name) syntax-table))
 		    declarations))
 
 (define (integrate/simple preprocessor input declarations receiver)
@@ -254,9 +308,11 @@ Currently only the 68000 implementation needs this."
   (mark-phase "Read")
   (read-file filename))
 
-(define (phase:syntax s-expression)
+(define (phase:syntax s-expression #!optional syntax-table)
+  (if (or (unassigned? syntax-table) (not syntax-table))
+      (set! syntax-table (make-syntax-table system-global-syntax-table)))
   (mark-phase "Syntax")
-  (syntax* s-expression (make-syntax-table system-global-syntax-table)))
+  (syntax* s-expression syntax-table))
 
 (define (phase:transform scode)
   (mark-phase "Transform")
diff --git a/v7/src/sf/usicon.scm b/v7/src/sf/usicon.scm
index 029c2cc9c..6d475e222 100644
--- a/v7/src/sf/usicon.scm
+++ b/v7/src/sf/usicon.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usicon.scm,v 3.0 1987/03/10 13:25:28 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usicon.scm,v 3.1 1987/03/13 04:14:39 cph Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -39,10 +39,6 @@ MIT in each case. |#
 (define usual-integrations/constant-names)
 (define usual-integrations/constant-values)
 
-(define (constant->integration-info constant)
-  (lambda ()
-    (constant/make constant)))
-
 (define (usual-integrations/delete-constant! name)
   (set! global-constant-objects (delq! name global-constant-objects))
   (usual-integrations/cache!))
@@ -58,4 +54,7 @@ MIT in each case. |#
 		     (error "USUAL-INTEGRATIONS: not a constant" name))
 		 (constant->integration-info object)))
 	     usual-integrations/constant-names))
+  'DONE)
+
+(define (constant->integration-info constant)
   (return-2 (constant/make constant) '()))
\ No newline at end of file
diff --git a/v7/src/sf/xform.scm b/v7/src/sf/xform.scm
index 1d2700400..63095ac4d 100644
--- a/v7/src/sf/xform.scm
+++ b/v7/src/sf/xform.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 3.1 1987/03/10 14:58:01 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 3.2 1987/03/13 04:14:48 cph Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -34,8 +34,7 @@ MIT in each case. |#
 
 ;;;; SCode Optimizer: Transform Input Expression
 
-(declare (usual-integrations)
-	 (integrate-external (access integrations package/scode-optimizer)))
+(declare (usual-integrations))
 
 ;;; GLOBAL-BLOCK is used to handle (USUAL-INTEGRATIONS), as follows.
 ;;; This declaration refers to a large group of names, which are
@@ -98,7 +97,9 @@ MIT in each case. |#
 
 (define ((transform/open-block* block environment) auxiliary declarations body)
   (let ((variables (map (lambda (name) (variable/make block name)) auxiliary)))
-    (block/set-bound-variables! block variables)
+    (block/set-bound-variables! block
+				(append (block/bound-variables block)
+					variables))
     (block/set-declarations! block (declarations/parse block declarations))
     (let ((environment (environment/bind environment variables)))
 
diff --git a/v8/src/sf/make.scm b/v8/src/sf/make.scm
index 6c6f56eb4..a750f65d0 100644
--- a/v8/src/sf/make.scm
+++ b/v8/src/sf/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 3.2 1987/03/10 14:54:48 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 3.3 1987/03/13 04:12:41 cph Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -38,6 +38,8 @@ MIT in each case. |#
 (declare (usual-integrations))
 
 (define sf)
+(define sf/set-file-syntax-table!)
+(define sf/add-file-declarations!)
 (load "$zcomp/base/load" system-global-environment)
 
 (load-system system-global-environment
@@ -45,51 +47,55 @@ MIT in each case. |#
 	     '(SYSTEM-GLOBAL-ENVIRONMENT)
 	     '(
 	       (PACKAGE/SCODE-OPTIMIZER
-		"mvalue.bin"		;Multiple Value Support
-		"eqsets.bin"		;Set Data Abstraction
-
-		"object.bin"		;Data Structures
-		"emodel.bin"		;Environment Model
-		"gconst.bin"		;Global Primitives List
-		"usicon.bin"		;Usual Integrations: Constants
-		"tables.bin"		;Table Abstractions
-		"packag.bin"		;Global packaging
+		"mvalue"		;Multiple Value Support
+		"eqsets"		;Set Data Abstraction
+
+		"object"		;Data Structures
+		"emodel"		;Environment Model
+		"gconst"		;Global Primitives List
+		"usicon"		;Usual Integrations: Constants
+		"tables"		;Table Abstractions
+		"packag"		;Global packaging
 		)
 
 	       (PACKAGE/TOP-LEVEL
-		"toplev.bin"		;Top Level
+		"toplev"		;Top Level
 		)
 
 	       (PACKAGE/TRANSFORM
-		"xform.bin"		;SCode -> Internal
+		"xform"			;SCode -> Internal
 		)
 
 	       (PACKAGE/INTEGRATE
-		"subst.bin"		;Beta Substitution Optimizer
+		"subst"			;Beta Substitution Optimizer
 		)
 
 	       (PACKAGE/CGEN
-		"cgen.bin"		;Internal -> SCode
+		"cgen"			;Internal -> SCode
 		)
 
 	       (PACKAGE/EXPANSION
-		"usiexp.bin"		;Usual Integrations: Expanders
+		"usiexp"		;Usual Integrations: Expanders
 		)
 
-	       (PACKAGE/DECLARATION-PARSER
-		"pardec.bin"		;Declaration Parser
+	       (PACKAGE/DECLARATIONS
+		"pardec"		;Declaration Parser
 		)
 
 	       (PACKAGE/COPY
-		"copy.bin"		;Copy Expressions
+		"copy"			;Copy Expressions
 		)
 
 	       (PACKAGE/FREE
-		"free.bin"		;Free Variable Analysis
+		"free"			;Free Variable Analysis
 		)
 
 	       (PACKAGE/SAFE?
-		"safep.bin"		;Safety Analysis
+		"safep"			;Safety Analysis
+		)
+
+	       (PACKAGE/CHANGE-TYPE
+		"chtype"		;Type interning
 		)
 
 	       ))
@@ -102,7 +108,7 @@ MIT in each case. |#
     (make-environment
       (define :name "SF")
       (define :version 3)
-      (define :modification 1)))
+      (define :modification 2)))
 
   (add-system! scode-optimizer/system)
 
diff --git a/v8/src/sf/toplev.scm b/v8/src/sf/toplev.scm
index e597ac8d6..aab94f434 100644
--- a/v8/src/sf/toplev.scm
+++ b/v8/src/sf/toplev.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 3.0 1987/03/10 13:25:25 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 3.1 1987/03/13 04:14:20 cph Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -53,8 +53,10 @@ Currently this optimization is not implemented.")
 		      environment)))
       (error "INTEGRATE/PROCEDURE: Not a compound procedure" procedure)))
 
-(define (integrate/sexp s-expression declarations receiver)
-  (integrate/simple phase:syntax (list s-expression) declarations receiver))
+(define (integrate/sexp s-expression syntax-table declarations receiver)
+  (integrate/simple (lambda (s-expressions)
+		      (phase:syntax s-expressions syntax-table))
+		    (list s-expression) declarations receiver))
 
 (define (integrate/scode scode declarations receiver)
   (integrate/simple identity-procedure scode declarations receiver))
@@ -72,6 +74,52 @@ Currently only the 68000 implementation needs this."
   (fluid-let ((wrapping-hook wrap-with-control-point))
     (syntax-file input-string bin-string spec-string)))
 
+(define (sf/set-file-syntax-table! pathname syntax-table)
+  (let ((pathname (pathname->absolute-pathname (->pathname pathname))))
+    (let ((association (find-file-info/assoc pathname)))
+      (if association
+	  (set-cdr! association
+		    (transmit-values (cdr association)
+		      (lambda (ignore declarations)
+			(return-2 syntax-table declarations))))
+	  (set! file-info
+		(cons (cons pathname (return-2 syntax-table '()))
+		      file-info))))))
+
+(define (sf/add-file-declarations! pathname declarations)
+  (let ((pathname (pathname->absolute-pathname (->pathname pathname))))
+    (let ((association (find-file-info/assoc pathname)))
+      (if association
+	  (set-cdr! association
+		    (transmit-values (cdr association)
+		      (lambda (syntax-table declarations*)
+			(return-2 syntax-table
+				  (append! declarations*
+					   (list-copy declarations))))))
+	  (set! file-info
+		(cons (cons pathname (return-2 false declarations))
+		      file-info))))))
+
+(define file-info
+  '())
+
+(define (find-file-info pathname)
+  (let ((association
+	 (find-file-info/assoc (pathname->absolute-pathname pathname))))
+    (if association
+	(cdr association)
+	(return-2 false '()))))
+
+(define (find-file-info/assoc pathname)
+  (list-search-positive file-info
+    (lambda (entry)
+      (pathname=? (car entry) pathname))))
+
+(define (pathname=? x y)
+  (and (equal? (pathname-device x) (pathname-device y))
+       (equal? (pathname-directory x) (pathname-directory y))
+       (equal? (pathname-name x) (pathname-name y))))
+
 ;;;; File Syntaxer
 
 (define sf/default-input-pathname
@@ -129,7 +177,11 @@ Currently only the 68000 implementation needs this."
     (write bin-filename)
     (write-string " ")
     (write spec-filename)
-    (transmit-values (integrate/file input-pathname '() spec-pathname)
+    (transmit-values
+	(transmit-values (find-file-info input-pathname)
+	  (lambda (syntax-table declarations)
+	    (integrate/file input-pathname syntax-table declarations
+			    spec-pathname)))
       (lambda (expression externs events)
 	(fasdump (wrapping-hook
 		  (make-comment `((SOURCE-FILE . ,input-filename)
@@ -168,8 +220,10 @@ Currently only the 68000 implementation needs this."
 			    sf/default-externs-pathname)))
 
 (define (write-externs-file pathname externs)
-  (if (not (null? externs))
-      (fasdump externs pathname)))
+  (cond ((not (null? externs))
+	 (fasdump externs pathname))
+	((file-exists? pathname)
+	 (delete-file pathname))))
 
 (define (print-spec identifier names)
   (newline)
@@ -214,9 +268,9 @@ Currently only the 68000 implementation needs this."
 
 ;;;; Optimizer Top Level
 
-(define (integrate/file file-name declarations compute-free?)
+(define (integrate/file file-name syntax-table declarations compute-free?)
   (integrate/kernel (lambda ()
-		      (phase:syntax (phase:read file-name)))
+		      (phase:syntax (phase:read file-name) syntax-table))
 		    declarations))
 
 (define (integrate/simple preprocessor input declarations receiver)
@@ -254,9 +308,11 @@ Currently only the 68000 implementation needs this."
   (mark-phase "Read")
   (read-file filename))
 
-(define (phase:syntax s-expression)
+(define (phase:syntax s-expression #!optional syntax-table)
+  (if (or (unassigned? syntax-table) (not syntax-table))
+      (set! syntax-table (make-syntax-table system-global-syntax-table)))
   (mark-phase "Syntax")
-  (syntax* s-expression (make-syntax-table system-global-syntax-table)))
+  (syntax* s-expression syntax-table))
 
 (define (phase:transform scode)
   (mark-phase "Transform")