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

Exported the transcoder? primitive.

This commit is contained in:
Abdulaziz Ghuloum 2007-12-06 05:05:26 -05:00
parent f7021bbcbc
commit 1469932f3d
11 changed files with 299 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
lab/io-prims.ss
View File

@ -1,9 +0,0 @@
(library (io-prims)
(export )
(import
(io-spec)
(except (ikarus)))
)

205
lab/io-spec.ss
View File

@ -1,28 +1,41 @@
(library (io-spec)
(export )
(export
input-port? textual-port? port-eof?
open-bytevector-input-port
make-custom-binary-input-port
get-char lookahead-char get-u8 lookahead-u8 close-port)
(import
(except (ikarus) get-char get-u8 put-char put-u8))
(except (ikarus)
input-port? textual-port? port-eof?
open-bytevector-input-port
make-custom-binary-input-port
get-char lookahead-char get-u8 lookahead-u8 close-port))
(define-struct $port
(index size buffer base-index codec closed? handlers attrs))
(index size buffer base-index codec closed? attrs
id read! write! get-position set-position! close))
(define $set-port-index! set-$port-index!)
(define $set-port-size! set-$port-size!)
(define $set-port-attrs! set-$port-attrs!)
(define $set-port-closed?! set-$port-closed?!)
(define $make-port make-$port)
(define fast-get-tag #x0001)
(define fast-put-tag #x0002)
(define fast-get-tag #x0001)
(define fast-put-tag #x0002)
(define fast-get-position-tag #x0004)
(define fast-get-mask #x00F0)
(define fast-get-utf8-tag #x0010)
(define fast-get-latin-tag #x0030)
(define fast-get-byte-tag #x0040)
(define fast-get-char-tag #x0080)
(define fast-get-mask #x00F0)
(define fast-get-utf8-tag #x0010)
(define fast-get-latin-tag #x0030)
(define fast-get-byte-tag #x0040)
(define fast-get-char-tag #x0080)
(define fast-put-mask #x0F00)
(define fast-put-utf8-tag #x0100)
(define fast-put-latin-tag #x0300)
(define fast-put-byte-tag #x0400)
(define fast-put-char-tag #x0800)
(define fast-put-mask #x0F00)
(define fast-put-utf8-tag #x0100)
(define fast-put-latin-tag #x0300)
(define fast-put-byte-tag #x0400)
(define fast-put-char-tag #x0800)
(define r6rs-mode-tag #x1000)
@ -38,8 +51,82 @@
;;; everything above this line will turn into primitive
;;; ----------------------------------------------------------
(define-struct handler
(data id read! write! get-position set-position! close))
(define ($make-custom-binary-input-port id
read! get-position set-position! close buffer-size)
(let ([bv (make-bytevector buffer-size)])
($make-port 0 0 bv 0 #f #f 0 id read! #f get-position
set-position! close)))
(define (make-custom-binary-input-port id
read! get-position set-position! close)
;;; FIXME: get-position and set-position! are ignored for now
(define who 'make-custom-binary-input-port)
(unless (string? id)
(error who "id is not a string" id))
(unless (procedure? read!)
(error who "read! is not a procedure" read!))
(unless (or (procedure? close) (not close))
(error who "close should be either a procedure or #f" close))
($make-custom-binary-input-port id read! get-position
set-position! close 256))
(define (transcoder-attrs x)
(import (ikarus system $transcoders))
(cond
[(not x) ;;; binary
(fxior fast-get-tag fast-get-byte-tag)]
[else
(error 'transcoder-attrs "not handled" x)]))
(define open-bytevector-input-port
(case-lambda
[(bv) (open-bytevector-input-port bv #f)]
[(bv maybe-transcoder)
(import (ikarus system $transcoders))
(unless (bytevector? bv)
(error 'open-bytevector-input-port
"not a bytevector" bv))
(when (and maybe-transcoder
(not ($transcoder? maybe-transcoder)))
(error 'open-bytevector-input-port
"not a transcoder" maybe-transcoder))
($make-port 0 (bytevector-length bv) bv 0
maybe-transcoder
#f ;;; closed?
(transcoder-attrs maybe-transcoder)
"*bytevector-input-port*"
(lambda (bv i c) 0) ;;; read!
#f ;;; write!
#f ;;; FIXME: get-position
#f ;;; FIXME: set-position!
#f ;;; close
)]))
(define (input-port? p)
(and ($port? p)
($port-read! p)
#t))
(define (textual-port? p)
(and ($port? p)
($port-codec p)
#t))
(define (close-port p)
(cond
[(not ($port? p))
(error 'close-port "not a port" p)]
[($port-closed? p) (void)]
[else
(when ($port-write! p)
(flush-output-port p))
($set-port-closed?! p #t)
(let ([close ($port-close p)])
(when (procedure? close)
(close)))]))
(define-syntax define-rrr
(syntax-rules ()
@ -48,11 +135,12 @@
(error 'name "not implemented" args))]))
;;; ----------------------------------------------------------
(module (get-char)
(module (get-char lookahead-char)
(define-rrr get-char-utf8-mode)
(define-rrr get-char-latin-mode)
(define-rrr get-char-char-mode)
(define-rrr slow-get-char)
(define-rrr lookahead-char)
;;;
(define (get-char p)
(define who 'get-char)
@ -90,9 +178,35 @@
[else (slow-get-char p who)]))))
;;; ----------------------------------------------------------
(module (get-u8)
(define-rrr get-u8-byte-mode)
(define-rrr slow-get-u8)
(define (assert-binary-input-port p who)
(unless ($port? p) (error who "not a port" p))
(when ($port-closed? p) (error who "port is closed" p))
(when ($port-codec p) (error who "port is not binary" p))
(unless ($port-read! p)
(error who "port is not an input port" p)))
(module (get-u8 lookahead-u8)
(define (get-u8-byte-mode p who start)
(when ($port-closed? p) (error who "port is closed" p))
(let* ([bv ($port-buffer p)]
[n (bytevector-length bv)])
(let ([j (($port-read! p) bv 0 n)])
(unless (fixnum? j)
(error who "invalid return value from read! procedure" j))
(cond
[(fx> j 0)
(unless (fx<= j n)
(error who "read! returned a value out of range" j))
($set-port-index! p start)
($set-port-size! p j)
(bytevector-u8-ref bv 0)]
[(fx= j 0) (eof-object)]
[else
(error who "read! returned a value out of range" j)]))))
(define (slow-get-u8 p who start)
(assert-binary-input-port p who)
($set-port-attrs! p (fxior fast-get-tag fast-get-byte-tag))
(get-u8-byte-mode p who start))
;;;
(define (get-u8 p)
(define who 'get-u8)
@ -104,9 +218,49 @@
[(fx< i ($port-size p))
($set-port-index! p (fx+ i 1))
(bytevector-u8-ref ($port-buffer p) i)]
[else (get-u8-byte-mode p who)]))]
[else (slow-get-u8 p who)]))))
[else (get-u8-byte-mode p who 1)]))]
[else (slow-get-u8 p who 1)])))
(define (lookahead-u8 p)
(define who 'lookahead-u8)
(let ([m ($port-get-mode p)])
(cond
[(eq? m fast-get-byte-tag)
(let ([i ($port-index p)])
(cond
[(fx< i ($port-size p))
(bytevector-u8-ref ($port-buffer p) i)]
[else (get-u8-byte-mode p who 0)]))]
[else (slow-get-u8 p who 0)]))))
(define (port-eof? p)
(define who 'port-eof?)
(let ([m ($port-get-mode p)])
(cond
[(not (eq? m 0))
(if (fx< ($port-index p) ($port-size p))
#f
(if ($port-codec p)
(eof-object? (lookahead-char p))
(eof-object? (lookahead-u8 p))))]
[(input-port? p)
(when ($port-closed? p)
(error 'port-eof? "port is closed" p))
(if (textual-port? p)
(eof-object? (lookahead-char p))
(eof-object? (lookahead-u8 p)))]
[else (error 'port-eof? "not an input port" p)])))
)
#!eof
;;; ----------------------------------------------------------
;;; do input ports first.
;;; ----------------------------------------------------------
(module (put-char)
(define-rrr put-char-utf8-mode)
@ -147,7 +301,6 @@
(put-char-latin-mode p b who)])))]
[else (slow-put-char p c who)]))))
;;; ----------------------------------------------------------
(module (put-u8)
(define-rrr put-u8-byte-mode)
(define-rrr slow-put-u8)
@ -166,7 +319,3 @@
[else
(put-u8-byte-mode p b who)]))]
[else (slow-put-u8 p b who)]))))
;;; that's it for today. see you tomorrow .
)

108
lab/io-test.ss Executable file
View File

@ -0,0 +1,108 @@
#!/usr/bin/env scheme-script
(import
(except (ikarus) get-char get-u8 lookahead-u8 close-port input-port?)
(io-spec))
(define-syntax test
(syntax-rules ()
[(_ name body)
(begin
(printf "running ~s ..." 'name)
body
(printf " ok\n"))]))
(define (make-n-byte-custom-binary-input-port n)
(assert (<= 0 n 256))
(make-custom-binary-input-port "test0"
(let ([c 0])
(lambda (bv i count)
(if (< c n)
(begin
(bytevector-u8-set! bv i c)
(set! c (+ c 1))
1)
0)))
#f #f #f))
(define (make-n-byte-bytevector-binary-input-port n)
(assert (<= 0 n 256))
(let ([bv (make-bytevector n)])
(let f ([i 0])
(unless (= i n)
(bytevector-u8-set! bv i i)
(f (+ i 1))))
(open-bytevector-input-port bv)))
(define (test-get-u8-1 p n)
(let f ([i 0])
(let ([x (get-u8 p)])
(cond
[(eof-object? x)
(unless (= i n)
(error 'test0 "premature termination" i))]
[(= x i) (f (+ i 1))]
[else
(error 'test0 "incorrect value returned" x)]))))
(define (test-peek-u8-1 p n)
(let f ([i 0])
(let* ([px (lookahead-u8 p)]
[x (get-u8 p)])
(cond
[(not (eqv? px x)) (error #f "peek invalid" px x)]
[(eof-object? x)
(unless (= i n)
(error #f "premature termination" i))]
[(= x i) (f (+ i 1))]
[else
(error #f "incorrect value returned" x i)]))))
(define (test-port-eof?-1 p n)
(let f ([i 0])
(cond
[(port-eof? p)
(unless (= i n)
(error #f "premature termination" i))
(assert (eof-object? (lookahead-u8 p)))
(assert (eof-object? (get-u8 p)))]
[(= (get-u8 p) i) (f (+ i 1))]
[else
(error #f "incorrect value returned" i)])))
(test "reading 256 bytes in ascending order"
(test-get-u8-1 (make-n-byte-custom-binary-input-port 256) 256))
(test "reading 256 bytes in ascending order 2 at a time"
(test-get-u8-1
(make-custom-binary-input-port "test0"
(let ([c 0])
(lambda (bv i count)
(if (< c 256)
(begin
(assert (>= count 2))
(bytevector-u8-set! bv i c)
(bytevector-u8-set! bv (+ i 1) (+ c 1))
(set! c (+ c 2))
2)
0)))
#f #f #f)
256))
(test "peeking 256 bytes in ascending order"
(test-peek-u8-1 (make-n-byte-custom-binary-input-port 256) 256))
(test "custom-binary-port port-eof?"
(test-port-eof?-1 (make-n-byte-custom-binary-input-port 256) 256))
;;;
(test "reading 256 bytes from bytevector-input-port"
(test-get-u8-1 (make-n-byte-bytevector-binary-input-port 256) 256))
(test "peeking 256 bytes from bytevector-input-port"
(test-peek-u8-1 (make-n-byte-bytevector-binary-input-port 256) 256))
(test "bytevector-binary-port port-eof?"
(test-port-eof?-1 (make-n-byte-bytevector-binary-input-port 256) 256))

6
lab/test-io.ss
View File

@ -1,6 +0,0 @@
#!/usr/bin/env scheme-script
(import
(except (ikarus))
(io-spec))

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

6
scheme/ikarus.codecs.ss
View File

@ -91,7 +91,7 @@
(define (transcoder-codec x)
(define who 'transcoder-codec)
(if ($transcoder? x)
(if (transcoder? x)
(let ([tag (fxlogand ($transcoder->data x) codec-mask)])
(or (rev-lookup tag codec-alist)
(error who "transcoder has no codec" x)))
@ -99,7 +99,7 @@
(define (transcoder-eol-style x)
(define who 'transcoder-eol-style)
(if ($transcoder? x)
(if (transcoder? x)
(let ([tag (fxlogand ($transcoder->data x) eol-style-mask)])
(or (rev-lookup tag eol-style-alist)
(error who "transcoder has no eol-style" x)))
@ -107,7 +107,7 @@
(define (transcoder-error-handling-mode x)
(define who 'transcoder-error-handling-mode)
(if ($transcoder? x)
(if (transcoder? x)
(let ([tag (fxlogand ($transcoder->data x) error-handling-mode-mask)])
(or (rev-lookup tag error-handling-mode-alist)
(error who "transcoder has no error-handling mode" x)))

7
scheme/ikarus.predicates.ss
View File

@ -22,14 +22,14 @@
symbol? code? not weak-pair? eq? eqv? equal? boolean=?
symbol=? finite? infinite? nan? real-valued?
rational-valued? integer-valued?
output-port? input-port? port?)
output-port? input-port? port? transcoder?)
(import
(except (ikarus) fixnum? flonum? bignum? ratnum? number? complex? real?
rational? integer? exact? inexact? eof-object? bwp-object?
immediate? boolean? char? vector? bytevector? string? procedure?
null? pair? weak-pair? symbol? code? not eq? eqv? equal?
port? input-port? output-port? boolean=? symbol=?
transcoder? port? input-port? output-port? boolean=? symbol=?
finite? infinite? nan? real-valued? rational-valued?
integer-valued?)
(ikarus system $fx)
@ -41,6 +41,7 @@
(rename (only (ikarus) fixnum? flonum? bignum? ratnum? eof-object?
bwp-object? immediate? boolean? char? vector? string?
bytevector? procedure? null? pair? symbol? code? eq?
transcoder?
port? input-port? output-port?)
(fixnum? sys:fixnum?)
(flonum? sys:flonum?)
@ -60,6 +61,7 @@
(symbol? sys:symbol?)
(code? sys:code?)
(eq? sys:eq?)
(transcoder? sys:transcoder?)
(port? sys:port?)
(input-port? sys:input-port?)
(output-port? sys:output-port?)
@ -173,6 +175,7 @@
(define eof-object? (lambda (x) (sys:eof-object? x)))
(define bwp-object? (lambda (x) (sys:bwp-object? x)))
(define transcoder? (lambda (x) (sys:transcoder? x)))
(define immediate? (lambda (x) (sys:immediate? x)))
(define boolean? (lambda (x) (sys:boolean? x)))
(define char? (lambda (x) (sys:char? x)))

2
scheme/ikarus.writer.ss
View File

@ -589,7 +589,7 @@
[(number? x)
(write-char* (number->string x) p)
i]
[($transcoder? x)
[(transcoder? x)
(write-char* "#<transcoder " p)
(let ([n ($transcoder->data x)])
(write-char* (number->string n) p))

2
scheme/last-revision
View File

@ -1 +1 @@
1187
1190

2
scheme/makefile.ss
View File

@ -1133,6 +1133,7 @@
[make-transcoder i r ip]
[native-eol-style i r ip]
[native-transcoder i r ip]
[transcoder? i]
[open-bytevector-input-port r ip]
[open-bytevector-output-port i r ip]
[open-file-input-port r ip]
@ -1298,7 +1299,6 @@
[library i]
[syntax-dispatch ]
[syntax-error i r sc]
[$transcoder? $transc]
[$transcoder->data $transc]
[$data->transcoder $transc]
[file-options-spec i]

4
scheme/pass-specify-rep-primops.ss
View File

@ -1964,8 +1964,10 @@
/section)
(section ; transcoders
(define-primop $transcoder? unsafe
(define-primop transcoder? unsafe
[(P x) (tag-test (T x) transcoder-mask transcoder-tag)])
(define-primop $data->transcoder unsafe
[(V x) (prm 'logor
(prm 'sll (T x) (K (- transcoder-payload-shift fixnum-shift)))