conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* reader can now read fasl objects.

This commit is contained in:
Abdulaziz Ghuloum 2006-12-26 11:39:14 +03:00
parent 903023592d f5f91712dd
commit 81b2f217a3
5 changed files with 245 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

215
src/libfasl.ss
View File

@ -217,7 +217,8 @@
(write-char #\K port)
(write-char #\0 port)
(write-char #\1 port)
(fasl-write x port h 1))))
(fasl-write x port h 1)
(void))))
(primitive-set! 'fasl-write
(case-lambda
[(x) (do-fasl-write x (current-output-port))]
@ -226,3 +227,215 @@
(error 'fasl-write "~s is not an output port" port))
(do-fasl-write x port)])))
(let ()
(define who 'fasl-read)
(define (assert-eq? x y)
(unless (eq? x y)
(error who "Expected ~s, got ~s\n" y x)))
(define (char->int x)
(if (char? x)
(char->integer x)
(error who "unexpected eof inside a fasl object")))
(define (read-fixnum p)
(let ([c0 (char->int (read-char p))]
[c1 (char->int (read-char p))]
[c2 (char->int (read-char p))]
[c3 (char->int (read-char p))])
(cond
[(fx<= c3 127)
(fxlogor (fxlogor (fxsra c0 2) (fxsll c1 6))
(fxlogor (fxsll c2 14) (fxsll c3 22)))]
[else
(let ([c0 (fxlogand #xFF (fxlognot c0))]
[c1 (fxlogand #xFF (fxlognot c1))]
[c2 (fxlogand #xFF (fxlognot c2))]
[c3 (fxlogand #xFF (fxlognot c3))])
(fx- -1
(fxlogor (fxlogor (fxsra c0 2)
(fxsll c1 6))
(fxlogor (fxsll c2 14)
(fxsll c3 22)))))])))
(define (read-int p)
(let ([c0 (char->int (read-char p))]
[c1 (char->int (read-char p))]
[c2 (char->int (read-char p))]
[c3 (char->int (read-char p))])
(cond
[(fx<= c3 127)
(fxlogor (fxlogor c0 (fxsll c1 8))
(fxlogor (fxsll c2 16) (fxsll c3 24)))]
[else
(let ([c0 (fxlogand #xFF (fxlognot c0))]
[c1 (fxlogand #xFF (fxlognot c1))]
[c2 (fxlogand #xFF (fxlognot c2))]
[c3 (fxlogand #xFF (fxlognot c3))])
(fx- -1
(fxlogor (fxlogor c0
(fxsll c1 8))
(fxlogor (fxsll c2 16)
(fxsll c3 24)))))])))
(define (do-read p)
(define marks (make-vector 1 #f))
(define (max x y)
(if (fx> x y) x y))
(define (put-mark m obj)
(cond
[(fx< m (vector-length marks))
(when (vector-ref marks m)
(error 'fasl-read "mark ~s set twice" m))
(vector-set! marks m obj)]
[else
(let ([n (vector-length marks)])
(let ([v (make-vector
(max (fx* n 2) (fx+ m 1))
#f)])
(let f ([i 0])
(cond
[(fx= i n)
(set! marks v)
(vector-set! marks m obj)]
[else
(vector-set! v i (vector-ref marks i))
(f (fxadd1 i))]))))]))
(define (read) (read/mark #f))
(define (read-code code-m clos-m)
(let* ([code-size (read-int p)]
[freevars (read-fixnum p)])
(let ([code (make-code code-size freevars)])
(when code-m (put-mark code-m code))
(let f ([i 0])
(unless (fx= i code-size)
(code-set! code i (char->int (read-char p)))
(f (fxadd1 i))))
(cond
[clos-m
(let ([clos ($code->closure code)])
(put-mark clos-m clos)
(set-code-reloc-vector! code (read))
clos)]
[else
(set-code-reloc-vector! code (read))
code]))))
(define (read-thunk m)
(let ([c (read-char p)])
(case c
[(#\x)
(read-code #f m)]
[(#\<)
(let ([cm (read-int p)])
(unless (fx< cm (vector-length marks))
(error who "invalid mark ~s\n" m))
(let ([code (vector-ref marks cm)])
(let ([proc ($code->closure code)])
(when m (put-mark m proc))
proc)))]
[(#\>)
(let ([cm (read-int p)])
(assert-eq? (read-char p) #\x)
(read-code cm m))]
[else (error who "invalid code header ~s" c)])))
(define (read/mark m)
(define (nom)
(when m (error who "unhandled mark")))
(let ([h (read-char p)])
(case h
[(#\I)
(nom)
(read-fixnum p)]
[(#\P)
(if m
(let ([x (cons #f #f)])
(put-mark m x)
(set-car! x (read))
(set-cdr! x (read))
x)
(let ([a (read)])
(cons a (read))))]
[(#\N) '()]
[(#\T) #t]
[(#\F) #f]
[(#\E) (eof-object)]
[(#\U) (void)]
[(#\S) ;;; string
(let ([n (read-int p)])
(let ([str (make-string n)])
(let f ([i 0])
(unless (fx= i n)
(let ([c (read-char p)])
(string-set! str i c)
(f (fxadd1 i)))))
(when m (put-mark m str))
str))]
[(#\M) ;;; symbol
(let ([str (read)])
(let ([sym (string->symbol str)])
(when m (put-mark m sym))
sym))]
[(#\G)
(let* ([pretty (read)]
[unique (read)])
(foreign-call "ikrt_strings_to_gensym" pretty unique))]
[(#\V) ;;; vector
(let ([n (read-int p)])
(let ([v (make-vector n)])
(when m (put-mark m v))
(let f ([i 0])
(unless (fx= i n)
(vector-set! v i (read))
(f (fxadd1 i))))
v))]
[(#\x) ;;; code
(read-code m #f)]
[(#\Q) ;;; thunk
(read-thunk m)]
[(#\R)
(let* ([rtd-name (read)]
[rtd-symbol (read)]
[field-count (read-int p)])
(let ([fields
(let f ([i 0])
(cond
[(fx= i field-count) '()]
[else
(let ([a (read)])
(cons a (f (fxadd1 i))))]))])
(let ([rtd (make-record-type
rtd-name fields rtd-symbol)])
(when m (put-mark m rtd))
rtd)))]
[(#\{)
(let ([n (read-int p)])
(let ([rtd (read)])
(let ([x ($make-record rtd n)])
(when m (put-mark m x))
(let f ([i 0])
(unless (fx= i n)
(record-set! x i (read))
(f (fxadd1 i))))
x)))]
[(#\C)
(let ([c (read-char p)])
(cond
[(char? c) c]
[else
(error who "invalid eof inside a fasl object")]))]
[(#\>)
(let ([m (read-int p)])
(read/mark m))]
[(#\<)
(let ([m (read-int p)])
(unless (fx< m (vector-length marks))
(error who "invalid mark ~s\n" m))
(vector-ref marks m))]
[else
(error who "Unexpected ~s as a fasl object header" h)])))
(read))
(primitive-set! '$fasl-read
(lambda (p)
(assert-eq? (read-char p) #\I)
(assert-eq? (read-char p) #\K)
(assert-eq? (read-char p) #\0)
(assert-eq? (read-char p) #\1)
(do-read p))))

37
src/librecord.ss
View File

@ -79,21 +79,40 @@
[else #f])))
(define make-record-type
(lambda (name fields)
(unless (string? name)
(error 'make-record-type "name must be a string, got ~s" name))
(unless (list? fields)
(error 'make-record-type "fields must be a list, got ~s" fields))
(for-each verify-field fields)
(make-rtd name fields #f (gensym name))))
(case-lambda
[(name fields)
(unless (string? name)
(error 'make-record-type "name must be a string, got ~s" name))
(unless (list? fields)
(error 'make-record-type "fields must be a list, got ~s" fields))
(for-each verify-field fields)
(let ([g (gensym name)])
(let ([rtd (make-rtd name fields #f g)])
(set-top-level-value! g rtd)
rtd))]
[(name fields g)
(unless (string? name)
(error 'make-record-type "name must be a string, got ~s" name))
(unless (list? fields)
(error 'make-record-type "fields must be a list, got ~s" fields))
(for-each verify-field fields)
(cond
[(top-level-bound? g)
(let ([rtd (top-level-value g)])
(unless (and (string=? name (record-type-name rtd))
(equal? fields (record-type-field-names rtd)))
(error 'make-record-type "definition mismatch"))
rtd)]
[else
(let ([rtd (make-rtd name fields #f g)])
(set-top-level-value! g rtd)
rtd)])]))
(define record-type-name
(lambda (rtd)
(unless (rtd? rtd)
(error 'record-type-name "~s is not an rtd" rtd))
(rtd-name rtd)))
(define record-type-symbol
(lambda (rtd)

2
src/libtokenizer.ss
View File

@ -405,6 +405,8 @@
[else
(error 'tokenize
"invalid char ~a inside gensym" c)])))]))]
[($char= #\@ c)
(cons 'datum ($fasl-read p))]
[else
(unread-char c p)
(error 'tokenize "invalid syntax #~a" c)])))

1
src/makefile.ss
View File

@ -115,6 +115,7 @@
trace-symbol! untrace-symbol! make-traced-procedure
fixnum->string
$interrupted? $unset-interrupted! $do-event
$fasl-read
;;; TODO: must open-code
$make-port/input $make-port/output $make-port/both