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

Code of fasl-write is changed to use only binary output prims.

This commit is contained in:
Abdulaziz Ghuloum 2007-12-08 14:52:35 -05:00
parent 515101d188
commit 0e93ac2db9
4 changed files with 132 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
lab/io-spec.ss
View File

@ -1,20 +1,51 @@
(library (io-spec) (library (io-spec)
(export (export
input-port? textual-port? port-eof? input-port? output-port? textual-port? binary-port?
open-file-input-port standard-input-port current-input-port
open-bytevector-input-port open-bytevector-input-port
open-string-input-port open-string-input-port
make-custom-binary-input-port make-custom-binary-input-port
get-char lookahead-char get-u8 lookahead-u8 close-port transcoded-port port-transcoder
transcoded-port) close-port
port-eof?
get-char lookahead-char
get-string-n get-string-n! get-string-all get-line
get-u8 lookahead-u8
get-bytevector-n get-bytevector-n!
get-bytevector-some get-bytevector-all
port-has-port-position? port-position
port-has-set-port-position!? set-port-position!
call-with-port
)
(import (import
(except (ikarus) (except (ikarus)
input-port? textual-port? port-eof? input-port? output-port? textual-port? binary-port?
open-file-input-port standard-input-port current-input-port
open-bytevector-input-port open-bytevector-input-port
open-string-input-port open-string-input-port
make-custom-binary-input-port make-custom-binary-input-port
get-char lookahead-char get-u8 lookahead-u8 close-port transcoded-port port-transcoder
transcoded-port)) close-port
port-eof?
get-char lookahead-char
get-string-n get-string-n! get-string-all get-line
get-u8 lookahead-u8
get-bytevector-n get-bytevector-n!
get-bytevector-some get-bytevector-all
port-has-port-position? port-position
port-has-set-port-position!? set-port-position!
call-with-port
))
(define-syntax define-rrr
(syntax-rules ()
[(_ name)
(define (name . args)
(apply error 'name "not implemented" args))]))
(define-struct $port (define-struct $port
(index size buffer base-index transcoder closed? attrs (index size buffer base-index transcoder closed? attrs
@ -150,6 +181,10 @@
($port-close p)))) ($port-close p))))
(define (output-port? p)
(and ($port? p)
($port-write! p)
#t))
(define (input-port? p) (define (input-port? p)
(and ($port? p) (and ($port? p)
@ -161,6 +196,16 @@
($port-transcoder p) ($port-transcoder p)
#t)) #t))
(define (binary-port? p)
(and ($port? p)
(not ($port-transcoder p))))
(define (port-transcoder p)
(if ($port? p)
(let ([tr ($port-transcoder p)])
(and (transcoder? tr) tr))
(error 'port-transcoder "not a port" p)))
(define (close-port p) (define (close-port p)
(cond (cond
[(not ($port? p)) [(not ($port? p))
@ -174,11 +219,10 @@
(when (procedure? close) (when (procedure? close)
(close)))])) (close)))]))
(define-syntax define-rrr (define-rrr port-has-port-position?)
(syntax-rules () (define-rrr port-position)
[(_ name) (define-rrr port-has-set-port-position!?)
(define (name . args) (define-rrr set-port-position!)
(apply error 'name "not implemented" args))]))
;;; ---------------------------------------------------------- ;;; ----------------------------------------------------------
(module (get-char lookahead-char) (module (get-char lookahead-char)
@ -412,7 +456,6 @@
[else (get-char-utf8-mode p who)]))])] [else (get-char-utf8-mode p who)]))])]
[else (do-error p who)]))]))) [else (do-error p who)]))])))
(define (advance-utf8-bom p who) (define (advance-utf8-bom p who)
(let ([i ($port-index p)] (let ([i ($port-index p)]
[j ($port-size p)] [j ($port-size p)]
@ -624,7 +667,29 @@
(eof-object? (lookahead-u8 p)))] (eof-object? (lookahead-u8 p)))]
[else (error 'port-eof? "not an input port" p)]))) [else (error 'port-eof? "not an input port" p)])))
(define-rrr open-file-input-port)
(define-rrr standard-input-port)
(define-rrr current-input-port)
(define (call-with-port p proc)
(if ($port? p)
(if (procedure? proc)
(dynamic-wind
void
(lambda () (proc p))
(lambda () (close-port p)))
(error 'call-with-port "not a procedure" proc))
(error 'call-with-port "not a port" p)))
(define-rrr get-bytevector-n)
(define-rrr get-bytevector-n!)
(define-rrr get-bytevector-some)
(define-rrr get-bytevector-all)
(define-rrr get-string-n)
(define-rrr get-string-n!)
(define-rrr get-string-all)
(define-rrr get-line)
) )

9
lab/io-test.ss
View File

@ -1,8 +1,13 @@
#!/usr/bin/env scheme-script #!/usr/bin/env scheme-script
(import (import
(except (ikarus) get-char get-u8 lookahead-u8 close-port input-port?
open-string-input-port) (except (ikarus) get-char get-u8 lookahead-u8 close-port
input-port? open-string-input-port output-port?
standard-input-port current-input-port
get-bytevector-n get-bytevector-n!
get-string-n get-string-n! get-line)
(io-spec)) (io-spec))
(define-syntax test (define-syntax test

86
scheme/ikarus.fasl.write.ss
View File

@ -31,6 +31,9 @@
(except (ikarus code-objects) procedure-annotation) (except (ikarus code-objects) procedure-annotation)
(except (ikarus) fasl-write)) (except (ikarus) fasl-write))
(define (put-tag c p)
(write-byte (char->integer c) p))
(define write-fixnum (define write-fixnum
(lambda (x p) (lambda (x p)
(unless (fixnum? x) (error 'write-fixnum "not a fixnum" x)) (unless (fixnum? x) (error 'write-fixnum "not a fixnum" x))
@ -48,25 +51,23 @@
(define fasl-write-immediate (define fasl-write-immediate
(lambda (x p) (lambda (x p)
(cond (cond
[(null? x) (write-char #\N p)] [(null? x) (put-tag #\N p)]
[(fixnum? x) [(fixnum? x)
(write-char #\I p) (put-tag #\I p)
(write-fixnum x p)] (write-fixnum x p)]
[(char? x) [(char? x)
(let ([n ($char->fixnum x)]) (let ([n ($char->fixnum x)])
(if ($fx<= n 255) (if ($fx<= n 255)
(begin (begin
(write-char #\c p) (put-tag #\c p)
(write-byte n p)) (write-byte n p))
(begin (begin
(write-char #\C p) (put-tag #\C p)
(write-int n p))))] (write-int n p))))]
; (write-char #\C p)
; (write-char x p)]
[(boolean? x) [(boolean? x)
(write-char (if x #\T #\F) p)] (put-tag (if x #\T #\F) p)]
[(eof-object? x) (write-char #\E p)] [(eof-object? x) (put-tag #\E p)]
[(eq? x (void)) (write-char #\U p)] [(eq? x (void)) (put-tag #\U p)]
[else (error 'fasl-write "not a fasl-writable immediate" x)]))) [else (error 'fasl-write "not a fasl-writable immediate" x)])))
(define (ascii-string? s) (define (ascii-string? s)
@ -97,22 +98,22 @@
(let ([n (count-unshared-cdrs d h 0)]) (let ([n (count-unshared-cdrs d h 0)])
(cond (cond
[($fx= n 0) [($fx= n 0)
(write-char #\P p) (put-tag #\P p)
(fasl-write-object d p h (fasl-write-object d p h
(fasl-write-object (car x) p h m))] (fasl-write-object (car x) p h m))]
[else [else
(cond (cond
[($fx<= n 255) [($fx<= n 255)
(write-char #\l p) (put-tag #\l p)
(write-byte n p)] (write-byte n p)]
[else [else
(write-char #\L p) (put-tag #\L p)
(write-int n p)]) (write-int n p)])
(write-pairs d p h (write-pairs d p h
(fasl-write-object (car x) p h m) (fasl-write-object (car x) p h m)
n)])))] n)])))]
[(vector? x) [(vector? x)
(write-char #\V p) (put-tag #\V p)
(write-int (vector-length x) p) (write-int (vector-length x) p)
(let f ([x x] [i 0] [n (vector-length x)] [m m]) (let f ([x x] [i 0] [n (vector-length x)] [m m])
(cond (cond
@ -123,14 +124,14 @@
[(string? x) [(string? x)
(cond (cond
[(ascii-string? x) [(ascii-string? x)
(write-char #\s p) (put-tag #\s p)
(write-int (string-length x) p) (write-int (string-length x) p)
(let f ([x x] [i 0] [n (string-length x)]) (let f ([x x] [i 0] [n (string-length x)])
(unless (fx= i n) (unless (fx= i n)
(write-char (string-ref x i) p) (write-byte (char->integer (string-ref x i)) p)
(f x (fxadd1 i) n)))] (f x (fxadd1 i) n)))]
[else [else
(write-char #\S p) (put-tag #\S p)
(write-int (string-length x) p) (write-int (string-length x) p)
(let f ([x x] [i 0] [n (string-length x)]) (let f ([x x] [i 0] [n (string-length x)])
(unless (= i n) (unless (= i n)
@ -138,14 +139,14 @@
(f x (fxadd1 i) n)))]) (f x (fxadd1 i) n)))])
m] m]
[(gensym? x) [(gensym? x)
(write-char #\G p) (put-tag #\G p)
(fasl-write-object (gensym->unique-string x) p h (fasl-write-object (gensym->unique-string x) p h
(fasl-write-object (symbol->string x) p h m))] (fasl-write-object (symbol->string x) p h m))]
[(symbol? x) [(symbol? x)
(write-char #\M p) (put-tag #\M p)
(fasl-write-object (symbol->string x) p h m)] (fasl-write-object (symbol->string x) p h m)]
[(code? x) [(code? x)
(write-char #\x p) (put-tag #\x p)
(write-int (code-size x) p) (write-int (code-size x) p)
(write-fixnum (code-freevars x) p) (write-fixnum (code-freevars x) p)
(let ([m (fasl-write-object ($code-annotation x) p h m)]) (let ([m (fasl-write-object ($code-annotation x) p h m)])
@ -159,7 +160,7 @@
(cond (cond
[(eq? rtd (base-rtd)) [(eq? rtd (base-rtd))
;;; rtd record ;;; rtd record
(write-char #\R p) (put-tag #\R p)
(let ([names (struct-type-field-names x)] (let ([names (struct-type-field-names x)]
[m [m
(fasl-write-object (struct-type-symbol x) p h (fasl-write-object (struct-type-symbol x) p h
@ -173,7 +174,7 @@
(fasl-write-object (car names) p h m))])))] (fasl-write-object (car names) p h m))])))]
[else [else
;;; non-rtd record ;;; non-rtd record
(write-char #\{ p) (put-tag #\{ p)
(write-int (length (struct-type-field-names rtd)) p) (write-int (length (struct-type-field-names rtd)) p)
(let f ([names (struct-type-field-names rtd)] (let f ([names (struct-type-field-names rtd)]
[m (fasl-write-object rtd p h m)]) [m (fasl-write-object rtd p h m)])
@ -185,16 +186,16 @@
((struct-field-accessor rtd (car names)) x) ((struct-field-accessor rtd (car names)) x)
p h m))]))]))] p h m))]))]))]
[(procedure? x) [(procedure? x)
(write-char #\Q p) (put-tag #\Q p)
(fasl-write-object ($closure-code x) p h m)] (fasl-write-object ($closure-code x) p h m)]
[(bytevector? x) [(bytevector? x)
(write-char #\v p) (put-tag #\v p)
(let ([n ($bytevector-length x)]) (let ([n ($bytevector-length x)])
(write-int n p) (write-int n p)
(write-bytevector x 0 n p)) (write-bytevector x 0 n p))
m] m]
[(flonum? x) [(flonum? x)
(write-char #\f p) (put-tag #\f p)
(write-byte ($flonum-u8-ref x 7) p) (write-byte ($flonum-u8-ref x 7) p)
(write-byte ($flonum-u8-ref x 6) p) (write-byte ($flonum-u8-ref x 6) p)
(write-byte ($flonum-u8-ref x 5) p) (write-byte ($flonum-u8-ref x 5) p)
@ -205,11 +206,11 @@
(write-byte ($flonum-u8-ref x 0) p) (write-byte ($flonum-u8-ref x 0) p)
m] m]
[(ratnum? x) [(ratnum? x)
(write-char #\r p) (put-tag #\r p)
(fasl-write-object (numerator x) p h (fasl-write-object (numerator x) p h
(fasl-write-object (denominator x) p h m))] (fasl-write-object (denominator x) p h m))]
[(bignum? x) [(bignum? x)
(write-char #\b p) (put-tag #\b p)
(let ([sz ($bignum-size x)]) (let ([sz ($bignum-size x)])
(write-int (if ($bignum-positive? x) sz (- sz)) p) (write-int (if ($bignum-positive? x) sz (- sz)) p)
(let f ([i 0]) (let f ([i 0])
@ -235,11 +236,11 @@
(do-write x p h m)] (do-write x p h m)]
[(fx> mark 0) ; marked but not written [(fx> mark 0) ; marked but not written
(hashtable-set! h x (fx- 0 m)) (hashtable-set! h x (fx- 0 m))
(write-char #\> p) (put-tag #\> p)
(write-int m p) (write-int m p)
(do-write x p h (fxadd1 m))] (do-write x p h (fxadd1 m))]
[else [else
(write-char #\< p) (put-tag #\< p)
(write-int (fx- 0 mark) p) (write-int (fx- 0 mark) p)
m]))] m]))]
[else (error 'fasl-write "BUG: not in hash table" x)]))) [else (error 'fasl-write "BUG: not in hash table" x)])))
@ -290,8 +291,9 @@
(let ([code ($closure-code x)]) (let ([code ($closure-code x)])
(unless (fxzero? (code-freevars code)) (unless (fxzero? (code-freevars code))
(error 'fasl-write (error 'fasl-write
"Cannot write a non-thunk procedure; the one given has free vars" "Cannot write a non-thunk procedure; \
(code-freevars code))) the one given has free vars"
(code-freevars code)))
(make-graph code h))] (make-graph code h))]
[(bytevector? x) (void)] [(bytevector? x) (void)]
[(flonum? x) (void)] [(flonum? x) (void)]
@ -304,18 +306,18 @@
(lambda (x port) (lambda (x port)
(let ([h (make-eq-hashtable)]) (let ([h (make-eq-hashtable)])
(make-graph x h) (make-graph x h)
(write-char #\# port) (put-tag #\# port)
(write-char #\@ port) (put-tag #\@ port)
(write-char #\I port) (put-tag #\I port)
(write-char #\K port) (put-tag #\K port)
(write-char #\0 port) (put-tag #\0 port)
(write-char #\1 port) (put-tag #\1 port)
(fasl-write-object x port h 1) (fasl-write-object x port h 1)
(void)))) (void))))
(define fasl-write (define fasl-write
(case-lambda (case-lambda
[(x) (fasl-write-to-port x (current-output-port))] [(x) (fasl-write-to-port x (current-output-port))]
[(x port) [(x port)
(unless (output-port? port) (unless (output-port? port)
(error 'fasl-write "not an output port" port)) (error 'fasl-write "not an output port" port))
(fasl-write-to-port x port)]))) (fasl-write-to-port x port)])))

2
scheme/last-revision
View File

@ -1 +1 @@
1196 1198