- fixed problem where interned symbols were being gc-ed incorrectly

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 ()
+      (cond
-        (let ([a (g)])
+        [(g) => 
-          (cond
+         (lambda (a)
-            [(not a) (intern str idx st)]
+           (let loop ([a a])
-            [(string=? str (symbol->string a))
-             (begin (g a) a)]
-            [else
              (cond
-               [(and ($unbound-object? ($symbol-value a))
+               [(eq? a sym) (g a)]
-                     (null? ($symbol-plist a)))
+               [(begin
-                (unintern a st)]
+                  (if (dead? a) (unintern a st) (g a))
-               [else (g a)])
+                  (g)) => loop])))]))
-             (f)])))))
+    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)

scheme/last-revision

@@ -1 +1 @@
-1718
+1719

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)))
+