* incremental step towards loading a fresh compiler for

bootstrapping.

bin/ikarus-collect.c

@@ -149,11 +149,22 @@ gc_alloc_new_ptr(int size, int old_gen, gc_t* gc){
   return meta_alloc(size, old_gen, gc, meta_ptrs);
 }
 
+#if 0
 static inline ikp 
 gc_alloc_new_symbol(int old_gen, gc_t* gc){
   assert(symbol_size == align(symbol_size));
   return meta_alloc(symbol_size, old_gen, gc, meta_symbol);
 }
+#endif
+
+static inline ikp 
+gc_alloc_new_symbol_record(int old_gen, gc_t* gc){
+  assert(symbol_record_size == align(symbol_record_size));
+  return meta_alloc(symbol_record_size, old_gen, gc, meta_symbol);
+}
+
+
+
 
 static inline ikp 
 gc_alloc_new_pair(int old_gen, gc_t* gc){
@@ -928,6 +939,7 @@ add_object_proc(gc_t* gc, ikp x)
     add_list(gc, t, gen, x, &y);
     return y;
   }
+#if 0
   else if(tag == symbol_tag){
     //ikp y = gc_alloc_new_ptr(align(symbol_size),gen, gc) + symbol_tag;
     ikp y = gc_alloc_new_symbol(gen, gc) + symbol_tag;
@@ -946,6 +958,7 @@ add_object_proc(gc_t* gc, ikp x)
 #endif
     return y;
   }
+#endif
   else if(tag == closure_tag){
     int size = disp_closure_data+
               (int) ref(fst, disp_code_freevars - disp_code_data);
@@ -982,6 +995,18 @@ add_object_proc(gc_t* gc, ikp x)
 #endif
       return y;
     } 
+    else if(fst == symbol_record_tag){
+      ikp y = gc_alloc_new_symbol_record(gen, gc) + record_tag;
+      ref(y, -record_tag)               = symbol_record_tag;
+      ref(y, off_symbol_record_string)  = ref(x, off_symbol_record_string);
+      ref(y, off_symbol_record_ustring) = ref(x, off_symbol_record_ustring);
+      ref(y, off_symbol_record_value)   = ref(x, off_symbol_record_value);
+      ref(y, off_symbol_record_proc)    = ref(x, off_symbol_record_proc);
+      ref(y, off_symbol_record_plist)   = ref(x, off_symbol_record_plist);
+      ref(x, -record_tag) = forward_ptr; 
+      ref(x, wordsize-record_tag) = y;
+      return y;
+    }
     else if(tagof(fst) == rtd_tag){
       /* record */
       int size = (int) ref(fst, off_rtd_length);

bin/ikarus-data.h

@@ -107,6 +107,7 @@
 #define off_vector_length (disp_vector_length - vector_tag)
 
 
+#if 0
 #define symbol_tag    2
 #define disp_symbol_string        0
 #define disp_symbol_ustring       4
@@ -125,6 +126,21 @@
 #define off_symbol_code (disp_symbol_code - symbol_tag)
 #define off_symbol_errcode (disp_symbol_errcode - symbol_tag)
 #define off_symbol_unused (disp_symbol_unused - symbol_tag)
+#endif
+
+#define symbol_record_tag ((ikp) 0x5F)
+#define disp_symbol_record_string   4
+#define disp_symbol_record_ustring  8
+#define disp_symbol_record_value   12
+#define disp_symbol_record_proc    16
+#define disp_symbol_record_plist   20
+#define symbol_record_size         24
+#define off_symbol_record_string  (disp_symbol_record_string  - record_tag) 
+#define off_symbol_record_ustring (disp_symbol_record_ustring - record_tag) 
+#define off_symbol_record_value   (disp_symbol_record_value   - record_tag) 
+#define off_symbol_record_proc    (disp_symbol_record_proc    - record_tag) 
+#define off_symbol_record_plist   (disp_symbol_record_plist   - record_tag) 
+
 
 #define closure_tag  3
 #define closure_mask 7

bin/ikarus-fasl.c

@@ -340,7 +340,7 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
       ptr -= pair_size;
       ref(ptr, off_cdr) = null_object;
     }
-    ikp gensym_val = ref(symb, off_symbol_value);
+    ikp gensym_val = ref(symb, off_symbol_record_value);
     ikp rtd;
     if(gensym_val == unbound_object){
       rtd = ik_alloc(pcb, align(rtd_size)) + vector_tag;
@@ -351,8 +351,8 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
       ref(rtd, off_rtd_fields) = fields;
       ref(rtd, off_rtd_printer) = false_object;
       ref(rtd, off_rtd_symbol) = symb;
-      ref(symb, off_symbol_value) = rtd;
+      ref(symb, off_symbol_record_value) = rtd;
-      pcb->dirty_vector[page_index(symb+off_symbol_value)] = -1;
+      pcb->dirty_vector[page_index(symb+off_symbol_record_value)] = -1;
     } else {
       rtd = gensym_val;
     }

bin/ikarus-print.c

@@ -54,10 +54,12 @@ print(FILE* fh, ikp x){
   else if(IK_CHARP(x)){
     fprintf(fh, "%s", char_string[IK_CHAR_VAL(x)]);
   }
+#if 0
   else if(tagof(x) == symbol_tag){
     ikp str = ref(x, off_symbol_string);
     fprintf(fh, "%s", str+off_string_data);
   }
+#endif
   else if(tagof(x) == vector_tag){
     ikp len = ref(x, off_vector_length);
     if(len == 0){

bin/ikarus-symbol-table.c

@@ -42,6 +42,7 @@ static int strings_eqp(ikp str1, ikp str2){
   return 0;
 }
 
+#if 0
 static ikp 
 ik_make_symbol(ikp str, ikp ustr, ikpcb* pcb){
   ikp sym = ik_alloc(pcb, symbol_size) + symbol_tag;
@@ -55,6 +56,19 @@ ik_make_symbol(ikp str, ikp ustr, ikpcb* pcb){
   ref(sym, off_symbol_unused) = 0;
   return sym;
 }
+#endif
+
+static ikp 
+ik_make_symbol(ikp str, ikp ustr, ikpcb* pcb){
+  ikp sym = ik_alloc(pcb, symbol_record_size) + record_tag;
+  ref(sym, off_symbol_record_string)  = str;
+  ref(sym, off_symbol_record_ustring) = ustr;
+  ref(sym, off_symbol_record_value)   = unbound_object;
+  ref(sym, off_symbol_record_proc)    = str;
+  ref(sym, off_symbol_record_plist)   = null_object;
+  return sym;
+}
+
 
 
 static ikp
@@ -65,7 +79,7 @@ intern_string(ikp str, ikp st, ikpcb* pcb){
   ikp b = bckt;
   while(b){
     ikp sym = ref(b, off_car);
-    ikp sym_str = ref(sym, off_symbol_string);
+    ikp sym_str = ref(sym, off_symbol_record_string);
     if(strings_eqp(sym_str, str)){
       return sym;
     }
@@ -88,7 +102,7 @@ intern_unique_string(ikp str, ikp ustr, ikp st, ikpcb* pcb){
   ikp b = bckt;
   while(b){
     ikp sym = ref(b, off_car);
-    ikp sym_ustr = ref(sym, off_symbol_ustring);
+    ikp sym_ustr = ref(sym, off_symbol_record_ustring);
     if(strings_eqp(sym_ustr, ustr)){
       return sym;
     }
@@ -110,14 +124,14 @@ ikrt_intern_gensym(ikp sym, ikpcb* pcb){
     st = make_symbol_table(pcb);
     pcb->gensym_table = st;
   }
-  ikp ustr = ref(sym, off_symbol_ustring);
+  ikp ustr = ref(sym, off_symbol_record_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);
+    ikp sym_ustr = ref(sym, off_symbol_record_ustring);
     if(strings_eqp(sym_ustr, ustr)){
       return false_object;
     }

src/ikarus.code-objects.ss

@@ -1,5 +1,5 @@
 
-(library (ikarus code-objects)
+(library (ikarus.code-objects)
   (export
     make-code code-reloc-vector code-freevars
     code-size code-ref code-set! set-code-reloc-vector!

src/ikarus.compiler.ss

@@ -1,5 +1,5 @@
 
-(library (ikarus compiler)
+(library (ikarus.compiler)
   (export compile-core-expr-to-port assembler-output
           current-primitive-locations eval-core)
   (import 
@@ -8,8 +8,8 @@
     (except (ikarus)
         compile-core-expr-to-port assembler-output
         current-primitive-locations eval-core)
-    (ikarus intel-assembler)
+    (ikarus.intel-assembler)
-    (ikarus fasl write))
+    (ikarus.fasl.write))
 
 
 
@@ -2943,6 +2943,9 @@
   (define disp-symbol-error-function 24)
   (define disp-symbol-unused         28)
   (define symbol-size                32)
+
+  
+
   (define vector-tag 5)
   (define vector-mask 7)
   (define disp-vector-length 0)

src/ikarus.fasl.ss

@@ -30,217 +30,13 @@
 
 
 
-(library (ikarus fasl write)
-  (export fasl-write)
-  (import
-    (ikarus system $codes)
-    (ikarus system $records)
-    (ikarus code-objects)
-    (except (ikarus) fasl-write))
-
-  (define write-fixnum 
-    (lambda (x p)
-      (unless (fixnum? x) (error 'write-fixnum "not a fixnum ~s" x))
-      (write-char (integer->char (fxsll (fxlogand x #x3F) 2)) p)
-      (write-char (integer->char (fxlogand (fxsra x 6) #xFF)) p)
-      (write-char (integer->char (fxlogand (fxsra x 14) #xFF)) p)
-      (write-char (integer->char (fxlogand (fxsra x 22) #xFF)) p)))
-  (define write-int 
-    (lambda (x p)
-      (unless (fixnum? x) (error 'write-int "not a fixnum ~s" x))
-      (write-char (integer->char (fxlogand x #xFF)) p)
-      (write-char (integer->char (fxlogand (fxsra x 8) #xFF)) p)
-      (write-char (integer->char (fxlogand (fxsra x 16) #xFF)) p)
-      (write-char (integer->char (fxlogand (fxsra x 24) #xFF)) p)))
-  
-  (define fasl-write-immediate
-    (lambda (x p)
-      (cond
-        [(null? x) (write-char #\N p)]
-        [(fixnum? x) 
-         (write-char #\I p)
-         (write-fixnum x p)]
-        [(char? x)
-         (write-char #\C p)
-         (write-char x p)]
-        [(boolean? x)
-         (write-char (if x #\T #\F) p)]
-        [(eof-object? x) (write-char #\E p)]
-        [(eq? x (void)) (write-char #\U p)]
-        [else (error 'fasl-write "~s is not a fasl-writable immediate" x)])))
-  
-  (define do-write
-    (lambda (x p h m)
-      (cond
-        [(pair? x)   
-         (write-char #\P p)
-         (fasl-write-object (cdr x) p h
-           (fasl-write-object (car x) p h m))]
-        [(vector? x)
-         (write-char #\V p)
-         (write-int (vector-length x) p)
-         (let f ([x x] [i 0] [n (vector-length x)] [m m])
-           (cond
-             [(fx= i n) m]
-             [else
-              (f x (fxadd1 i) n
-                 (fasl-write-object (vector-ref x i) p h m))]))]
-        [(string? x) 
-         (write-char #\S p)
-         (write-int (string-length x) p)
-         (let f ([x x] [i 0] [n (string-length x)])
-           (cond
-             [(fx= i n) m]
-             [else
-              (write-char (string-ref x i) p)
-              (f x (fxadd1 i) n)]))]
-        [(gensym? x)
-         (write-char #\G p)
-         (fasl-write-object (gensym->unique-string x) p h
-           (fasl-write-object (symbol->string x) p h m))]
-        [(symbol? x) 
-         (write-char #\M p)
-         (fasl-write-object (symbol->string x) p h m)]
-        [(code? x)
-         (write-char #\x p)
-         (write-int (code-size x) p)
-         (write-fixnum (code-freevars x) p)
-         (let f ([i 0] [n (code-size x)])
-           (unless (fx= i n)
-             (write-char (integer->char (code-ref x i)) p)
-             (f (fxadd1 i) n)))
-         (fasl-write-object (code-reloc-vector x) p h m)]
-        [(record? x)
-         (let ([rtd (record-type-descriptor x)])
-           (cond
-             [(eq? rtd (base-rtd))
-              ;;; rtd record
-              (write-char #\R p)
-              (let ([names (record-type-field-names x)]
-                    [m 
-                     (fasl-write-object (record-type-symbol x) p h
-                       (fasl-write-object (record-type-name x) p h m))])
-                (write-int (length names) p)
-                (let f ([names names] [m m])
-                  (cond
-                    [(null? names) m]
-                    [else
-                     (f (cdr names)
-                        (fasl-write-object (car names) p h m))])))]
-             [else
-              ;;; non-rtd record
-              (write-char #\{ p)
-              (write-int (length (record-type-field-names rtd)) p)
-              (let f ([names (record-type-field-names rtd)] 
-                      [m (fasl-write-object rtd p h m)])
-                (cond
-                  [(null? names) m]
-                  [else
-                   (f (cdr names) 
-                      (fasl-write-object 
-                         ((record-field-accessor rtd (car names)) x)
-                         p h m))]))]))]
-        [(procedure? x)
-         (write-char #\Q p)
-         (fasl-write-object ($closure-code x) p h m)]
-        [else (error 'fasl-write "~s is not fasl-writable" x)])))
-  (define fasl-write-object 
-    (lambda (x p h m)
-      (cond
-        [(immediate? x) (fasl-write-immediate x p) m]
-        [(get-hash-table h x #f) =>
-         (lambda (mark)
-           (unless (fixnum? mark)
-             (error 'fasl-write "BUG: invalid mark ~s" mark))
-           (cond
-             [(fx= mark 0) ; singly referenced
-              (do-write x p h m)]
-             [(fx> mark 0) ; marked but not written
-              (put-hash-table! h x (fx- 0 m))
-              (write-char #\> p)
-              (write-int m p)
-              (do-write x p h (fxadd1 m))]
-             [else
-              (write-char #\< p)
-              (write-int (fx- 0 mark) p)
-              m]))]
-        [else (error 'fasl-write "BUG: not in hash table ~s" x)]))) 
-  (define make-graph
-    (lambda (x h)
-      (unless (immediate? x)
-        (cond
-          [(get-hash-table h x #f) =>
-           (lambda (i) 
-             (put-hash-table! h x (fxadd1 i)))]
-          [else
-           (put-hash-table! h x 0)
-           (cond
-             [(pair? x) 
-              (make-graph (car x) h)
-              (make-graph (cdr x) h)]
-             [(vector? x)
-              (let f ([x x] [i 0] [n (vector-length x)])
-                (unless (fx= i n) 
-                  (make-graph (vector-ref x i) h)
-                  (f x (fxadd1 i) n)))]
-             [(symbol? x) 
-              (make-graph (symbol->string x) h)
-              (when (gensym? x) (make-graph (gensym->unique-string x) h))]
-             [(string? x) (void)]
-             [(code? x) 
-              (make-graph (code-reloc-vector x) h)]
-             [(record? x)
-              (when (eq? x (base-rtd))
-                (error 'fasl-write "base-rtd is not writable"))
-              (let ([rtd (record-type-descriptor x)])
-                (cond
-                  [(eq? rtd (base-rtd))
-                   ;;; this is an rtd
-                   (make-graph (record-type-name x) h)
-                   (make-graph (record-type-symbol x) h)
-                   (for-each (lambda (x) (make-graph x h))
-                     (record-type-field-names x))]
-                  [else
-                   ;;; this is a record
-                   (make-graph rtd h)
-                   (for-each 
-                     (lambda (name) 
-                       (make-graph ((record-field-accessor rtd name) x) h))
-                     (record-type-field-names rtd))]))]
-             [(procedure? x)
-              (let ([code ($closure-code x)])
-                (unless (fxzero? (code-freevars code))
-                  (error 'fasl-write
-                         "Cannot write a non-thunk procedure; the one given has ~s free vars"
-                         (code-freevars code)))
-                (make-graph code h))]
-             [else (error 'fasl-write "~s is not fasl-writable" x)])]))))
-  (define fasl-write-to-port
-    (lambda (x port)
-      (let ([h (make-hash-table)])
-         (make-graph x h)
-         (write-char #\# port)
-         (write-char #\@ port)
-         (write-char #\I port)
-         (write-char #\K port)
-         (write-char #\0 port)
-         (write-char #\1 port)
-         (fasl-write-object x port h 1)
-         (void))))
-  (define fasl-write
-     (case-lambda 
-       [(x) (fasl-write-to-port x (current-output-port))]
-       [(x port)
-        (unless (output-port? port)
-          (error 'fasl-write "~s is not an output port" port))
-        (fasl-write-to-port x port)])))
 
 
 
 (library (ikarus fasl read)
   (export fasl-read)
   (import (ikarus)
-          (ikarus code-objects)
+          (ikarus.code-objects)
           (ikarus system $codes)
           (ikarus system $records))
 

src/ikarus.intel-assembler.ss

@@ -1,10 +1,10 @@
 
 
-(library (ikarus intel-assembler)
+(library (ikarus.intel-assembler)
   (export assemble-sources)
   (import 
     (ikarus)
-    (ikarus code-objects)
+    (ikarus.code-objects)
     (ikarus system $pairs))
 
 (define fold

src/ikarus.syntax.ss

@@ -14,7 +14,7 @@
   (import
     (r6rs)
     (except (ikarus library-manager) installed-libraries)
-    (only (ikarus compiler) eval-core)
+    (only (ikarus system $bootstrap) eval-core)
     (chez modules)
     (ikarus symbols)
     (ikarus parameters)

src/makefile.ss

@@ -1,6 +1,13 @@
 #!/usr/bin/env ikarus -b ikarus.boot --r6rs-script
 
-(import (ikarus system $bootstrap) (ikarus))
+;(import 
+;  ;(only (ikarus system $bootstrap) boot-library-expand)
+;  (ikarus.compiler)
+;  (ikarus.syntax)
+;  (except (ikarus) 
+;           assembler-output))
+
+(import (ikarus) (ikarus system $bootstrap))
 
 (define scheme-library-files
   ;;; Listed in the order in which they're loaded.
@@ -51,6 +58,7 @@
     "ikarus.code-objects.ss"
     "ikarus.intel-assembler.ss"
     "ikarus.trace.ss"
+    "ikarus.fasl.write.ss"
     "ikarus.fasl.ss"
     "ikarus.compiler.ss"
     "ikarus.library-manager.ss"
@@ -422,6 +430,7 @@
     [compile-core-expr-to-port   $boot]
     [current-primitive-locations $boot]
     [boot-library-expand         $boot]
+    [eval-core                   $boot]
 
     [$car               $pairs]
     [$cdr               $pairs]
@@ -673,7 +682,7 @@
                   (import 
                     (only (ikarus library-manager)
                           install-library)
-                    (only (ikarus compiler)
+                    (only (ikarus.compiler)
                           current-primitive-locations)
                     (ikarus))
                   (current-primitive-locations