gensym->unique-string now interns gensyms in the gensym table.

bin/ikarus-collect.c

@@ -319,6 +319,7 @@ ik_collect(int mem_req, ikpcb* pcb){
   collect_stack(&gc, pcb->frame_pointer, pcb->frame_base - wordsize);
   pcb->next_k = add_object(&gc, pcb->next_k, "next_k"); 
   pcb->symbol_table = add_object(&gc, pcb->symbol_table, "symbol_table"); 
+  pcb->gensym_table = add_object(&gc, pcb->gensym_table, "gensym_table"); 
   pcb->arg_list = add_object(&gc, pcb->arg_list, "args_list_foo");
   /* now we trace all live objects */
   collect_loop(&gc);

bin/ikarus-fasl.c

@@ -257,7 +257,7 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
   else if(c == 'M'){
     /* symbol */
     ikp str = do_read(pcb, p);
-    ikp sym = ik_intern_string(str, pcb);
+    ikp sym = ikrt_string_to_symbol(str, pcb);
     if(put_mark_index){
       p->marks[put_mark_index] = sym;
     }

bin/ikarus-symbol-table.c

@@ -5,13 +5,12 @@
 #include <stdlib.h>
 
 static ikp
-initialize_symbol_table(ikpcb* pcb){
+make_symbol_table(ikpcb* pcb){
   #define NUM_OF_BUCKETS 4096 /* power of 2 */
   int size = align_to_next_page(disp_vector_data + NUM_OF_BUCKETS * wordsize);
   ikp st = ik_mmap_ptr(size, 0, pcb) + vector_tag;
   bzero(st-vector_tag, size);
   ref(st, off_vector_length) = fix(NUM_OF_BUCKETS);
-  pcb->symbol_table = st;
   return st;
 }
 
@@ -43,10 +42,11 @@ static int strings_eqp(ikp str1, ikp str2){
   return 0;
 }
 
-static ikp ik_make_symbol(ikp str, ikpcb* pcb){
+static ikp 
+ik_make_symbol(ikp str, ikp ustr, ikpcb* pcb){
   ikp sym = ik_alloc(pcb, symbol_size) + symbol_tag;
   ref(sym, off_symbol_string)  = str;
-  ref(sym, off_symbol_ustring) = false_object;
+  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;
@@ -55,11 +55,8 @@ static ikp ik_make_symbol(ikp str, ikpcb* pcb){
 }
 
 
-ikp ik_intern_string(ikp str, ikpcb* pcb){
-  ikp st = pcb->symbol_table;
-  if(st == 0){
-    st = initialize_symbol_table(pcb);
-  }
+static ikp
+intern_string(ikp str, ikp st, ikpcb* pcb){
   int h = compute_hash(str);
   int idx = h & (unfix(ref(st, off_vector_length)) - 1);
   ikp bckt = ref(st, off_vector_data + idx*wordsize);
@@ -72,7 +69,7 @@ ikp ik_intern_string(ikp str, ikpcb* pcb){
     }
     b = ref(b, off_cdr);
   }
-  ikp sym = ik_make_symbol(str, pcb);
+  ikp sym = ik_make_symbol(str, false_object,  pcb);
   b = ik_alloc(pcb, pair_size) + pair_tag;
   ref(b, off_car) = sym;
   ref(b, off_cdr) = bckt;
@@ -81,6 +78,87 @@ ikp ik_intern_string(ikp str, ikpcb* pcb){
   return sym;
 }
 
+ikp
+ikrt_intern_unique_string(ikp ustr, ikp st, ikpcb* pcb){
+  int h = compute_hash(ustr);
+  int idx = h & (unfix(ref(st, off_vector_length)) - 1);
+  ikp bckt = ref(st, off_vector_data + idx*wordsize);
+  ikp b = bckt;
+  while(b){
+    ikp sym = ref(b, off_car);
+    ikp sym_str = ref(sym, off_symbol_ustring);
+    if(strings_eqp(sym_str, ustr)){
+      return sym;
+    }
+    b = ref(b, off_cdr);
+  }
+  ikp sym = ik_make_symbol(false_object, ustr, pcb);
+  b = ik_alloc(pcb, pair_size) + pair_tag;
+  ref(b, off_car) = sym;
+  ref(b, off_cdr) = bckt;
+  ref(st, off_vector_data + idx*wordsize) = b;
+  pcb->dirty_vector[page_index(st+off_vector_data+idx*wordsize)] = -1;
+  return sym;
+}
+
+ikp
+ikrt_intern_gensym(ikp sym, ikpcb* pcb){
+  ikp st = pcb->gensym_table;
+  if(st == 0){
+    st = make_symbol_table(pcb);
+    pcb->gensym_table = st;
+  }
+  ikp ustr = ref(sym, off_symbol_ustring);
+  int h = compute_hash(ustr);
+  int idx = h & (unfix(ref(st, off_vector_length)) - 1);
+  ikp bckt = ref(st, off_vector_data + idx*wordsize);
+  ikp b = bckt;
+  while(b){
+    ikp sym = ref(b, off_car);
+    ikp sym_ustr = ref(sym, off_symbol_ustring);
+    if(strings_eqp(sym_ustr, ustr)){
+      return false_object;
+    }
+    b = ref(b, off_cdr);
+  }
+  b = ik_alloc(pcb, pair_size) + pair_tag;
+  ref(b, off_car) = sym;
+  ref(b, off_cdr) = bckt;
+  ref(st, off_vector_data + idx*wordsize) = b;
+  pcb->dirty_vector[page_index(st+off_vector_data+idx*wordsize)] = -1;
+  return true_object;
+}
+
+
+
+
+ikp 
+ikrt_string_to_symbol(ikp str, ikpcb* pcb){
+  ikp st = pcb->symbol_table;
+  if(st == 0){
+    st = make_symbol_table(pcb);
+    pcb->symbol_table = st;
+  }
+  return intern_string(str, st, pcb);
+}
+
+ikp 
+ik_intern_string(ikp str, ikpcb* pcb){
+  return ikrt_string_to_symbol(str, pcb);
+}
+
+ikp 
+ikrt_string_to_gensym(ikp str, ikpcb* pcb){
+  ikp st = pcb->gensym_table;
+  if(st == 0){
+    st = make_symbol_table(pcb);
+    pcb->gensym_table = st;
+  }
+  return intern_string(str, st, pcb);
+}
+
+
+
 ikp
 ik_cstring_to_symbol(char* str, ikpcb* pcb){
   int n = strlen(str);
@@ -88,6 +166,6 @@ ik_cstring_to_symbol(char* str, ikpcb* pcb){
   ikp s = ik_alloc(pcb, align(size)) + string_tag;
   ref(s, off_string_length) = fix(n);
   memcpy(s+off_string_data, str, n+1);
-  ikp sym = ik_intern_string(s, pcb);
+  ikp sym = ikrt_string_to_symbol(s, pcb);
   return sym;
 }

bin/ikarus.h

@@ -124,7 +124,8 @@ typedef struct ikpcb{
   ikpage* uncached_pages; /* ikpages cached so that we don't malloc/free */
   ikp   stack_base;
   int   stack_size;
-  ikp   symbol_table;;
+  ikp   symbol_table;
+  ikp   gensym_table;
   ik_guardian_table* guardians[generation_count];
   unsigned int* dirty_vector_base;
   unsigned int* segment_vector_base;
@@ -160,7 +161,7 @@ ikp ik_exec_code(ikpcb* pcb, ikp code_ptr);
 void ik_print(ikp x);
 void ik_fprint(FILE*, ikp x);
 
-ikp ik_intern_string(ikp, ikpcb*);
+ikp ikrt_string_to_symbol(ikp, ikpcb*);
 
 ikp ik_cstring_to_symbol(char*, ikpcb*);
 

src/libcore.ss

@@ -1074,7 +1074,7 @@ reference-implementation:
   (lambda (x)
     (unless (string? x) 
       (error 'string->symbol "~s is not a string" x))
-    (foreign-call "ik_intern_string" x)))
+    (foreign-call "ikrt_string_to_symbol" x)))
   
 (primitive-set! 'gensym
   (case-lambda
@@ -1139,39 +1139,6 @@ reference-implementation:
       (f ($symbol-plist x) '()))))
 
 
-;;X (primitive-set! 'make-parameter
-;;X   (letrec ([make-param-no-guard
-;;X             (lambda (x)
-;;X               (lambda args
-;;X                 (if (null? args)
-;;X                     x
-;;X                     (if (null? ($cdr args))
-;;X                         (set! x ($car args))
-;;X                         (error #f "too many arguments to parameter")))))]
-;;X            [make-param-with-guard
-;;X             (lambda (x g)
-;;X               (let ([f
-;;X                      (lambda args
-;;X                        (if (null? args)
-;;X                            x
-;;X                            (if (null? ($cdr args))
-;;X                                (set! x (g ($car args)))
-;;X                                (error #f "too many arguments to parameter"))))])
-;;X                (if (procedure? g)
-;;X                    (begin (set! x (g x)) f)
-;;X                    (error 'make-parameter "not a procedure ~s" g))))])
-;;X     (lambda args
-;;X        (if (pair? args)
-;;X            (let ([x ($car args)] [args ($cdr args)])
-;;X              (if (null? args)
-;;X                  (make-param-no-guard x)
-;;X                  (let ([g ($car args)])
-;;X                    (if (null? ($cdr args))
-;;X                        (make-param-with-guard x g)
-;;X                        (error 'make-parameter "too many arguments")))))
-;;X            (error 'make-parameter "insufficient arguments")))))
-;;X 
-
 
 (let ()
    (define vector-loop
@@ -1619,9 +1586,12 @@ reference-implementation:
         [(eq? us #t) 
          (error 'gensym->unique-string "~s is not a gensym" x)]
         [else
-         (let ([id (uuid)])
-           ($set-symbol-unique-string! x id)
-           id)]))))
+         (let f ([x x])
+           (let ([id (uuid)])
+             ($set-symbol-unique-string! x id)
+             (cond
+               [(foreign-call "ikrt_intern_gensym" x) id]
+               [else (f x)])))]))))
 
 (primitive-set! 'gensym-prefix
   (make-parameter