- implemented $unintern-gensym

scheme/ikarus.symbols.ss

@@ -20,6 +20,7 @@
           getprop putprop remprop property-list
           top-level-value top-level-bound? set-top-level-value!
           symbol-value symbol-bound? set-symbol-value!
+          $unintern-gensym
           reset-symbol-proc! system-value system-value-gensym)
   (import 
     (ikarus system $symbols)
@@ -27,7 +28,7 @@
     (ikarus system $fx)
     (except (ikarus) gensym gensym? gensym->unique-string
       gensym-prefix gensym-count print-gensym system-value
-      string->symbol symbol->string
+      $unintern-gensym string->symbol symbol->string
       getprop putprop remprop property-list
       top-level-value top-level-bound? set-top-level-value!
       symbol-value symbol-bound? set-symbol-value! reset-symbol-proc!))
@@ -44,10 +45,15 @@
 
   (define gensym?
     (lambda (x)
-      (and (symbol? x) 
+      (and (symbol? x)
            (let ([s ($symbol-unique-string x)])
              (and s #t)))))
 
+  (define ($unintern-gensym x)
+    (if (symbol? x)
+        (begin (foreign-call "ikrt_unintern_gensym" x) (void))
+        (die 'unintern-gensym "not a symbol" x)))
+
   (define top-level-value
     (lambda (x)
       (unless (symbol? x)

scheme/last-revision

@@ -1 +1 @@
-1669
+1670

scheme/makefile.ss

@@ -522,6 +522,7 @@
     [$set-symbol-string!                         $symbols]
     [$set-symbol-unique-string!                  $symbols]
     [$set-symbol-plist!                          $symbols]
+    [$unintern-gensym                            $symbols]
     [$init-symbol-value!                         ]
     [$unbound-object?                            $symbols]
     ;;;

src/ikarus-symbol-table.c

@@ -68,22 +68,6 @@ static int strings_eqp(ikptr str1, ikptr str2){
   return 0;
 }
 
-#if 0
-static ikptr 
-ik_make_symbol(ikptr str, ikptr ustr, ikpcb* pcb){
-  ikptr sym = ik_unsafe_alloc(pcb, symbol_size) + symbol_tag;
-  ref(sym, off_symbol_string)  = str;
-  ref(sym, off_symbol_ustring) = ustr;
-  ref(sym, off_symbol_value)   = unbound_object;
-  ref(sym, off_symbol_plist)   = null_object;
-  ref(sym, off_symbol_system_value) = str;
-  ref(sym, off_symbol_code) = 0;
-  ref(sym, off_symbol_errcode) = 0;
-  ref(sym, off_symbol_unused) = 0;
-  return sym;
-}
-#endif
-
 static ikptr 
 ik_make_symbol(ikptr str, ikptr ustr, ikpcb* pcb){
   ikptr sym = ik_unsafe_alloc(pcb, symbol_record_size) + record_tag;
@@ -96,8 +80,6 @@ ik_make_symbol(ikptr str, ikptr ustr, ikpcb* pcb){
   return sym;
 }
 
-
-
 static ikptr
 intern_string(ikptr str, ikptr st, ikpcb* pcb){
   int h = compute_hash(str);
@@ -173,6 +155,34 @@ ikrt_intern_gensym(ikptr sym, ikpcb* pcb){
 }
 
 
+ikptr
+ikrt_unintern_gensym(ikptr sym, ikpcb* pcb){
+  ikptr st = pcb->gensym_table;
+  if(st == 0){
+    /* no symbol table */
+    return false_object;
+  }
+  ikptr ustr = ref(sym, off_symbol_record_ustring);
+  if (tagof(ustr) != string_tag) {
+    return false_object;
+  }
+  int h = compute_hash(ustr);
+  int idx = h & (unfix(ref(st, off_vector_length)) - 1);
+  ikptr loc = (ikptr)(st+off_vector_data+idx*wordsize);
+  ikptr bckt = ref(loc, 0);
+  while(bckt){
+    if (ref(bckt, off_car) == sym) {
+      /* found it */
+      ref(loc, 0) = ref(bckt, off_cdr);
+      return true_object;
+    } else {
+      loc = (ikptr)(bckt + off_cdr);
+      bckt = ref(loc, 0);
+    }
+  }
+  return false_object;
+}
+
 
 
 ikptr 
@@ -201,15 +211,3 @@ ikrt_strings_to_gensym(ikptr str, ikptr ustr, ikpcb* pcb){
 }
 
 
-#if 0
-ikptr
-ik_cstring_to_symbol(char* str, ikpcb* pcb){
-  int n = strlen(str);
-  int size = n + disp_string_data + 1;
-  ikptr s = ik_unsafe_alloc(pcb, align(size)) + string_tag;
-  ref(s, off_string_length) = fix(n);
-  memcpy(s+off_string_data, str, n+1);
-  ikptr sym = ikrt_string_to_symbol(s, pcb);
-  return sym;
-}
-#endif