From d8c2147d78b23ecb6bd55e78ce43d3960f49393b Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 28 Oct 1988 07:03:24 +0000
Subject: [PATCH] Several changes to make package model objects fasdumpable.
---
v7/src/cref/cref.pkg | 13 +++++++++--
v7/src/cref/make.scm | 4 ++--
v7/src/cref/object.scm | 51 +++++++++++++++++++++++++++---------------
v7/src/cref/redpkg.scm | 10 +++++----
4 files changed, 52 insertions(+), 26 deletions(-)
diff --git a/v7/src/cref/cref.pkg b/v7/src/cref/cref.pkg
index 148e16fd7..7b0813bc1 100644
--- a/v7/src/cref/cref.pkg
+++ b/v7/src/cref/cref.pkg
@@ -1,6 +1,6 @@
#| -*-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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/cref.pkg,v 1.2 1988/10/28 07:03:12 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
@@ -38,7 +38,6 @@ MIT in each case. |#
(define-package (cross-reference)
(files "mset"
- "btree"
"object"
"toplev")
(parent ())
@@ -48,6 +47,16 @@ MIT in each case. |#
cref/generate-cref
cref/generate-trivial-constructor))
+(define-package (cross-reference balanced-binary-tree)
+ (files "btree")
+ (parent ())
+ (export (cross-reference)
+ btree-delete!
+ btree-fringe
+ btree-insert!
+ btree-lookup
+ make-btree))
+
(define-package (cross-reference analyze-file)
(files "anfile")
(parent (cross-reference))
diff --git a/v7/src/cref/make.scm b/v7/src/cref/make.scm
index 4ddaa17a8..906236f2d 100644
--- a/v7/src/cref/make.scm
+++ b/v7/src/cref/make.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/make.scm,v 1.2 1988/06/14 10:32:05 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/make.scm,v 1.3 1988/10/28 07:03:16 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
@@ -37,4 +37,4 @@ MIT in each case. |#
(declare (usual-integrations))
(package/system-loader "cref" '() false)
-(add-system! (make-system "CREF" 1 2 '()))
\ No newline at end of file
+(add-system! (make-system "CREF" 1 3 '()))
\ No newline at end of file
diff --git a/v7/src/cref/object.scm b/v7/src/cref/object.scm
index 1d0de6068..19b5879b6 100644
--- a/v7/src/cref/object.scm
+++ b/v7/src/cref/object.scm
@@ -1,6 +1,6 @@
#| -*-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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/object.scm,v 1.2 1988/10/28 07:03:20 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
@@ -36,8 +36,11 @@ MIT in each case. |#
(declare (usual-integrations))
-(define-structure (package-description (constructor make-package-description)
- (conc-name package-description/))
+(define-structure (package-description
+ (named
+ (string->symbol "#[(cross-reference)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)
@@ -45,7 +48,9 @@ MIT in each case. |#
(exports false read-only true)
(imports false read-only true))
-(define-structure (pmodel (conc-name pmodel/))
+(define-structure (pmodel
+ (named (string->symbol "#[(cross-reference)pmodel]"))
+ (conc-name pmodel/))
(root-package false read-only true)
(primitive-package false read-only true)
(packages false read-only true)
@@ -53,6 +58,7 @@ MIT in each case. |#
(default-pathname false read-only true))
(define-structure (package
+ (named (string->symbol "#[(cross-reference)package]"))
(constructor %make-package
(name file-cases files initialization parent))
(conc-name package/))
@@ -62,8 +68,8 @@ MIT in each case. |#
(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))
+ (bindings (make-btree) read-only true)
+ (references (make-btree) read-only true))
(define (make-package name file-cases initialization parent)
(let ((files
@@ -84,7 +90,7 @@ MIT in each case. |#
(null? (package/name package)))
(define (package/find-binding package name)
- (btree-lookup (package/bindings package) name
+ (btree-lookup (package/bindings package) symbol<? binding/name name
identity-procedure
(lambda (name) name false)))
@@ -100,9 +106,10 @@ MIT in each case. |#
(define-integrable (file-case-clause/files clause)
(cdr clause))
-(define-structure (binding (constructor %make-binding
- (package name value-cell))
- (conc-name binding/))
+(define-structure (binding
+ (named (string->symbol "#[(cross-reference)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)
@@ -125,14 +132,18 @@ MIT in each case. |#
(define (binding/internal? binding)
(eq? binding (binding/source-binding binding)))
-(define-structure (value-cell (constructor make-value-cell ())
- (conc-name value-cell/))
+(define-structure (value-cell
+ (named (string->symbol "#[(cross-reference)value-cell]"))
+ (constructor make-value-cell ())
+ (conc-name value-cell/))
(bindings '())
(expressions '())
(source-binding false))
-(define-structure (link (constructor %make-link)
- (conc-name link/))
+(define-structure (link
+ (named (string->symbol "#[(cross-reference)link]"))
+ (constructor %make-link)
+ (conc-name link/))
(source false read-only true)
(destination false read-only true))
@@ -142,16 +153,20 @@ MIT in each case. |#
(cons link (binding/links source-binding)))
link))
-(define-structure (expression (constructor make-expression (package file type))
- (conc-name expression/))
+(define-structure (expression
+ (named (string->symbol "#[(cross-reference)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/))
+(define-structure (reference
+ (named (string->symbol "#[(cross-reference)reference]"))
+ (constructor %make-reference (package name))
+ (conc-name reference/))
(package false read-only true)
(name false read-only true)
(expressions '())
diff --git a/v7/src/cref/redpkg.scm b/v7/src/cref/redpkg.scm
index 4f01f13f7..79e62c576 100644
--- a/v7/src/cref/redpkg.scm
+++ b/v7/src/cref/redpkg.scm
@@ -1,6 +1,6 @@
#| -*-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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/redpkg.scm,v 1.2 1988/10/28 07:03:24 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
@@ -325,7 +325,7 @@ MIT in each case. |#
default-pathname))))
(define primitive-package-name
- (list (string->uninterned-symbol "primitives")))
+ (list (string->symbol "#[(cross-reference reader)primitives]")))
;;;; Binding and Reference
@@ -340,6 +340,8 @@ MIT in each case. |#
(let ((source-binding (intern-binding! source-package source-name)))
(make-link source-binding
(btree-insert! (package/bindings destination-package)
+ symbol<?
+ binding/name
destination-name
(lambda (destination-name)
(make-binding destination-package
@@ -351,7 +353,7 @@ MIT in each case. |#
identity-procedure))))
(define (intern-binding! package name)
- (btree-insert! (package/bindings package) name
+ (btree-insert! (package/bindings package) symbol<? binding/name name
(lambda (name)
(let ((value-cell (make-value-cell)))
(let ((binding (make-binding package name value-cell)))
@@ -369,7 +371,7 @@ MIT in each case. |#
(set-expression/references!
expression
(cons reference (expression/references expression))))))
- (btree-insert! (package/references package) name
+ (btree-insert! (package/references package) symbol<? reference/name name
(lambda (name)
(%make-reference package name))
(lambda (reference)
--
2.25.1