From c2047badb91b0f8997fcc251596c0b957956b7ec Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Wed, 17 Dec 2008 14:59:03 -0500
Subject: [PATCH] - fixed problem where interned symbols were being gc-ed
 incorrectly

---
 scheme/ikarus.symbol-table.ss | 35 +++++++++++++++++++----------------
 scheme/last-revision          |  2 +-
 scheme/tests/symbol-table.ss  | 27 +++++++++++++++++++++++++--
 3 files changed, 45 insertions(+), 19 deletions(-)

diff --git a/scheme/ikarus.symbol-table.ss b/scheme/ikarus.symbol-table.ss
index 2c46cdb..eda72d7 100644
--- a/scheme/ikarus.symbol-table.ss
+++ b/scheme/ikarus.symbol-table.ss
@@ -60,29 +60,32 @@
                [(eq? (car ls) x)
                 (set-cdr! prev (cdr ls))]
                [else (f ls (cdr ls))]))]))))
-  
-  (define (guardian-lookup str idx st)
+
+   (define (dead? sym)
+    (and ($unbound-object? ($symbol-value sym))
+         (null? ($symbol-plist sym))))
+
+  (define (bleed-guardian sym st)
     (let ([g (symbol-table-guardian st)])
-      (let f ()
-        (let ([a (g)])
-          (cond
-            [(not a) (intern str idx st)]
-            [(string=? str (symbol->string a))
-             (begin (g a) a)]
-            [else
+      (cond
+        [(g) => 
+         (lambda (a)
+           (let loop ([a a])
              (cond
-               [(and ($unbound-object? ($symbol-value a))
-                     (null? ($symbol-plist a)))
-                (unintern a st)]
-               [else (g a)])
-             (f)])))))
+               [(eq? a sym) (g a)]
+               [(begin
+                  (if (dead? a) (unintern a st) (g a))
+                  (g)) => loop])))]))
+    sym)
   
   (define (chain-lookup str idx st ls)
     (if (null? ls)
-        (guardian-lookup str idx st)
+        (let ([sym (intern str idx st)])
+          ;;; doesn't need eq? check there
+          (bleed-guardian sym st))
         (let ([a (car ls)])
           (if (string=? str (symbol->string a))
-              a
+              (bleed-guardian a st)
               (chain-lookup str idx st (cdr ls))))))
   
   (define (lookup str ih st)
diff --git a/scheme/last-revision b/scheme/last-revision
index d75c403..f345fc6 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1718
+1719
diff --git a/scheme/tests/symbol-table.ss b/scheme/tests/symbol-table.ss
index 2562421..03e0253 100644
--- a/scheme/tests/symbol-table.ss
+++ b/scheme/tests/symbol-table.ss
@@ -14,6 +14,29 @@
       (let ([st2 ($symbol-table-size)])
         (assert (< (- st2 st1) n)))))
 
-  (define (run-tests)
-    (test-gcable-symbols 1000000)))
+
+  (define (test-reference-after-gc)
+    (define random-string
+      (lambda (n)
+        (list->string
+         (map (lambda (n)
+                (integer->char (+ (char->integer #\a) (random 26))))
+              (make-list n)))))
+    (newline)
+    (let ([str1 (random-string 70)]
+          [str2 (random-string 70)])
+      (printf "sym1=~s\n" (string->symbol str1))
+      (do ((i 0 (+ i 1))) ((= i 1024)) (collect))
+      (let ([sym1 (string->symbol str1)])
+        (printf "sym1=~s\n" (string->symbol str1))
+        (printf "sym2=~s\n" (string->symbol str2))
+        (let ([sym3 (string->symbol str1)])
+          (printf "sym3=~s\n" (string->symbol str1))
+          (assert (eq? sym1 sym3))))))
+
+
+  (define (run-tests)
+    (test-gcable-symbols 1000000)
+    (test-reference-after-gc)))
+