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