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

cleanup of tags in ikarus.io.ss

This commit is contained in:
Abdulaziz Ghuloum 2007-12-12 18:59:19 -05:00
parent 28496998bb
commit eac9829a03
2 changed files with 62 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

125
scheme/ikarus.io.ss
View File

@ -121,34 +121,52 @@
(define $set-port-attrs! set-$port-attrs!) (define $set-port-attrs! set-$port-attrs!)
(define $set-port-closed?! set-$port-closed?!) (define $set-port-closed?! set-$port-closed?!)
(define $make-port make-$port) (define $make-port make-$port)
(define ($port-tag x) (if ($port? x) ($port-attrs x) 0))
(define ($port-fast-attrs x) (fxand ($port-tag x) fast-attrs-mask))
(define (u8? x) (and (fixnum? x) (fx>= x 0) (fx< x 256)))
(define (textual-port? x)
(fx= (fxand ($port-tag x) textual-port-tag) textual-port-tag))
(define ($port-get-mode x) (define (binary-port? x)
(and ($port? x) (fxand ($port-attrs x) fast-get-mask))) (fx= (fxand ($port-tag x) binary-port-tag) binary-port-tag))
(define ($port-put-mode x) (define (output-port? x)
(and ($port? x) (fxand ($port-attrs x) fast-put-mask))) (fx= (fxand ($port-tag x) output-port-tag) output-port-tag))
(define (u8? x) (define (input-port? x)
(and (fixnum? x) (fx>= x 0) (fx< x 256))) (fx= (fxand ($port-tag x) input-port-tag) input-port-tag))
(define (textual-port? p) ;;; everything above this line will turn into primitive
(and ($port? p) ;;; ----------------------------------------------------------
($port-transcoder p)
#t)) (define input-port-tag #b00000001)
(define output-port-tag #b00000010)
(define textual-port-tag #b00000100)
(define binary-port-tag #b00001000)
(define fast-char-text-tag #b00010000)
(define fast-u7-text-tag #b00100000)
(define fast-u8-text-tag #b01100000)
(define r6rs-mode-tag #b10000000)
(define (binary-port? p) (define fast-attrs-mask #b01111111)
(and ($port? p) (define binary-input-port-bits #b00001001)
(not ($port-transcoder p)))) (define binary-output-port-bits #b00001010)
(define textual-input-port-bits #b00000101)
(define textual-output-port-bits #b00000110)
(define (output-port? p) (define fast-get-byte-tag #b00001001)
(and ($port? p) (define fast-get-char-tag #b00010101)
($port-write! p) (define fast-get-utf8-tag #b00100101)
#t)) (define fast-get-latin-tag #b01100101)
(define (input-port? p) (define fast-put-byte-tag #b00001010)
(and ($port? p) (define fast-put-char-tag #b00010110)
($port-read! p) (define fast-put-utf8-tag #b00100110)
#t)) (define fast-put-latin-tag #b01100110)
(define (input-port-name p) (define (input-port-name p)
(if (input-port? p) (if (input-port? p)
@ -165,27 +183,6 @@
($port-id p) ($port-id p)
(error 'port-id "not a port" p))) (error 'port-id "not a port" p)))
;;; everything above this line will turn into primitive
;;; ----------------------------------------------------------
(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-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)
(define guarded-port (define guarded-port
(let ([G (make-guardian)]) (let ([G (make-guardian)])
(define (clean-up) (define (clean-up)
@ -223,7 +220,7 @@
(unless (or (procedure? close) (not close)) (unless (or (procedure? close) (not close))
(error who "close should be either a procedure or #f" close)) (error who "close should be either a procedure or #f" close))
($make-custom-binary-port ($make-custom-binary-port
(fxior fast-get-tag fast-get-byte-tag) binary-input-port-bits
0 0
id read! #f get-position id read! #f get-position
set-position! close 256)) set-position! close 256))
@ -239,7 +236,7 @@
(unless (or (procedure? close) (not close)) (unless (or (procedure? close) (not close))
(error who "close should be either a procedure or #f" close)) (error who "close should be either a procedure or #f" close))
($make-custom-binary-port ($make-custom-binary-port
(fxior fast-put-tag fast-put-byte-tag) binary-output-port-bits
256 256
id #f write! get-position id #f write! get-position
set-position! close 256)) set-position! close 256))
@ -255,7 +252,7 @@
(unless (or (procedure? close) (not close)) (unless (or (procedure? close) (not close))
(error who "close should be either a procedure or #f" close)) (error who "close should be either a procedure or #f" close))
($make-custom-textual-port ($make-custom-textual-port
(fxior fast-get-tag fast-get-char-tag) textual-input-port-bits
0 0
id read! #f get-position id read! #f get-position
set-position! close 256)) set-position! close 256))
@ -271,7 +268,7 @@
(unless (or (procedure? close) (not close)) (unless (or (procedure? close) (not close))
(error who "close should be either a procedure or #f" close)) (error who "close should be either a procedure or #f" close))
($make-custom-textual-port ($make-custom-textual-port
(fxior fast-put-tag fast-put-char-tag) textual-output-port-bits
256 256
id #f write! get-position id #f write! get-position
set-position! close 256)) set-position! close 256))
@ -281,23 +278,23 @@
(define (input-transcoder-attrs x) (define (input-transcoder-attrs x)
(cond (cond
[(not x) ;;; binary input port [(not x) ;;; binary input port
(fxior fast-get-tag fast-get-byte-tag)] binary-input-port-bits]
[(and (eq? 'latin-1-codec (transcoder-codec x)) [(and (eq? 'latin-1-codec (transcoder-codec x))
(eq? 'none (transcoder-eol-style x))) (eq? 'none (transcoder-eol-style x)))
(fxior fast-get-tag fast-get-latin-tag)] (fxior textual-input-port-bits fast-u8-text-tag)]
[else 0])) [else textual-input-port-bits]))
(define (output-transcoder-attrs x) (define (output-transcoder-attrs x)
(cond (cond
[(not x) ;;; binary input port [(not x) ;;; binary input port
(fxior fast-put-tag fast-put-byte-tag)] binary-output-port-bits]
[(and (eq? 'latin-1-codec (transcoder-codec x)) [(and (eq? 'latin-1-codec (transcoder-codec x))
(eq? 'none (transcoder-eol-style x))) (eq? 'none (transcoder-eol-style x)))
(fxior fast-put-tag fast-put-latin-tag)] (fxior textual-output-port-bits fast-u8-text-tag)]
[(and (eq? 'utf-8-codec (transcoder-codec x)) [(and (eq? 'utf-8-codec (transcoder-codec x))
(eq? 'none (transcoder-eol-style x))) (eq? 'none (transcoder-eol-style x)))
(fxior fast-put-tag fast-put-utf8-tag)] (fxior textual-output-port-bits fast-u7-text-tag)]
[else 0])) [else textual-output-port-bits]))
(define open-bytevector-input-port (define open-bytevector-input-port
(case-lambda (case-lambda
@ -396,7 +393,7 @@
($make-port 0 buffer-size (make-string buffer-size) 0 ($make-port 0 buffer-size (make-string buffer-size) 0
#t ;;; transcoder #t ;;; transcoder
#f #f
(fxior fast-put-tag fast-put-char-tag) (fxior textual-output-port-bits fast-char-text-tag)
"*string-output-port*" "*string-output-port*"
#f #f
(lambda (str i c) (lambda (str i c)
@ -435,7 +432,7 @@
($make-port 0 (string-length str) str 0 ($make-port 0 (string-length str) str 0
#t ;;; transcoder #t ;;; transcoder
#f ;;; closed? #f ;;; closed?
(fxior fast-get-tag fast-get-char-tag) (fxior textual-input-port-bits fast-char-text-tag)
"*string-input-port*" "*string-input-port*"
(lambda (str i c) 0) ;;; read! (lambda (str i c) 0) ;;; read!
#f ;;; write! #f ;;; write!
@ -839,7 +836,7 @@
[(utf-8-codec) [(utf-8-codec)
;;; ;;;
($set-port-attrs! p ($set-port-attrs! p
(fxior fast-get-tag fast-get-utf8-tag)) (fxior textual-input-port-bits fast-u7-text-tag))
(eof-object? (advance-bom p who '(#xEF #xBB #xBF)))] (eof-object? (advance-bom p who '(#xEF #xBB #xBF)))]
[else (error 'slow-get-char "codec not handled")]))) [else (error 'slow-get-char "codec not handled")])))
@ -861,7 +858,7 @@
;;; ;;;
(define (lookahead-char p) (define (lookahead-char p)
(define who 'lookahead-char) (define who 'lookahead-char)
(let ([m ($port-get-mode p)]) (let ([m ($port-fast-attrs p)])
(cond (cond
[(eq? m fast-get-utf8-tag) [(eq? m fast-get-utf8-tag)
(let ([i ($port-index p)]) (let ([i ($port-index p)])
@ -912,7 +909,7 @@
(define (get-char p) (define (get-char p)
(define who 'get-char) (define who 'get-char)
(let ([m ($port-get-mode p)]) (let ([m ($port-fast-attrs p)])
(cond (cond
[(eq? m fast-get-utf8-tag) [(eq? m fast-get-utf8-tag)
(let ([i ($port-index p)]) (let ([i ($port-index p)])
@ -975,12 +972,12 @@
(error who "read! returned a value out of range" j)])))) (error who "read! returned a value out of range" j)]))))
(define (slow-get-u8 p who start) (define (slow-get-u8 p who start)
(assert-binary-input-port p who) (assert-binary-input-port p who)
($set-port-attrs! p (fxior fast-get-tag fast-get-byte-tag)) ($set-port-attrs! p fast-get-byte-tag)
(get-u8-byte-mode p who start)) (get-u8-byte-mode p who start))
;;; ;;;
(define (get-u8 p) (define (get-u8 p)
(define who 'get-u8) (define who 'get-u8)
(let ([m ($port-get-mode p)]) (let ([m ($port-fast-attrs p)])
(cond (cond
[(eq? m fast-get-byte-tag) [(eq? m fast-get-byte-tag)
(let ([i ($port-index p)]) (let ([i ($port-index p)])
@ -992,7 +989,7 @@
[else (slow-get-u8 p who 1)]))) [else (slow-get-u8 p who 1)])))
(define (lookahead-u8 p) (define (lookahead-u8 p)
(define who 'lookahead-u8) (define who 'lookahead-u8)
(let ([m ($port-get-mode p)]) (let ([m ($port-fast-attrs p)])
(cond (cond
[(eq? m fast-get-byte-tag) [(eq? m fast-get-byte-tag)
(let ([i ($port-index p)]) (let ([i ($port-index p)])
@ -1004,7 +1001,7 @@
(define (port-eof? p) (define (port-eof? p)
(define who 'port-eof?) (define who 'port-eof?)
(let ([m ($port-get-mode p)]) (let ([m ($port-fast-attrs p)])
(cond (cond
[(not (eq? m 0)) [(not (eq? m 0))
(if (fx< ($port-index p) ($port-size p)) (if (fx< ($port-index p) ($port-size p))
@ -1623,7 +1620,7 @@
(f (fx+ i 1) n)))) (f (fx+ i 1) n))))
(define (do-put-char p c who) (define (do-put-char p c who)
(unless (char? c) (error who "not a char" c)) (unless (char? c) (error who "not a char" c))
(let ([m ($port-put-mode p)]) (let ([m ($port-fast-attrs p)])
(cond (cond
[(eq? m fast-put-utf8-tag) [(eq? m fast-put-utf8-tag)
(let ([i ($port-index p)]) (let ([i ($port-index p)])
@ -1698,7 +1695,7 @@
(define (put-u8 p b) (define (put-u8 p b)
(define who 'put-u8) (define who 'put-u8)
(unless (u8? b) (error who "not a u8" b)) (unless (u8? b) (error who "not a u8" b))
(let ([m ($port-put-mode p)]) (let ([m ($port-fast-attrs p)])
(cond (cond
[(eq? m fast-put-byte-tag) [(eq? m fast-put-byte-tag)
(let ([i ($port-index p)]) (let ([i ($port-index p)])

2
scheme/last-revision
View File

@ -1 +1 @@
1225 1227