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

* Removed $port-input-index, $port-input-size, 

$set-port-input-index! and $set-port-input-size!
This commit is contained in:
Abdulaziz Ghuloum 2007-08-25 11:06:30 -04:00
parent c5530973d0
commit 023d0831d7
6 changed files with 38 additions and 56 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.

16
src/ikarus.io-ports.ss
View File

@ -102,19 +102,19 @@
(define port-input-buffer (define port-input-buffer
(lambda (x) (lambda (x)
(if (input-port? x) (if (input-port? x)
($port-input-buffer x) ($port-buffer x)
(error 'port-input-buffer "~s is not an input-port" x)))) (error 'port-input-buffer "~s is not an input-port" x))))
;;; ;;;
(define port-input-index (define port-input-index
(lambda (x) (lambda (x)
(if (input-port? x) (if (input-port? x)
($port-input-index x) ($port-index x)
(error 'port-input-index "~s is not an input-port" x)))) (error 'port-input-index "~s is not an input-port" x))))
;;; ;;;
(define port-input-size (define port-input-size
(lambda (x) (lambda (x)
(if (input-port? x) (if (input-port? x)
($port-input-size x) ($port-size x)
(error 'port-input-size "~s is not an input-port" x)))) (error 'port-input-size "~s is not an input-port" x))))
;;; ;;;
(define port-output-buffer (define port-output-buffer
@ -140,8 +140,8 @@
(if (input-port? p) (if (input-port? p)
(if (fixnum? i) (if (fixnum? i)
(if ($fx>= i 0) (if ($fx>= i 0)
(if ($fx<= i ($port-input-size p)) (if ($fx<= i ($port-size p))
($set-port-input-index! p i) ($set-port-index! p i)
(error 'set-port-input-index! "index ~s is too big" i)) (error 'set-port-input-index! "index ~s is too big" i))
(error 'set-port-input-index! "index ~s is negative" i)) (error 'set-port-input-index! "index ~s is negative" i))
(error 'set-port-input-index! "~s is not a valid index" i)) (error 'set-port-input-index! "~s is not a valid index" i))
@ -152,10 +152,10 @@
(if (input-port? p) (if (input-port? p)
(if (fixnum? i) (if (fixnum? i)
(if ($fx>= i 0) (if ($fx>= i 0)
(if ($fx<= i ($bytevector-length ($port-input-buffer p))) (if ($fx<= i ($bytevector-length ($port-buffer p)))
(begin (begin
($set-port-input-index! p 0) ($set-port-index! p 0)
($set-port-input-size! p i)) ($set-port-size! p i))
(error 'set-port-input-size! "size ~s is too big" i)) (error 'set-port-input-size! "size ~s is too big" i))
(error 'set-port-input-size! "size ~s is negative" i)) (error 'set-port-input-size! "size ~s is negative" i))
(error 'set-port-input-size! "~s is not a valid size" i)) (error 'set-port-input-size! "~s is not a valid size" i))

24
src/ikarus.io-primitives.unsafe.ss
View File

@ -50,21 +50,21 @@
(define $read-char (define $read-char
(lambda (p) (lambda (p)
(let ([idx ($port-input-index p)]) (let ([idx ($port-index p)])
(if ($fx< idx ($port-input-size p)) (if ($fx< idx ($port-size p))
(let ([b ($bytevector-u8-ref ($port-input-buffer p) idx)]) (let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
(cond (cond
[($fx<= b 127) [($fx<= b 127)
($set-port-input-index! p ($fxadd1 idx)) ($set-port-index! p ($fxadd1 idx))
($fixnum->char b)] ($fixnum->char b)]
[else (($port-handler p) 'read-char p)])) [else (($port-handler p) 'read-char p)]))
(($port-handler p) 'read-char p))))) (($port-handler p) 'read-char p)))))
(define $peek-char (define $peek-char
(lambda (p) (lambda (p)
(let ([idx ($port-input-index p)]) (let ([idx ($port-index p)])
(if ($fx< idx ($port-input-size p)) (if ($fx< idx ($port-size p))
(let ([b ($bytevector-u8-ref ($port-input-buffer p) idx)]) (let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
(cond (cond
[($fx<= b 127) [($fx<= b 127)
($fixnum->char b)] ($fixnum->char b)]
@ -73,19 +73,19 @@
(define $unread-char (define $unread-char
(lambda (c p) (lambda (c p)
(let ([idx ($fxsub1 ($port-input-index p))] (let ([idx ($fxsub1 ($port-index p))]
[b ($char->fixnum c)]) [b ($char->fixnum c)])
(if (and ($fx<= b 127) (if (and ($fx<= b 127)
($fx>= idx 0) ($fx>= idx 0)
($fx< idx ($port-input-size p))) ($fx< idx ($port-size p)))
(begin (begin
($set-port-input-index! p idx) ($set-port-index! p idx)
($bytevector-set! ($port-input-buffer p) idx b)) ($bytevector-set! ($port-buffer p) idx b))
(($port-handler p) 'unread-char c p))))) (($port-handler p) 'unread-char c p)))))
(define $reset-input-port! (define $reset-input-port!
(lambda (p) (lambda (p)
($set-port-input-size! p 0))) ($set-port-size! p 0)))
(define $close-input-port (define $close-input-port
(lambda (p) (lambda (p)

36
src/ikarus.io.input-files.ss
View File

@ -52,19 +52,19 @@
(define read-multibyte-char (define read-multibyte-char
(lambda (p b0) (lambda (p b0)
(let ([idx ($port-input-index p)] (let ([idx ($port-index p)]
[size ($port-input-size p)]) [size ($port-size p)])
(cond (cond
[($fx= ($fxlogand b0 #b11100000) #b11000000) [($fx= ($fxlogand b0 #b11100000) #b11000000)
;;; 2-byte utf8 sequence ;;; 2-byte utf8 sequence
(unless ($fx< ($fx+ idx 1) size) (unless ($fx< ($fx+ idx 1) size)
(refill-buffer! p 1)) (refill-buffer! p 1))
(let ([b1 ($bytevector-u8-ref (let ([b1 ($bytevector-u8-ref
($port-input-buffer p) ($port-buffer p)
($fxadd1 idx))]) ($fxadd1 idx))])
(unless ($fx= ($fxlogand b1 #b11000000) #b10000000) (unless ($fx= ($fxlogand b1 #b11000000) #b10000000)
(error 'read-char "invalid utf8 sequence ~a ~a" b0 b1)) (error 'read-char "invalid utf8 sequence ~a ~a" b0 b1))
($set-port-input-index! p ($fx+ idx 2)) ($set-port-index! p ($fx+ idx 2))
($fixnum->char ($fixnum->char
($fx+ ($fxsll ($fxlogand b0 #b11111) 6) ($fx+ ($fxsll ($fxlogand b0 #b11111) 6)
($fxlogand b1 #b111111))))] ($fxlogand b1 #b111111))))]
@ -87,21 +87,21 @@
[(read-char p) [(read-char p)
(unless (input-port? p) (unless (input-port? p)
(error 'read-char "~s is not an input port" p)) (error 'read-char "~s is not an input port" p))
(let ([idx ($port-input-index p)]) (let ([idx ($port-index p)])
(if ($fx< idx ($port-input-size p)) (if ($fx< idx ($port-size p))
(let ([b ($bytevector-u8-ref ($port-input-buffer p) idx)]) (let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
(cond (cond
[($fx< b 128) [($fx< b 128)
($set-port-input-index! p ($fxadd1 idx)) ($set-port-index! p ($fxadd1 idx))
($fixnum->char b)] ($fixnum->char b)]
[else (read-multibyte-char p b)])) [else (read-multibyte-char p b)]))
(if open? (if open?
(let ([bytes (let ([bytes
(foreign-call "ikrt_read" (foreign-call "ikrt_read"
fd ($port-input-buffer p))]) fd ($port-buffer p))])
(cond (cond
[($fx> bytes 0) [($fx> bytes 0)
($set-port-input-size! p bytes) ($set-port-size! p bytes)
($read-char p)] ($read-char p)]
[($fx= bytes 0) [($fx= bytes 0)
(eof-object)] (eof-object)]
@ -112,9 +112,9 @@
[(peek-char p) [(peek-char p)
(unless (input-port? p) (unless (input-port? p)
(error 'peek-char "~s is not an input port" p)) (error 'peek-char "~s is not an input port" p))
(let ([idx ($port-input-index p)]) (let ([idx ($port-index p)])
(if ($fx< idx ($port-input-size p)) (if ($fx< idx ($port-size p))
(let ([b ($bytevector-u8-ref ($port-input-buffer p) idx)]) (let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
(cond (cond
[($fx< b 128) ($fixnum->char b)] [($fx< b 128) ($fixnum->char b)]
[else (peek-multibyte-char p)])) [else (peek-multibyte-char p)]))
@ -129,21 +129,21 @@
[($fx= bytes 0) [($fx= bytes 0)
(eof-object)] (eof-object)]
[else [else
($set-port-input-size! p bytes) ($set-port-size! p bytes)
($peek-char p)])) ($peek-char p)]))
(error 'peek-char "port ~s is closed" p))))] (error 'peek-char "port ~s is closed" p))))]
[(unread-char c p) [(unread-char c p)
(unless (input-port? p) (unless (input-port? p)
(error 'unread-char "~s is not an input port" p)) (error 'unread-char "~s is not an input port" p))
(let ([idx ($fxsub1 ($port-input-index p))] (let ([idx ($fxsub1 ($port-index p))]
[b (if (char? c) [b (if (char? c)
($char->fixnum c) ($char->fixnum c)
(error 'unread-char "~s is not a char" c))]) (error 'unread-char "~s is not a char" c))])
(if (and ($fx>= idx 0) (if (and ($fx>= idx 0)
($fx< idx ($port-input-size p))) ($fx< idx ($port-size p)))
(cond (cond
[($fx< b 128) [($fx< b 128)
($set-port-input-index! p idx)] ($set-port-index! p idx)]
[else (unread-multibyte-char c p)]) [else (unread-multibyte-char c p)])
(if open? (if open?
(error 'unread-char "port ~s is closed" p) (error 'unread-char "port ~s is closed" p)
@ -153,7 +153,7 @@
(unless (input-port? p) (unless (input-port? p)
(error 'close-input-port "~s is not an input port" p)) (error 'close-input-port "~s is not an input port" p))
(when open? (when open?
($set-port-input-size! p 0) ($set-port-size! p 0)
(set! open? #f) (set! open? #f)
(unless (foreign-call "ikrt_close_file" fd) (unless (foreign-call "ikrt_close_file" fd)
(error 'close-input-port "cannot close ~s" port-name)))] (error 'close-input-port "cannot close ~s" port-name)))]

5
src/makefile.ss
View File

@ -699,14 +699,9 @@
[$set-port-index! $ports] [$set-port-index! $ports]
[$set-port-size! $ports] [$set-port-size! $ports]
[$port-input-buffer $ports]
[$port-input-index $ports]
[$port-input-size $ports]
[$port-output-buffer $ports] [$port-output-buffer $ports]
[$port-output-index $ports] [$port-output-index $ports]
[$port-output-size $ports] [$port-output-size $ports]
[$set-port-input-index! $ports]
[$set-port-input-size! $ports]
[$set-port-output-index! $ports] [$set-port-output-index! $ports]
[$set-port-output-size! $ports] [$set-port-output-size! $ports]

13
src/pass-specify-rep-primops.ss
View File

@ -1459,27 +1459,14 @@
(prm 'mset (T x) (K (- disp-port-index vector-tag)) (K 0)) (prm 'mset (T x) (K (- disp-port-index vector-tag)) (K 0))
(prm 'mset (T x) (K (- disp-port-size vector-tag)) (T i)))]) (prm 'mset (T x) (K (- disp-port-size vector-tag)) (T i)))])
(define-primop $port-input-buffer unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-buffer vector-tag)))])
(define-primop $port-input-index unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-index vector-tag)))])
(define-primop $port-input-size unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-size vector-tag)))])
(define-primop $port-output-buffer unsafe (define-primop $port-output-buffer unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-output-buffer vector-tag)))]) [(V x) (prm 'mref (T x) (K (- disp-port-output-buffer vector-tag)))])
(define-primop $port-output-index unsafe (define-primop $port-output-index unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-output-index vector-tag)))]) [(V x) (prm 'mref (T x) (K (- disp-port-output-index vector-tag)))])
(define-primop $port-output-size unsafe (define-primop $port-output-size unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-output-size vector-tag)))]) [(V x) (prm 'mref (T x) (K (- disp-port-output-size vector-tag)))])
(define-primop $set-port-input-index! unsafe
[(E x i) (prm 'mset (T x) (K (- disp-port-index vector-tag)) (T i))])
(define-primop $set-port-output-index! unsafe (define-primop $set-port-output-index! unsafe
[(E x i) (prm 'mset (T x) (K (- disp-port-output-index vector-tag)) (T i))]) [(E x i) (prm 'mset (T x) (K (- disp-port-output-index vector-tag)) (T i))])
(define-primop $set-port-input-size! unsafe
[(E x i)
(seq*
(prm 'mset (T x) (K (- disp-port-index vector-tag)) (K 0))
(prm 'mset (T x) (K (- disp-port-size vector-tag)) (T i)))])
(define-primop $set-port-output-size! unsafe (define-primop $set-port-output-size! unsafe
[(E x i) [(E x i)
(seq* (seq*