diff --git a/bin/ikarus b/bin/ikarus index 269d988..a8c78c8 100755 Binary files a/bin/ikarus and b/bin/ikarus differ diff --git a/bin/ikarus-fasl.c b/bin/ikarus-fasl.c index ece3513..cfc47f1 100644 --- a/bin/ikarus-fasl.c +++ b/bin/ikarus-fasl.c @@ -19,7 +19,7 @@ #define RTLD_DEFAULT 0 #endif -#define USE_ZLIB 1 +#define USE_ZLIB 0 typedef struct { #if USE_ZLIB @@ -473,6 +473,49 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){ } return x; } + else if(c == 'l'){ + int len = (unsigned char) fasl_read_byte(p); + if(len < 0){ + fprintf(stderr, "invalid len=%d\n", len); + exit(-1); + } + ikp pair = ik_alloc(pcb, pair_size * (len+1)) + pair_tag; + if(put_mark_index){ + p->marks[put_mark_index] = pair; + } + int i; ikp pt = pair; + for(i=0; imarks[put_mark_index] = pair; + } + int i; ikp pt = pair; + for(i=0; ichar 127)) (f s ($fxadd1 i) n))))) + (define (count-unshared-cdrs x h n) + (cond + [(and (pair? x) (eq? (get-hash-table h x #f) 0)) + (count-unshared-cdrs ($cdr x) h ($fxadd1 n))] + [else n])) + + (define (write-pairs x p h m n) + (cond + [($fx= n 0) (fasl-write-object x p h m)] + [else + (write-pairs (cdr x) p h + (fasl-write-object (car x) p h m) + ($fxsub1 n))])) + (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))] + [(pair? x) + (let ([d ($cdr x)]) + (let ([n (count-unshared-cdrs d h 0)]) + (cond + [($fx= n 0) + (write-char #\P p) + (fasl-write-object d p h + (fasl-write-object (car x) p h m))] + [else + (cond + [($fx<= n 255) + (write-char #\l p) + (write-byte n p)] + [else + (write-char #\L p) + (write-int n p)]) + (write-pairs d p h + (fasl-write-object (car x) p h m) + n)])))] [(vector? x) (write-char #\V p) (write-int (vector-length x) p) diff --git a/src/makefile.ss b/src/makefile.ss index 38151d9..7a37e76 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -843,14 +843,14 @@ [(assq x locs) => cdr] [else (error 'bootstrap "no location for ~s" x)]))) - (let ([p (open-output-file "ikarus.tmp" 'replace)]) + (let ([p (open-output-file "ikarus.boot" 'replace)]) (for-each (lambda (x) (compile-core-expr-to-port x p)) core*) (close-output-port p))))) -(system "gzip -f ikarus.tmp") -(system "mv ikarus.tmp.gz ikarus.boot") +;(system "gzip -f ikarus.boot.uncompressed") +;(system "mv ikarus.boot.uncompressed.gz ikarus.boot") (printf "Happy Happy Joy Joy\n")