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 7c8d5786ceecf3f43369dac380ee8eaaad970128..1ad91e206ddedafb03e2f7cb59d6cd3fd60d9560 100644 (file)
--- 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 6e8ecfad1af100a0b07f1f3562f73c092d052467..ba7d065202180e9d4de6b5a5d8eb8264fc3f5f31 100644 (file)
--- 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 3f6f272c6732f788d6cc2e38490587151e9c8c53..6b240fcae661a018883baf8221b61f89d4b1e52f 100644 (file)
--- 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 4f67a11a1c0afb2f2365871d046785c98a70a21b..de93c377ca5bef28a71da073d533ff484aa46976 100644 (file)
--- 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