From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Fri, 6 Jan 2012 23:18:40 +0000 (-0700)
Subject: Fixed CREF to handle uninterned symbols.
X-Git-Tag: release-9.2.0~334^2~32^2
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f0f3cbcadc16454ded8fe25568dbbcbfc020b91f;p=mit-scheme.git

Fixed CREF to handle uninterned symbols.

"Names" (aka "binding-names") are symbols OR uninterned symbols, and
NOT sortable.  Replaced the rb-trees with hash tables.  This banished
the bogus complaints about free references to e.g. .tag.1 in compiler,
edwin and imail.
---

diff --git a/src/cref/forpkg.scm b/src/cref/forpkg.scm
index 7c8d5786c..1ad91e206 100644
--- a/src/cref/forpkg.scm
+++ b/src/cref/forpkg.scm
@@ -207,12 +207,12 @@ USA.
 		    destination-binding)
        (let ((local-name (binding/name local-binding))
 	     (remote-name (binding/name remote-binding)))
-	 (let ((name-string (binding-name->string local-name)))
+	 (let ((name-string (name->string local-name)))
 	   (if (eq? local-name remote-name)
 	       name-string
 	       (string-append name-string
 			      " ["
-			      (binding-name->string remote-name)
+			      (name->string remote-name)
 			      "]"))))))))
 
 (define (local-map/export source destination)
@@ -255,12 +255,12 @@ USA.
   (for-each
    (lambda (reference)
      (format-expressions port indentation width package
-			 (binding-name->string (reference/name reference))
+			 (name->string (reference/name reference))
 			 (reference/expressions reference)))
    references))
 
 (define (format-expressions port indentation width package name expressions)
-  (receive (symbols pairs)
+  (receive (names pairs)
       (classify-expression-names
        (map (lambda (expression)
 	      (expression->name expression package))
@@ -270,7 +270,7 @@ USA.
     (newline port)
     (let ((indentation (new-indentation indentation)))
       (write-strings/compact port indentation width
-			     (map symbol-name (sort symbols symbol<?)))
+			     (sort (map name->string names) string<?))
       (write-items/miser port indentation width
 	(sort pairs
 	  (lambda (x y)
@@ -278,7 +278,7 @@ USA.
 		(and (string=? (car x) (car y))
 		     (or (not (pair? (cdr x)))
 			 (and (pair? (cdr y))
-			      (symbol<? (cadr x) (cadr y))))))))))))
+			      (name<? (cadr x) (cadr y))))))))))))
 
 (define (classify-expression-names names)
   (if (pair? names)
@@ -344,12 +344,7 @@ USA.
   (string-append indentation "    "))
 
 (define (binding/name-string binding)
-  (binding-name->string (binding/name binding)))
-
-(define (binding-name->string name)
-  (if (symbol? name)
-      (symbol-name name)
-      (write-to-string name)))
+  (name->string (binding/name binding)))
 
 (define (package/name-string package)
   (package-name->string (package/name package)))
@@ -357,5 +352,5 @@ USA.
 (define (package-name->string name)
   (string-append "("
 		 (decorated-string-append "" " " ""
-					  (map binding-name->string name))
+					  (map name->string name))
 		 ")"))
\ No newline at end of file
diff --git a/src/cref/make.scm b/src/cref/make.scm
index 6e8ecfad1..ba7d06520 100644
--- a/src/cref/make.scm
+++ b/src/cref/make.scm
@@ -28,7 +28,6 @@ USA.
 
 (declare (usual-integrations))
 
-(load-option 'RB-TREE)
 (with-loader-base-uri (system-library-uri "cref/")
   (lambda ()
     (load-package-set "cref")))
diff --git a/src/cref/object.scm b/src/cref/object.scm
index 3f6f272c6..6b240fcae 100644
--- a/src/cref/object.scm
+++ b/src/cref/object.scm
@@ -59,8 +59,8 @@ USA.
   (files '())
   parent
   (children '())
-  (bindings (make-rb-tree eq? symbol<?) read-only #t)
-  (references (make-rb-tree eq? symbol<?) read-only #t)
+  (bindings (make-strong-eq-hash-table) read-only #t)
+  (references (make-strong-eq-hash-table) read-only #t)
   (links '()))
 
 (define-integrable (package/n-files package)
@@ -69,14 +69,25 @@ USA.
 (define-integrable (package/root? package)
   (null? (package/name package)))
 
+(define-integrable (package/find-reference package name)
+  (hash-table/get (package/references package) name #f))
+
+(define-integrable (package/put-reference! package name reference)
+  (hash-table/put! (package/references package) name reference))
+
 (define-integrable (package/find-binding package name)
-  (rb-tree/lookup (package/bindings package) name #f))
+  (hash-table/get (package/bindings package) name #f))
+
+(define-integrable (package/put-binding! package name binding)
+  (hash-table/put! (package/bindings package) name binding))
 
 (define-integrable (package/sorted-bindings package)
-  (rb-tree/datum-list (package/bindings package)))
+  (sort (hash-table/datum-list (package/bindings package))
+	binding<?))
 
 (define-integrable (package/sorted-references package)
-  (rb-tree/datum-list (package/references package)))
+  (sort (hash-table/datum-list (package/references package))
+	reference<?))
 
 (define-integrable (file-case/type file-case)
   (car file-case))
@@ -195,8 +206,17 @@ USA.
 (define (package<? x y)
   (symbol-list<? (package/name x) (package/name y)))
 
-(define (binding<? x y)
-  (symbol<? (binding/name x) (binding/name y)))
+(declare (integrate-operator name->string))
+(define (name->string name)
+  (if (interned-symbol? name)
+      (symbol-name name)
+      (write-to-string name)))
+
+(define-integrable (name<? x y)
+  (string<? (name->string x) (name->string y)))
+
+(define-integrable (binding<? x y)
+  (name<? (binding/name x) (binding/name y)))
 
-(define (reference<? x y)
-  (symbol<? (reference/name x) (reference/name y)))
\ No newline at end of file
+(define-integrable (reference<? x y)
+  (name<? (reference/name x) (reference/name y)))
\ No newline at end of file
diff --git a/src/cref/redpkg.scm b/src/cref/redpkg.scm
index 4f67a11a1..de93c377c 100644
--- a/src/cref/redpkg.scm
+++ b/src/cref/redpkg.scm
@@ -640,9 +640,9 @@ USA.
 					  destination-name
 					  (binding/value-cell source-binding)
 					  new?)))
-		       (rb-tree/insert! (package/bindings destination-package)
-					destination-name
-					binding)
+		       (package/put-binding! destination-package
+					     destination-name
+					     binding)
 		       binding)))
 	       owner-package
 	       new?)))
@@ -658,12 +658,11 @@ USA.
 		 (let ((binding (make-binding package name value-cell new?)))
 		   (set-value-cell/source-binding! value-cell binding)
 		   binding))))
-	  (rb-tree/insert! (package/bindings package) name binding)
+	  (package/put-binding! package name binding)
 	  binding))))
 
 (define (make-reference package name expression)
-  (let ((references (package/references package))
-	(add-reference!
+  (let ((add-reference!
 	 (lambda (reference)
 	   (set-reference/expressions!
 	    reference
@@ -671,13 +670,13 @@ USA.
 	   (set-expression/references!
 	    expression
 	    (cons reference (expression/references expression))))))
-    (let ((reference (rb-tree/lookup references name #f)))
+    (let ((reference (package/find-reference package name)))
       (if reference
 	  (begin
 	    (if (not (memq expression (reference/expressions reference)))
 		(add-reference! reference))
 	    reference)
 	  (let ((reference (%make-reference package name)))
-	    (rb-tree/insert! references name reference)
+	    (package/put-reference! package name reference)
 	    (add-reference! reference)
 	    reference)))))
\ No newline at end of file