From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 13 Jun 1988 12:38:37 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~12728
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ce9b09ae3bb4ab73d487a34385e5ea63210a1aff;p=mit-scheme.git

Initial revision
---

diff --git a/v7/src/cref/anfile.scm b/v7/src/cref/anfile.scm
new file mode 100644
index 000000000..0e9426b3a
--- /dev/null
+++ b/v7/src/cref/anfile.scm
@@ -0,0 +1,218 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/anfile.scm,v 1.1 1988/06/13 12:38:14 cph Rel $
+
+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
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Free/Bound Variable Analysis
+
+(declare (usual-integrations))
+
+(define (analyze/directory filename)
+  (for-each
+   (lambda (input-pathname)
+     (let ((output-pathname (pathname-new-type input-pathname "free")))
+       (if (not (compare-file-modification-times input-pathname
+						 output-pathname))
+	   (analyze/file input-pathname output-pathname))))
+   (directory-read
+    (merge-pathnames (pathname-as-directory (->pathname filename))
+		     (string->pathname "*.bin")))))
+
+(define (read-analyzed-file input-pathname)
+  (let ((output-pathname (pathname-new-type input-pathname "free")))
+    (if (compare-file-modification-times input-pathname output-pathname)
+	(fasload output-pathname)
+	(analyze/file input-pathname output-pathname))))
+
+(define (analyze/file input-pathname output-pathname)
+  (fasdump (analyze/top-level (fasload input-pathname)) output-pathname))
+(define (compare-file-modification-times x y)
+  (let ((x (file-modification-time x)))
+    (and x
+	 (let ((y (file-modification-time y)))
+	   (and y
+		(< x y))))))
+
+(define (analyze/top-level expression)
+  (with-values (lambda () (sort-expressions (process-top-level expression)))
+    (lambda (definitions others)
+      (let ((definition-analysis
+	      (map analyze/top-level/definition definitions)))
+	(if (not (null? others))
+	    (cons (with-values (lambda ()
+				 (analyze/expression (make-sequence others)))
+		    (lambda (references assignments executions)
+		      (vector false references assignments executions
+			      'EXPRESSION)))
+		  definition-analysis)
+	    definition-analysis)))))
+
+(define (sort-expressions expressions)
+  (if (null? expressions)
+      (values '() '())
+      (let ((rest (lambda () (sort-expressions (cdr expressions)))))
+	(if (block-declaration? (car expressions))
+	    (rest)
+	    (with-values rest
+	      (lambda (definitions others)
+		(if (definition? (car expressions))
+		    (values (cons (car expressions) definitions) others)
+		    (values definitions (cons (car expressions) others)))))))))
+
+(define (process-top-level expression)
+  (cond ((comment? expression)
+	 (process-top-level (comment-expression expression)))
+	((sequence? expression)
+	 (mapcan process-top-level (sequence-actions expression)))
+	(else
+	 (list expression))))
+
+(define (analyze/top-level/definition definition)
+  (let ((name (definition-name definition))
+	(expression (definition-value definition)))
+    (cond ((unassigned-reference-trap? expression)
+	   (vector name '() '() '() 'UNASSIGNED))
+	  ((scode-constant? expression)
+	   (vector name '() '() '() 'CONSTANT))
+	  (else
+	   (with-values (lambda () (analyze/expression expression))
+	     (lambda (references assignments executions)
+	       (vector name references assignments executions
+		       (cond ((lambda? expression) 'LAMBDA)
+			     ((delay? expression) 'DELAY)
+			     (else 'EXPRESSION)))))))))
+
+(define (analyze/expression expression)
+  ((scode-walk analyze/dispatch expression) expression))
+
+(define (analyze/expressions expressions)
+  (if (null? expressions)
+      (values '() '() '())
+      (result-sum (lambda () (analyze/expression (car expressions)))
+		  (lambda () (analyze/expressions (cdr expressions))))))
+
+(define (analyze/uninteresting expression)
+  (values (if (primitive-procedure? expression) (list expression) '())
+	  '() '()))
+
+(define (analyze/error expression)
+  (error "Illegal expression" expression))
+
+(define (analyze/access expression)
+  (if (access-environment expression)
+      (warn "Access to non-global environment:" (unsyntax expression)))
+  (values (list expression) '() '()))
+
+(define (analyze/variable expression)
+  (values (list (variable-name expression)) '() '()))
+
+(define (analyze/assignment expression)
+  (with-values (lambda () (analyze/expression (assignment-value expression)))
+    (lambda (references assignments executions)
+      (values references
+	      (cons (assignment-name expression) assignments)
+	      executions))))
+
+(define (analyze/combination expression)
+  (result-sum (lambda ()
+		(let ((operator (combination-operator expression)))
+		  (cond ((variable? operator)
+			 (values '() '() (list (variable-name operator))))
+			((or (primitive-procedure? operator)
+			     (and (access? operator)
+				  (not (access-environment operator))))
+			 (values '() '() (list operator)))
+			(else
+			 (analyze/expression operator)))))
+	      (lambda ()
+		(analyze/expressions (combination-operands expression)))))
+
+(define (analyze/lambda expression)
+  (lambda-components expression
+    (lambda (name required optional rest auxiliary declarations body)
+      name declarations
+      (with-values (lambda () (analyze/expression body))
+	(lambda (references assignments executions)
+	  (let ((bound
+		 (append required
+			 optional
+			 (if rest (list rest) '())
+			 auxiliary)))
+	    (values (multiset-difference references bound)
+		    (multiset-difference assignments bound)
+		    (multiset-difference executions bound))))))))
+
+(define (analyze/error-combination expression)
+  (combination-components expression
+    (lambda (operator operands)
+      (analyze/expressions (list operator (car operands) (cadr operands))))))
+
+(define (analyze/delay expression)
+  (analyze/expression (delay-expression expression)))
+
+(define (analyze/sequence expression)
+  (analyze/expressions (sequence-actions expression)))
+
+(define (analyze/conditional expression)
+  (analyze/expressions (conditional-components expression list)))
+
+(define (analyze/disjunction expression)
+  (analyze/expressions (disjunction-components expression list)))
+
+(define (analyze/comment expression)
+  (analyze/expression (comment-expression expression)))
+
+(define analyze/dispatch
+  (make-scode-walker
+   analyze/uninteresting
+   `((ACCESS ,analyze/access)
+     (ASSIGNMENT ,analyze/assignment)
+     (COMBINATION ,analyze/combination)
+     (COMMENT ,analyze/comment)
+     (CONDITIONAL ,analyze/conditional)
+     (DEFINITION ,analyze/error)
+     (DELAY ,analyze/delay)
+     (DISJUNCTION ,analyze/disjunction)
+     (ERROR-COMBINATION ,analyze/error-combination)
+     (IN-PACKAGE ,analyze/error)
+     (LAMBDA ,analyze/lambda)
+     (SEQUENCE ,analyze/sequence)
+     (VARIABLE ,analyze/variable))))
+
+(define (result-sum first rest)
+  (with-values first
+    (lambda (references assignments executions)
+      (with-values rest
+	(lambda (references* assignments* executions*)
+	  (values (append! references references*)
+		  (append! assignments assignments*)
+		  (append! executions executions*)))))))
\ No newline at end of file
diff --git a/v7/src/cref/conpkg.scm b/v7/src/cref/conpkg.scm
new file mode 100644
index 000000000..7d3eaf361
--- /dev/null
+++ b/v7/src/cref/conpkg.scm
@@ -0,0 +1,152 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/conpkg.scm,v 1.1 1988/06/13 12:38:19 cph Rel $
+
+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
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Generate construction program from package model
+
+(declare (usual-integrations)
+	 (integrate-external "object"))
+
+;;; Construct expressions to construct the package structure.
+
+(define (construct-constructor pmodel)
+  (let ((packages (pmodel/packages pmodel)))
+    `((DECLARE (USUAL-INTEGRATIONS))
+      ,@(mapcan*
+	 `((LET ()
+	     (DECLARE (INTEGRATE-PRIMITIVE-PROCEDURES ENVIRONMENT-LINK-NAME))
+	     ,@(mapcan* (mapcan construct-links (pmodel/extra-packages pmodel))
+			construct-links packages)))
+	 construct-definitions
+	 (sort packages package-structure<?)))))
+
+(define (construct-definitions package)
+  (cond ((package/root? package)
+	 `((IN-PACKAGE #F
+	     ,@(map (lambda (binding) `(DEFINE ,(binding/name binding)))
+		    (package/source-bindings package)))))
+	((equal? (package/name package) '(PACKAGE))
+	 ;; This environment is hand built by the cold-load.
+	 '())
+	(else
+	 (package-definition
+	  (package/name package)
+	  `(IN-PACKAGE ,(package-reference (package/parent package))
+	     (LET (,@(map (lambda (binding) `(,(binding/name binding)))
+			  (package/source-bindings package)))
+	       (THE-ENVIRONMENT)))))))
+
+(define (construct-links package)
+  (if (equal? (package/name package) '(PACKAGE))
+      '()
+      (mapcan (lambda (binding)
+		(map (lambda (link)
+		       (let ((source (link/source link))
+			     (destination (link/destination link)))
+			 `(ENVIRONMENT-LINK-NAME
+			   ,(package-reference (binding/package destination))
+			   ,(package-reference (binding/package source))
+			   ',(binding/name source))))
+		     (binding/links binding)))
+	      (btree-fringe (package/bindings package)))))
+
+(define (package/source-bindings package)
+  (list-transform-positive (btree-fringe (package/bindings package))
+    (lambda (binding)
+      (eq? (binding/source-binding binding) binding))))
+
+(define (package-structure<? x y)
+  (cond ((package/topological<? x y) true)
+	((package/topological<? y x) false)
+	(else (package<? x y))))
+
+(define (package/topological<? x y)
+  (and (not (eq? x y))
+       (let loop ((y (package/parent y)))
+	 (and y
+	      (if (eq? x y)
+		  true
+		  (loop (package/parent y)))))))
+
+;;; Construct a procedure which will load the files into the package
+;;; structure.
+
+(define (construct-loader pmodel)
+  `((DECLARE (USUAL-INTEGRATIONS))
+    (LAMBDA (LOAD KEY-ALIST)
+      (LET ((LOOKUP-KEY
+	     (LAMBDA (KEY)
+	       (LET LOOP ((ALIST KEY-ALIST))
+		 (IF (NULL? ALIST)
+		     (ERROR "Missing key" KEY))
+		 (IF (EQ? KEY (CAR (CAR ALIST)))
+		     (CDR (CAR ALIST))
+		     (LOOP (CDR ALIST)))))))
+	LOOKUP-KEY			;ignore if not referenced
+	,@(mapcan (lambda (package)
+		    (let ((reference (package-reference package)))
+		      (if (> (package/n-files package) 1)
+			  `((LET ((ENVIRONMENT ,reference))
+			      ,@(load-package package 'ENVIRONMENT)))
+			  (load-package package reference))))
+		  (pmodel/packages pmodel))))))
+
+(define (load-package package environment)
+  (mapcan (lambda (file-case)
+	    (let ((type (file-case/type file-case)))
+	      (if type
+		  `((CASE (LOOKUP-KEY ',type)
+		      ,@(map (lambda (clause)
+			       `(,(file-case-clause/keys clause)
+				 ,@(clause-loader clause environment)))
+			     (file-case/clauses file-case))))
+		  (clause-loader (car (file-case/clauses file-case))
+				 environment))))
+	  (package/file-cases package)))
+
+(define (clause-loader clause environment)
+  (let ((files (file-case-clause/files clause)))
+    (if (null? files)
+	`(FALSE)
+	(map (lambda (file)
+	       `(LOAD ,(pathname->string file) ,environment))
+	     files))))
+
+(define (package-definition name value)
+  (let ((path (reverse name)))
+    `((PACKAGE/ADD-CHILD! (FIND-PACKAGE ',(reverse (cdr path)))
+			  ',(car path)
+			  ,value))))
+
+(define (package-reference package)
+  `(PACKAGE/ENVIRONMENT (FIND-PACKAGE ',(package/name package))))
\ No newline at end of file
diff --git a/v7/src/cref/cref.pkg b/v7/src/cref/cref.pkg
new file mode 100644
index 000000000..148e16fd7
--- /dev/null
+++ b/v7/src/cref/cref.pkg
@@ -0,0 +1,77 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/cref.pkg,v 1.1 1988/06/13 12:38:35 cph Exp $
+
+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
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; CREF Packaging
+
+(global-definitions "../runtime/runtim")
+
+(define-package (cross-reference)
+  (files "mset"
+	 "btree"
+	 "object"
+	 "toplev")
+  (parent ())
+  (export ()
+	  cref/generate-all
+	  cref/generate-constructors
+	  cref/generate-cref
+	  cref/generate-trivial-constructor))
+
+(define-package (cross-reference analyze-file)
+  (files "anfile")
+  (parent (cross-reference))
+  (export (cross-reference)
+	  analyze/directory
+	  read-analyzed-file))
+
+(define-package (cross-reference constructor)
+  (files "conpkg")
+  (parent (cross-reference))
+  (export (cross-reference)
+	  construct-constructor
+	  construct-loader))
+
+(define-package (cross-reference formatter)
+  (files "forpkg")
+  (parent (cross-reference))
+  (export (cross-reference)
+	  format-packages))
+
+(define-package (cross-reference reader)
+  (files "redpkg")
+  (parent (cross-reference))
+  (export (cross-reference)
+	  read-file-analyses!
+	  read-package-model
+	  resolve-references!))
\ No newline at end of file
diff --git a/v7/src/cref/cref.sf b/v7/src/cref/cref.sf
new file mode 100644
index 000000000..e5b86a910
--- /dev/null
+++ b/v7/src/cref/cref.sf
@@ -0,0 +1,39 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/cref.sf,v 1.1 1988/06/13 12:38:37 cph Rel $
+
+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
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+(sf/set-default-syntax-table! system-global-syntax-table)
+(sf-conditionally "object")
+(sf-directory ".")
+(cref/generate-all "cref")(sf "cref.con" "cref.bcon")
+(sf "cref.ldr" "cref.bldr")
\ No newline at end of file
diff --git a/v7/src/cref/forpkg.scm b/v7/src/cref/forpkg.scm
new file mode 100644
index 000000000..bd33be680
--- /dev/null
+++ b/v7/src/cref/forpkg.scm
@@ -0,0 +1,353 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/forpkg.scm,v 1.1 1988/06/13 12:38:22 cph Exp $
+
+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
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Package Model Formatter
+
+(declare (usual-integrations)
+	 (integrate-external "object"))
+
+(define (format-packages pmodel)
+  (let ((indentation "  ")
+	(width 79)
+	(root-package (pmodel/root-package pmodel))	(packages (pmodel/packages pmodel)))
+    (let ((free-references
+	   (mapcan (lambda (package)
+		     (list-transform-negative
+			 (btree-fringe (package/references package))
+		       reference/binding))
+		   packages)))
+      (if (not (null? free-references))
+	  (begin
+	    (format-references indentation width "Free References" false
+	      (sort free-references reference<?))
+	    (write-string "\f\n"))))
+    (with-values (lambda () (get-value-cells/unusual packages))
+      (lambda (undefined multiple)
+	(if (not (null? undefined))
+	    (begin
+	      (format-value-cells indentation width "Undefined Bindings"
+				  undefined)
+	      (write-string "\f\n")))
+	(if (not (null? multiple))
+	    (begin
+	      (format-value-cells indentation width
+				  "Bindings with Multiple Definitions"
+				  multiple)
+	      (write-string "\f\n")))))
+    (if (not (memq root-package packages))
+	(begin
+	  (write-label "Global References")
+	  (for-each
+	   (lambda (binding)
+	     (let ((references (binding/references binding)))
+	       (if (not (null? references))
+		   (format-expressions
+		    indentation width root-package
+		    (write-to-string (binding/name binding))
+		    (mapcan (lambda (reference)
+			      (list-copy (reference/expressions reference)))
+			    references)))))
+	   (btree-fringe (package/bindings root-package)))
+	  (write-string "\f\n")))
+    (format-references
+     indentation width "Primitives" root-package
+     (btree-fringe (package/references (pmodel/primitive-package pmodel))))
+    (for-each (lambda (package)
+		(write-string "\f\n")
+		(format-package indentation width package))
+	      packages)))
+
+(define (format-package indentation width package)
+  (write-package-name "Package" package)
+  (if (package/parent package)
+      (write-package-name "Parent" (package/parent package)))
+  (format-package/files indentation width package)
+  (let ((classes
+	 (classify-bindings-by-package
+	  (lambda (binding)
+	    (binding/package (binding/source-binding binding)))
+	  (btree-fringe (package/bindings package)))))
+    (let ((class (assq package classes)))
+      (if class
+	  (format-package/bindings indentation width package (cdr class)))
+      (for-each (lambda (class)
+		  (if (not (eq? package (car class)))
+		      (format-package/imports indentation width package
+					      (car class)
+					      (cdr class))))
+		classes)
+      (if class
+	  (for-each
+	   (lambda (class)
+	     (if (not (eq? package (car class)))
+		 (format-package/exports indentation width (car class)
+					 (sort (cdr class) binding<?))))
+	   (classify-bindings-by-package
+	    binding/package
+	    (mapcan (lambda (binding)
+		      (list-copy
+		       (value-cell/bindings (binding/value-cell binding))))
+		    (cdr class))))))))
+
+(define (format-value-cells indentation width label value-cells)
+  (write-label label)
+  (for-each (lambda (binding)
+	      (format-expressions
+	       indentation width false
+	       (string-append
+		(write-to-string (binding/name binding))
+		" "
+		(write-to-string (package/name (binding/package binding))))
+	       (binding/expressions binding)))
+	    (sort (map value-cell/source-binding value-cells)
+		  binding<?)))
+
+(define (get-value-cells/unusual packages)
+  (with-values (lambda () (get-value-cells packages))
+    (lambda (unlinked linked)
+      (values
+       (list-transform-positive linked
+	 (lambda (value-cell)
+	   (null? (value-cell/expressions value-cell))))
+       (list-transform-positive (append unlinked linked)
+	 (lambda (value-cell)
+	   (let ((expressions (value-cell/expressions value-cell)))
+	     (and (not (null? expressions))
+		  (not (null? (cdr expressions)))))))))))
+
+(define (get-value-cells packages)
+  (let ((unlinked '())
+	(linked '()))
+    (for-each
+     (lambda (package)
+       (for-each (lambda (binding)
+		   (let ((value-cell (binding/value-cell binding)))
+		     (cond ((null? (cdr (value-cell/bindings value-cell)))
+			    (set! unlinked (cons value-cell unlinked)))
+			   ((not (memq value-cell linked))
+			    (set! linked (cons value-cell linked))))))
+		 (btree-fringe (package/bindings package))))
+     packages)
+    (values unlinked linked)))
+
+(define (write-package-name label package)
+  (write-string label)
+  (write-string ": ")
+  (write (package/name package))
+  (newline))
+
+(define (format-package/files indentation width package)
+  width
+  (if (positive? (package/n-files package))
+      (begin
+	(newline)
+	(write-label "Files")
+	(newline)
+	(for-each (lambda (pathname)
+		    (write-string indentation)
+		    (write-string (pathname->string pathname))
+		    (newline))
+		  (package/files package)))))
+
+(define (format-package/bindings indentation width package bindings)
+  (format-bindings
+   indentation width package bindings
+   "Bindings"
+   (lambda (binding)
+     (let ((name (write-to-string (binding/name binding))))
+       (if (< (package/n-files package) 2)
+	   name
+	   (string-append
+	    name
+	    " "
+	    (write-to-string
+	     (map expression/file (binding/expressions binding)))))))))
+
+(define (format-package/imports indentation width local-package remote-package
+				bindings)
+  (format-exports indentation width local-package remote-package bindings
+		  local-map/import "Imports from"))
+
+(define (format-package/exports indentation width remote-package bindings)
+  (format-exports indentation width remote-package remote-package bindings
+		  local-map/export "Exports to"))
+
+(define (format-exports indentation width local-package remote-package
+			bindings local-map label)
+  (format-bindings
+   indentation width local-package bindings
+   (string-append label
+		  " package "
+		  (write-to-string (package/name remote-package)))
+   (lambda (destination-binding)
+     (with-values
+	 (lambda ()
+	   (local-map (binding/source-binding destination-binding)
+		      destination-binding))
+       (lambda (local-binding remote-binding)
+	 (let ((local-name (binding/name local-binding))
+	       (remote-name (binding/name remote-binding)))
+	   (let ((name-string (write-to-string local-name)))
+	     (if (eq? local-name remote-name)
+		 name-string
+		 (string-append name-string
+				" ["
+				(write-to-string remote-name)
+				"]")))))))))
+
+(define (local-map/export source destination)
+  (values source destination))
+
+(define (local-map/import source destination)
+  (values destination source))
+
+(define (format-bindings indentation width package
+			 bindings label binding->name)
+  (newline)
+  (write-label label)
+  (for-each (lambda (binding)
+	      (format-expressions
+	       indentation width package
+	       (binding->name binding)
+	       (mapcan (lambda (reference)
+			 (list-copy (reference/expressions reference)))
+		       (binding/references binding))))
+	    bindings))
+
+(define (classify-bindings-by-package binding->package bindings)
+  (let ((classes '()))
+    (for-each
+     (lambda (binding)
+       (let ((package (binding->package binding)))
+	 (let ((entry (assq package classes)))
+	   (if entry
+	       (set-cdr! entry (cons binding (cdr entry)))
+	       (set! classes (cons (list package binding) classes))))))
+     bindings)
+    (for-each (lambda (class)
+		(set-cdr! class (reverse! (cdr class))))
+	      classes)
+    (sort classes
+	  (lambda (x y)
+	    (package<? (car x) (car y))))))
+
+(define (format-references indentation width label package references)
+  (write-label label)
+  (for-each (lambda (reference)
+	      (format-expressions indentation width package
+				  (write-to-string (reference/name reference))
+				  (reference/expressions reference)))
+	    references))
+
+(define (format-expressions indentation width package name expressions)
+  (with-values (lambda ()
+		 (classify-expression-names
+		  (map (lambda (expression)
+			 (expression->name expression package))
+		       expressions)))
+    (lambda (symbols pairs)
+      (write-string indentation)
+      (write-string name)
+      (newline)
+      (let ((indentation (new-indentation indentation)))
+	(write-strings/compact indentation width
+			       (map write-to-string (sort symbols symbol<?)))
+	(write-items/miser indentation width write
+	  (sort pairs
+	    (lambda (x y)
+	      (or (string<? (car x) (car y))
+		  (and (string=? (car x) (car y))
+		       (or (null? (cdr x))
+			   (and (not (null? (cdr y)))
+				(symbol<? (cadr x) (cadr y)))))))))))))
+
+(define (classify-expression-names names)
+  (if (null? names)
+      (values '() '())
+      (with-values (lambda () (classify-expression-names (cdr names)))
+	(lambda (symbols pairs)
+	  (if (pair? (car names))
+	      (values symbols (cons (car names) pairs))
+	      (values (cons (car names) symbols) pairs))))))
+
+(define (expression->name expression package)
+  (let ((package* (expression/package expression))
+	(value-cell (expression/value-cell expression)))
+    (let ((binding
+	   (and value-cell
+		(list-search-positive (value-cell/bindings value-cell)
+		  (lambda (binding)
+		    (eq? package* (binding/package binding)))))))
+      (if binding
+	  (let ((name (binding/name binding)))
+	    (if (and package
+		     (let ((binding* (package/find-binding package name)))
+		       (and binding*
+			    (eq? (binding/value-cell binding)
+				 (binding/value-cell binding*)))))
+		name
+		(list (expression/file expression) name)))
+	  (list (expression/file expression))))))
+
+(define (write-label label)
+  (write-string label)
+  (write-string ":")
+  (newline))
+
+(define (write-strings/compact indentation width strings)
+  (if (not (null? strings))
+      (begin
+	(let loop ((strings strings) (offset 0) (prefix indentation))
+	  (if (not (null? strings))
+	      (let ((length (string-length (car strings))))
+		(let ((new-offset (+ offset (string-length prefix) length)))
+		  (if (and (> new-offset width)
+			   (not (zero? offset)))
+		      (begin (newline)
+			     (loop strings 0 indentation))
+		      (begin (write-string prefix)
+			     (write-string (car strings))
+			     (loop (cdr strings) new-offset " ")))))))
+	(newline))))
+
+(define (write-items/miser indentation width write-item items)
+  width
+  (for-each (lambda (item)
+	      (write-string indentation)
+	      (write-item item)
+	      (newline))
+	    items))
+
+(define (new-indentation indentation)
+  (string-append indentation "    "))
\ No newline at end of file
diff --git a/v7/src/cref/make.scm b/v7/src/cref/make.scm
new file mode 100644
index 000000000..6ae4e70ad
--- /dev/null
+++ b/v7/src/cref/make.scm
@@ -0,0 +1,40 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/make.scm,v 1.1 1988/06/13 12:38:24 cph Exp $
+
+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
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Package Model: System Construction
+
+(declare (usual-integrations))
+
+(package/system-loader "cref" '() 'QUERY)
+(add-system! (make-system "CREF" 0 0 '()))
\ No newline at end of file
diff --git a/v7/src/cref/mset.scm b/v7/src/cref/mset.scm
new file mode 100644
index 000000000..f0536781b
--- /dev/null
+++ b/v7/src/cref/mset.scm
@@ -0,0 +1,53 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/mset.scm,v 1.1 1988/06/13 12:38:26 cph Rel $
+
+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
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Multiset Operations
+
+(declare (usual-integrations))
+
+(define (multiset->set multiset)
+  (if (null? multiset)
+      '()
+      (let ((set (multiset->set (cdr multiset))))
+	(if (memq (car multiset) set)
+	    set
+	    (cons (car multiset) set)))))
+
+(define (multiset-difference x y)
+  (if (null? y)
+      x
+      (let loop ((x x))
+	(cond ((null? x) '())
+	      ((memq (car x) y) (loop (cdr x)))
+	      (else (cons (car x) (loop (cdr x))))))))
\ No newline at end of file
diff --git a/v7/src/cref/object.scm b/v7/src/cref/object.scm
new file mode 100644
index 000000000..1d0de6068
--- /dev/null
+++ b/v7/src/cref/object.scm
@@ -0,0 +1,185 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/object.scm,v 1.1 1988/06/13 12:38:28 cph Exp $
+
+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
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Package Model Data Structures
+
+(declare (usual-integrations))
+
+(define-structure (package-description (constructor make-package-description)
+				       (conc-name package-description/))
+  (name false read-only true)
+  (file-cases false read-only true)
+  (parent false read-only true)
+  (initialization false read-only true)
+  (exports false read-only true)
+  (imports false read-only true))
+
+(define-structure (pmodel (conc-name pmodel/))
+  (root-package false read-only true)
+  (primitive-package false read-only true)
+  (packages false read-only true)
+  (extra-packages false read-only true)
+  (default-pathname false read-only true))
+
+(define-structure (package
+		   (constructor %make-package
+				(name file-cases files initialization parent))
+		   (conc-name package/))
+  (name false read-only true)
+  (file-cases false read-only true)
+  (files false read-only true)
+  (initialization false read-only true)
+  parent
+  (children '())
+  (bindings (make-btree symbol<? binding/name) read-only true)
+  (references (make-btree symbol<? reference/name) read-only true))
+
+(define (make-package name file-cases initialization parent)
+  (let ((files
+	 (mapcan (lambda (file-case)
+		   (mapcan (lambda (clause) (list-copy (cdr clause)))
+			   (cdr file-case)))
+		 file-cases)))
+    (%make-package name
+		   file-cases
+		   files
+		   initialization
+		   parent)))
+
+(define-integrable (package/n-files package)
+  (length (package/files package)))
+
+(define-integrable (package/root? package)
+  (null? (package/name package)))
+
+(define (package/find-binding package name)
+  (btree-lookup (package/bindings package) name
+    identity-procedure
+    (lambda (name) name false)))
+
+(define-integrable (file-case/type file-case)
+  (car file-case))
+
+(define-integrable (file-case/clauses file-case)
+  (cdr file-case))
+
+(define-integrable (file-case-clause/keys clause)
+  (car clause))
+
+(define-integrable (file-case-clause/files clause)
+  (cdr clause))
+
+(define-structure (binding (constructor %make-binding
+					(package name value-cell))
+			   (conc-name binding/))
+  (package false read-only true)
+  (name false read-only true)
+  (value-cell false read-only true)
+  (references '())
+  (links '()))
+
+(define (make-binding package name value-cell)
+  (let ((binding (%make-binding package name value-cell)))
+    (set-value-cell/bindings!
+     value-cell
+     (cons binding (value-cell/bindings value-cell)))
+    binding))
+
+(define-integrable (binding/expressions binding)
+  (value-cell/expressions (binding/value-cell binding)))
+
+(define-integrable (binding/source-binding binding)
+  (value-cell/source-binding (binding/value-cell binding)))
+
+(define (binding/internal? binding)
+  (eq? binding (binding/source-binding binding)))
+
+(define-structure (value-cell (constructor make-value-cell ())
+			      (conc-name value-cell/))
+  (bindings '())
+  (expressions '())
+  (source-binding false))
+
+(define-structure (link (constructor %make-link)
+			(conc-name link/))
+  (source false read-only true)
+  (destination false read-only true))
+
+(define (make-link source-binding destination-binding)
+  (let ((link (%make-link source-binding destination-binding)))
+    (set-binding/links! source-binding
+			(cons link (binding/links source-binding)))
+    link))
+
+(define-structure (expression (constructor make-expression (package file type))
+			      (conc-name expression/))
+  (package false read-only true)
+  (file false read-only true)
+  (type false read-only true)
+  (references '())
+  (value-cell false))
+
+(define-structure (reference (constructor %make-reference (package name))
+			     (conc-name reference/))
+  (package false read-only true)
+  (name false read-only true)
+  (expressions '())
+  (binding false))
+
+(define-integrable (symbol<? x y)
+  (string<? (symbol->string x) (symbol->string y)))
+
+(define (symbol-list=? x y)
+  (if (null? x)
+      (null? y)
+      (and (not (null? y))
+	   (eq? (car x) (car y))
+	   (symbol-list=? (cdr x) (cdr y)))))
+
+(define (symbol-list<? x y)
+  (and (not (null? y))
+       (if (or (null? x)
+	       (symbol<? (car x) (car y)))
+	   true
+	   (and (eq? (car x) (car y))
+		(symbol-list<? (cdr x) (cdr y))))))
+
+(define (package<? x y)
+  (symbol-list<? (package/name x) (package/name y)))
+
+(define (binding<? x y)
+  (symbol<? (binding/name x) (binding/name y)))
+
+(define (reference<? x y)
+  (symbol<? (reference/name x) (reference/name y)))
\ No newline at end of file
diff --git a/v7/src/cref/redpkg.scm b/v7/src/cref/redpkg.scm
new file mode 100644
index 000000000..4f01f13f7
--- /dev/null
+++ b/v7/src/cref/redpkg.scm
@@ -0,0 +1,381 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/redpkg.scm,v 1.1 1988/06/13 12:38:30 cph Exp $
+
+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
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Package Model Reader
+
+(declare (usual-integrations)
+	 (integrate-external "object"))
+
+(define (read-package-model filename)
+  (let* ((pathname (pathname->absolute-pathname (->pathname filename)))
+	 (default-pathname (pathname-directory-path pathname)))
+    (with-values
+	(lambda ()
+	  (sort-descriptions
+	   (map (lambda (expression)
+		  (parse-package-expression expression))
+		(read-package-description-file pathname))))
+      (lambda (packages globals)
+	(let ((pmodel (descriptions->pmodel packages default-pathname)))
+	  (for-each
+	   (let ((root-package (pmodel/root-package pmodel)))
+	     (lambda (pathname)
+	       (for-each (let ((expression
+				(make-expression root-package
+						 (pathname->string pathname)
+						 false)))
+			   (lambda (name)
+			     (bind! root-package name expression)))
+			 (fasload
+			  (merge-pathnames (pathname-new-type pathname "glob")
+					   default-pathname)))))
+	   globals)
+	  pmodel)))))
+
+(define (sort-descriptions descriptions)
+  (let loop
+      ((descriptions descriptions)
+       (packages '())
+       (globals '()))
+    (cond ((null? descriptions)
+	   (values (reverse! packages) globals))
+	  ((package-description? (car descriptions))
+	   (loop (cdr descriptions)
+		 (cons (car descriptions) packages)
+		 globals))
+	  ((and (pair? (car descriptions))
+		(eq? (car (car descriptions)) 'GLOBAL-DEFINITIONS))
+	   (loop (cdr descriptions)
+		 packages
+		 (append globals (cdr (car descriptions)))))
+	  (else
+	   (error "Illegal description" (car descriptions))))))
+
+(define (read-package-description-file pathname)
+  (read-file (pathname-default-type pathname "pkg")))
+
+(define (read-file-analyses! pmodel)
+  (for-each (lambda (package)
+	      (for-each (lambda (pathname)
+			  (read-file-analysis! pmodel package pathname))
+			(package/files package)))
+	    (pmodel/packages pmodel)))
+
+(define (read-file-analysis! pmodel package pathname)
+  (let ((filename (pathname->string pathname))
+	(root-package (pmodel/root-package pmodel))
+	(primitive-package (pmodel/primitive-package pmodel)))
+    (for-each (lambda (entry)
+		(let ((name (vector-ref entry 0))
+		      (expression
+		       (make-expression package
+					filename
+					(vector-ref entry 4))))
+		  (let ((intern!
+			 (lambda (name)
+			   (cond ((symbol? name)
+				  (make-reference package name expression))
+				 ((primitive-procedure? name)
+				  (make-reference
+				   primitive-package
+				   (primitive-procedure-name name)
+				   expression))
+				 ((access? name)
+				  (if (access-environment name)
+				      (error "Non-root access" name))
+				  (make-reference root-package
+						  (access-name name)
+						  expression))
+				 (else
+				  (error "Illegal reference name" name))))))
+		    (for-each intern! (vector-ref entry 1))
+		    (for-each intern! (vector-ref entry 2))
+		    (for-each intern! (vector-ref entry 3)))
+		  (if name
+		      (bind! package name expression))))
+	      (read-analyzed-file
+	       (merge-pathnames (pathname-new-type pathname "bin")
+				(pmodel/default-pathname pmodel))))))
+
+(define (resolve-references! pmodel)
+  (for-each (lambda (package)
+	      (for-each resolve-reference!
+			(btree-fringe (package/references package))))
+	    (pmodel/packages pmodel)))
+
+(define (resolve-reference! reference)
+  (let ((binding
+	 (package-lookup (reference/package reference)
+			 (reference/name reference))))
+    (if binding
+	(begin
+	  (set-reference/binding! reference binding)
+	  (set-binding/references! binding
+				   (cons reference
+					 (binding/references binding)))))))
+
+;;;; Package Descriptions
+
+(define (parse-package-expression expression)
+  (if (not (pair? expression))
+      (error "package expression not a pair" expression))
+  (case (car expression)
+    ((DEFINE-PACKAGE)
+     (parse-package-description (parse-name (cadr expression))
+				(cddr expression)))
+    ((GLOBAL-DEFINITIONS)
+     (let ((filenames (cdr expression)))
+       (if (not (check-list filenames string?))
+	   (error "illegal filenames" filenames))
+       (cons 'GLOBAL-DEFINITIONS (map parse-filename filenames))))
+    (else
+     (error "unrecognized expression keyword" (car expression)))))
+
+(define (parse-package-description name options)
+  (let ((none "none"))
+    (let ((file-cases '())
+	  (parent none)
+	  (initialization none)
+	  (exports '())
+	  (imports '()))
+      (if (not (list? options))
+	  (error "options not list" options))
+      (for-each (lambda (option)
+		  (if (not (pair? option))
+		      (error "Illegal option" option))
+		  (case (car option)
+		    ((FILES)
+		     (set! file-cases
+			   (cons (parse-filenames (cdr option)) file-cases)))
+		    ((FILE-CASE)
+		     (set! file-cases
+			   (cons (parse-file-case (cdr option)) file-cases)))
+		    ((PARENT)
+		     (if (not (eq? parent none))
+			 (error "option reoccurs" option))
+		     (if (not (and (pair? (cdr option)) (null? (cddr option))))
+			 (error "illegal option" option))
+		     (set! parent (parse-name (cadr option))))
+		    ((EXPORT)
+		     (set! exports (cons (parse-export (cdr option)) exports)))
+		    ((IMPORT)
+		     (set! imports (cons (parse-import (cdr option)) imports)))
+		    ((INITIALIZATION)
+		     (if (not (eq? initialization none))
+			 (error "option reoccurs" option))
+		     (set! initialization (parse-initialization (cdr option))))
+		    (else
+		     (error "unrecognized option keyword" (car option)))))
+		options)
+      (make-package-description
+       name
+       file-cases
+       (if (eq? parent none) 'NONE parent)
+       (if (eq? initialization none) '#F initialization)
+       (reverse! exports)
+       (reverse! imports)))))
+
+(define (parse-name name)
+  (if (not (check-list name symbol?))
+      (error "illegal name" name))
+  name)
+
+(define (parse-filenames filenames)
+  (if (not (check-list filenames string?))
+      (error "illegal filenames" filenames))
+  (list #F (cons 'ELSE (map parse-filename filenames))))
+
+(define (parse-file-case file-case)
+  (if (not (and (pair? file-case)
+		(symbol? (car file-case))
+		(check-list (cdr file-case)
+		  (lambda (clause)
+		    (and (pair? clause)
+			 (or (eq? 'ELSE (car clause))
+			     (check-list (car clause) symbol?))
+			 (check-list (cdr clause) string?))))))
+      (error "Illegal file-case" file-case))
+  (cons (car file-case)
+	(map (lambda (clause)
+	       (cons (car clause)
+		     (map parse-filename (cdr clause))))
+	     (cdr file-case))))
+
+(define-integrable (parse-filename filename)
+  (string->pathname filename))
+
+(define (parse-initialization initialization)
+  (if (not (and (pair? initialization) (null? (cdr initialization))))
+      (error "illegal initialization" initialization))
+  (car initialization))
+
+(define (parse-import import)
+  (if (not (and (pair? import) (check-list (cdr import) symbol?)))
+      (error "illegal import" import))
+  (cons (parse-name (car import)) (cdr import)))
+
+(define (parse-export export)
+  (if (not (and (pair? export) (check-list (cdr export) symbol?)))
+      (error "illegal export" export))
+  (cons (parse-name (car export)) (cdr export)))
+
+(define (check-list items predicate)
+  (let loop ((items items))
+    (if (pair? items)
+	(if (predicate (car items))
+	    (loop (cdr items))
+	    false)
+	(null? items))))
+
+;;;; Packages
+
+(define (package-lookup package name)
+  (let package-loop ((package package))
+    (or (package/find-binding package name)
+	(and (package/parent package)
+	     (package-loop (package/parent package))))))
+
+(define (name->package packages name)
+  (list-search-positive packages
+    (lambda (package)
+      (symbol-list=? name (package/name package)))))
+
+(define (descriptions->pmodel descriptions default-pathname)
+  (let ((packages
+	 (map (lambda (description)
+		(make-package
+		 (package-description/name description)
+		 (package-description/file-cases description)
+		 (package-description/initialization description)
+		 'UNKNOWN))
+	      descriptions))
+	(extra-packages '()))
+    (let ((root-package
+	   (or (name->package packages '())
+	       (make-package '() '() '#F false))))
+      (let ((get-package
+	     (lambda (name)
+	       (if (null? name)
+		   root-package
+		   (or (name->package packages name)
+		       (let ((package (make-package name '() #F 'UNKNOWN)))
+			 (set! extra-packages (cons package extra-packages))
+			 package))))))
+	(for-each (lambda (package description)
+		    (let ((parent
+			   (let ((parent-name
+				  (package-description/parent description)))
+			     (and (not (eq? parent-name 'NONE))
+				  (get-package parent-name)))))
+		      (set-package/parent! package parent)
+		      (if parent
+			  (set-package/children!
+			   parent
+			   (cons package (package/children parent)))))
+		    (for-each (lambda (export)
+				(let ((destination (get-package (car export))))
+				  (for-each (lambda (name)
+					      (link! package name
+						     destination name))
+					    (cdr export))))
+			      (package-description/exports description))
+		    (for-each (lambda (import)
+				(let ((source (get-package (car import))))
+				  (for-each (lambda (name)
+					      (link! source name package name))
+					    (cdr import))))
+			      (package-description/imports description)))
+		  packages
+		  descriptions))
+      (make-pmodel root-package
+		   (make-package primitive-package-name '() '() false)
+		   packages
+		   extra-packages
+		   default-pathname))))
+
+(define primitive-package-name
+  (list (string->uninterned-symbol "primitives")))
+
+;;;; Binding and Reference
+
+(define (bind! package name expression)
+  (let ((value-cell (binding/value-cell (intern-binding! package name))))
+    (set-expression/value-cell! expression value-cell)
+    (set-value-cell/expressions!
+     value-cell
+     (cons expression (value-cell/expressions value-cell)))))
+
+(define (link! source-package source-name destination-package destination-name)
+  (let ((source-binding (intern-binding! source-package source-name)))
+    (make-link source-binding
+	       (btree-insert! (package/bindings destination-package)
+			      destination-name
+		 (lambda (destination-name)
+		   (make-binding destination-package
+				 destination-name
+				 (binding/value-cell source-binding)))
+		 (lambda (binding)
+		   binding
+		   (error "Attempt to reinsert binding" destination-name))
+		 identity-procedure))))
+
+(define (intern-binding! package name)
+  (btree-insert! (package/bindings package) name
+    (lambda (name)
+      (let ((value-cell (make-value-cell)))
+	(let ((binding (make-binding package name value-cell)))
+	  (set-value-cell/source-binding! value-cell binding)
+	  binding)))
+    identity-procedure
+    identity-procedure))
+
+(define (make-reference package name expression)
+  (let ((add-reference!
+	 (lambda (reference)
+	   (set-reference/expressions!
+	    reference
+	    (cons expression (reference/expressions reference)))
+	   (set-expression/references!
+	    expression
+	    (cons reference (expression/references expression))))))
+    (btree-insert! (package/references package) name
+      (lambda (name)
+	(%make-reference package name))
+      (lambda (reference)
+	(if (not (memq expression (reference/expressions reference)))
+	    (add-reference! reference))
+	reference)
+      (lambda (reference)
+	(add-reference! reference)
+	reference))))
\ No newline at end of file
diff --git a/v7/src/cref/toplev.scm b/v7/src/cref/toplev.scm
new file mode 100644
index 000000000..b2b446403
--- /dev/null
+++ b/v7/src/cref/toplev.scm
@@ -0,0 +1,102 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/toplev.scm,v 1.1 1988/06/13 12:38:33 cph Exp $
+
+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
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Package Model: Top Level
+
+(declare (usual-integrations))
+
+(define (generate/common kernel)
+  (lambda (filename)
+    (let ((pathname (pathname->absolute-pathname (->pathname filename))))
+      (let ((pmodel (read-package-model pathname)))
+	(read-file-analyses! pmodel)
+	(resolve-references! pmodel)
+	(kernel pathname pmodel)))))
+
+(define (cref/generate-trivial-constructor filename)
+  (let ((pathname (pathname->absolute-pathname (->pathname filename))))
+    (write-constructor pathname (read-package-model pathname))))
+
+(define cref/generate-cref
+  (generate/common
+   (lambda (pathname pmodel)
+     (write-cref pathname pmodel))))
+
+(define cref/generate-constructors
+  (generate/common
+   (lambda (pathname pmodel)     (write-constructor pathname pmodel)
+     (write-loader pathname pmodel))))
+
+(define cref/generate-all
+  (generate/common
+   (lambda (pathname pmodel)
+     (write-cref pathname pmodel)
+     (write-globals pathname pmodel)
+     (write-constructor pathname pmodel)
+     (write-loader pathname pmodel))))
+
+(define (write-constructor pathname pmodel)
+  (let ((constructor (construct-constructor pmodel)))
+    (with-output-to-file (pathname-new-type pathname "con")
+      (lambda ()
+	(write-string ";;; -*-Scheme-*-")
+	(newline)
+	(write-string ";;; program to make package structure")
+	(for-each (lambda (expression)
+		    (pp expression 'AS-CODE))
+		  constructor)))))
+
+(define (write-loader pathname pmodel)
+  (let ((loader (construct-loader pmodel)))
+    (with-output-to-file (pathname-new-type pathname "ldr")
+      (lambda ()
+	(write-string ";;; -*-Scheme-*-")
+	(newline)
+	(write-string ";;; program to load package contents")
+	(for-each (lambda (expression)
+		    (pp expression 'AS-CODE))
+		  loader)))))
+
+(define (write-cref pathname pmodel)
+  (with-output-to-file (pathname-new-type pathname "cref")
+    (lambda ()
+      (format-packages pmodel))))
+
+(define (write-globals pathname pmodel)
+  (fasdump (map binding/name
+		(list-transform-positive
+		    (btree-fringe
+		     (package/bindings (pmodel/root-package pmodel)))
+		  binding/source-binding))
+	   (pathname-new-type pathname "glob")))
\ No newline at end of file