diff --git a/src/ikarus.boot b/src/ikarus.boot index 99859a2..2150c1b 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.reader.ss b/src/ikarus.reader.ss index 7f116ee..d02ac4b 100644 --- a/src/ikarus.reader.ss +++ b/src/ikarus.reader.ss @@ -3,6 +3,9 @@ (export read read-initial read-token comment-handler) (import (ikarus system $chars) + (ikarus system $fx) + (ikarus system $pairs) + (ikarus system $bytevectors) (except (ikarus) read read-token comment-handler)) (define delimiter? @@ -460,6 +463,25 @@ [else (error 'tokenize "invalid char ~a inside gensym" c)])))]))] + [($char= #\v c) + (let ([c (read-char p)]) + (cond + [($char= #\u c) + (let ([c (read-char p)]) + (cond + [($char= c #\8) + (let ([c (read-char p)]) + (cond + [($char= c #\() 'vu8] + [(eof-object? c) + (error 'tokenize "invalid eof object after #vu8")] + [else (error 'tokenize "invalid sequence #vu8~a" c)]))] + [(eof-object? c) + (error 'tokenize "invalid eof object after #vu")] + [else (error 'tokenize "invalid sequence #vu~a" c)]))] + [(eof-object? c) + (error 'tokenize "invalid eof object after #v")] + [else (error 'tokenize "invalid sequence #v~a" c)]))] [($char= #\@ c) (error 'read "FIXME: fasl read disabled") '(cons 'datum ($fasl-read p))] @@ -634,6 +656,19 @@ (k)) k) (fxsub1 i) (cdr ls)))]))) + (define bytevector-put + (lambda (v k i ls) + (cond + [(null? ls) k] + [else + (let ([a (car ls)]) + (cond + [(fixnum? a) + (unless (and (fx<= 0 a) (fx<= a 255)) + (error 'read "invalid value ~s in a bytevector" a)) + ($bytevector-set! v i a) + (bytevector-put v k ($fxsub1 i) ($cdr ls))] + [else (error 'read "invalid value ~s is a bytevector" a)]))]))) (define read-vector (lambda (p locs k count ls) (let ([t (tokenize p)]) @@ -654,6 +689,26 @@ [else (let-values ([(a locs k) (parse-token p locs k t)]) (read-vector p locs k (fxadd1 count) (cons a ls)))])))) + (define read-bytevector + (lambda (p locs k count ls) + (let ([t (tokenize p)]) + (cond + [(eof-object? t) + (error 'read "end of file encountered while reading a bytevector")] + [(eq? t 'rparen) + (let ([v ($make-bytevector count)]) + (let ([k (bytevector-put v k (fxsub1 count) ls)]) + (values v locs k)))] + [(eq? t 'rbrack) + (error 'read "unexpected ] while reading a bytevector")] + [(eq? t 'dot) + (error 'read "unexpected . while reading a bytevector")] + [(eq? t 'hash-semi) + (let-values ([(ignored locs k) (read-expr p locs k)]) + (read-bytevector p locs k count ls))] + [else + (let-values ([(a locs k) (parse-token p locs k t)]) + (read-bytevector p locs k (fxadd1 count) (cons a ls)))])))) (define-record loc (value set?)) (define parse-token (lambda (p locs k t) @@ -665,6 +720,7 @@ [(eq? t 'hash-semi) (let-values ([(ignored locs k) (read-expr p locs k)]) (read-expr p locs k))] + [(eq? t 'vu8) (read-bytevector p locs k 0 '())] [(pair? t) (cond [(eq? (car t) 'datum) (values (cdr t) locs k)] diff --git a/src/ikarus.writer.ss b/src/ikarus.writer.ss index a412a8e..5b335d1 100644 --- a/src/ikarus.writer.ss +++ b/src/ikarus.writer.ss @@ -9,6 +9,7 @@ (ikarus system $fx) (ikarus system $pairs) (ikarus system $symbols) + (ikarus system $bytevectors) (except (ikarus) write display format printf print-error error-handler error)) @@ -74,6 +75,30 @@ (write-char #\) p) i)))) + (define write-bytevector + (lambda (x p m h i) + (write-char #\# p) + (write-char #\v p) + (write-char #\u p) + (write-char #\8 p) + (write-char #\( p) + (let ([n ($bytevector-length x)]) + (let ([i + (cond + [(fx> n 0) + (let f ([idx 1] [i (writer ($bytevector-u8-ref x 0) p m h i)]) + (cond + [(fx= idx n) + i] + [else + (write-char #\space p) + (f (fxadd1 idx) + (writer (bytevector-u8-ref x idx) p m h i))]))] + [else i])]) + (write-char #\) p) + i)))) + + (define write-record (lambda (x p m h i) (write-char #\# p) @@ -347,6 +372,8 @@ i)] [(vector? x) (write-shareable x p m h i write-vector)] + [(bytevector? x) + (write-shareable x p m h i write-bytevector)] [(null? x) (write-char #\( p) (write-char #\) p) diff --git a/src/tests/bytevectors.ss b/src/tests/bytevectors.ss index 23c3318..daab249 100644 --- a/src/tests/bytevectors.ss +++ b/src/tests/bytevectors.ss @@ -105,6 +105,9 @@ (bytevector-uint-ref b 0 'big 16) (bytevector-sint-ref b 0 'big 16) (bytevector->u8-list b)))] + [(lambda (x) (equal? x '(1 2 3 4))) + (bytevector->u8-list '#vu8(1 2 3 4))] + ))