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

* $port-output-index, $port-output-size, $set-port-output-index! and 

$set-port-output-size! are gone.
This commit is contained in:
Abdulaziz Ghuloum 2007-08-25 11:24:05 -04:00
parent 023d0831d7
commit d8b81869c9
8 changed files with 42 additions and 82 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.

7
src/ikarus.compiler.ss
View File

@ -1800,15 +1800,14 @@
(define port-tag #x3F) (define port-tag #x3F)
(define output-port-tag #x7F) (define output-port-tag #x7F)
(define input-port-tag #xBF) (define input-port-tag #xBF)
;(define input/output-port-tag #xFF)
(define port-mask #x3F) (define port-mask #x3F)
(define disp-port-buffer 4) (define disp-port-buffer 4)
(define disp-port-index 8) (define disp-port-index 8)
(define disp-port-size 12) (define disp-port-size 12)
(define disp-port-handler 16) (define disp-port-handler 16)
(define disp-port-output-buffer 20) (define disp-port-unused1 20)
(define disp-port-output-index 24) (define disp-port-unused2 24)
(define disp-port-output-size 28) (define disp-port-unused3 28)
(define port-size 32) (define port-size 32)

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

@ -55,7 +55,7 @@
;;; ;;;
(define $make-input-port (define $make-input-port
(lambda (handler buffer) (lambda (handler buffer)
($make-port/input handler buffer 0 ($bytevector-length buffer) #f 0 0))) ($make-port/input handler buffer 0 ($bytevector-length buffer))))
;;; ;;;
(define make-input-port (define make-input-port
(lambda (handler buffer) (lambda (handler buffer)
@ -67,7 +67,7 @@
;;; ;;;
(define $make-output-port (define $make-output-port
(lambda (handler buffer) (lambda (handler buffer)
($make-port/output handler #f 0 0 buffer 0 ($bytevector-length buffer)))) ($make-port/output handler buffer 0 ($bytevector-length buffer))))
;;; ;;;
(define make-output-port (define make-output-port
(lambda (handler buffer) (lambda (handler buffer)
@ -77,22 +77,6 @@
(error 'make-output-port "~s is not a bytevector" buffer)) (error 'make-output-port "~s is not a bytevector" buffer))
(error 'make-output-port "~s is not a procedure" handler)))) (error 'make-output-port "~s is not a procedure" handler))))
;;; ;;;
;(define $make-input/output-port
; (lambda (handler input-buffer output-buffer)
; ($make-port/both handler
; input-buffer 0 ($bytevector-length input-buffer)
; output-buffer 0 ($bytevector-length output-buffer))))
;;;
;(define make-input/output-port
; (lambda (handler input-buffer output-buffer)
; (if (procedure? handler)
; (if (bytevector? input-buffer)
; (if (bytevector? output-buffer)
; ($make-input/output-port handler input-buffer output-buffer)
; (error 'make-input/output-port "~s is not a bytevector" output-buffer))
; (error 'make-input/output-port "~s is not a bytevector" input-buffer))
; (error 'make-input/output-port "~s is not a procedure" handler))))
;;;
(define port-handler (define port-handler
(lambda (x) (lambda (x)
(if (port? x) (if (port? x)
@ -120,19 +104,19 @@
(define port-output-buffer (define port-output-buffer
(lambda (x) (lambda (x)
(if (output-port? x) (if (output-port? x)
($port-output-buffer x) ($port-buffer x)
(error 'port-output-buffer "~s is not an output-port" x)))) (error 'port-output-buffer "~s is not an output-port" x))))
;;; ;;;
(define port-output-index (define port-output-index
(lambda (x) (lambda (x)
(if (output-port? x) (if (output-port? x)
($port-output-index x) ($port-index x)
(error 'port-output-index "~s is not an output-port" x)))) (error 'port-output-index "~s is not an output-port" x))))
;;; ;;;
(define port-output-size (define port-output-size
(lambda (x) (lambda (x)
(if (output-port? x) (if (output-port? x)
($port-output-size x) ($port-size x)
(error 'port-output-size "~s is not an output-port" x)))) (error 'port-output-size "~s is not an output-port" x))))
;;; ;;;
(define set-port-input-index! (define set-port-input-index!
@ -166,8 +150,8 @@
(if (output-port? p) (if (output-port? p)
(if (fixnum? i) (if (fixnum? i)
(if ($fx>= i 0) (if ($fx>= i 0)
(if ($fx<= i ($port-output-size p)) (if ($fx<= i ($port-size p))
($set-port-output-index! p i) ($set-port-index! p i)
(error 'set-port-output-index! "index ~s is too big" i)) (error 'set-port-output-index! "index ~s is too big" i))
(error 'set-port-output-index! "index ~s is negative" i)) (error 'set-port-output-index! "index ~s is negative" i))
(error 'set-port-output-index! "~s is not a valid index" i)) (error 'set-port-output-index! "~s is not a valid index" i))
@ -178,10 +162,10 @@
(if (output-port? p) (if (output-port? p)
(if (fixnum? i) (if (fixnum? i)
(if ($fx>= i 0) (if ($fx>= i 0)
(if ($fx<= i ($bytevector-length ($port-output-buffer p))) (if ($fx<= i ($bytevector-length ($port-buffer p)))
(begin (begin
($set-port-output-index! p 0) ($set-port-index! p 0)
($set-port-output-size! p i)) ($set-port-size! p i))
(error 'set-port-output-size! "size ~s is too big" i)) (error 'set-port-output-size! "size ~s is too big" i))
(error 'set-port-output-size! "size ~s is negative" i)) (error 'set-port-output-size! "size ~s is negative" i))
(error 'set-port-output-size! "~s is not a valid size" i)) (error 'set-port-output-size! "~s is not a valid size" i))

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

@ -42,10 +42,10 @@
(define $write-byte (define $write-byte
(lambda (b p) (lambda (b p)
(let ([idx (port-output-index p)]) (let ([idx (port-output-index p)])
(if ($fx< idx ($port-output-size p)) (if ($fx< idx ($port-size p))
(begin (begin
($bytevector-set! ($port-output-buffer p) idx b) ($bytevector-set! ($port-buffer p) idx b)
($set-port-output-index! p ($fxadd1 idx))) ($set-port-index! p ($fxadd1 idx)))
(($port-handler p) 'write-byte b p))))) (($port-handler p) 'write-byte b p)))))
(define $read-char (define $read-char

20
src/ikarus.io.output-files.ss
View File

@ -76,15 +76,15 @@
[(write-byte b p) [(write-byte b p)
(if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255)) (if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
(if (output-port? p) (if (output-port? p)
(let ([idx ($port-output-index p)]) (let ([idx ($port-index p)])
(if ($fx< idx ($port-output-size p)) (if ($fx< idx ($port-size p))
(begin (begin
($bytevector-set! ($port-output-buffer p) idx b) ($bytevector-set! ($port-buffer p) idx b)
($set-port-output-index! p ($fxadd1 idx))) ($set-port-index! p ($fxadd1 idx)))
(if open? (if open?
(let ([bytes (do-write-buffer fd port-name (let ([bytes (do-write-buffer fd port-name
($port-output-buffer p) idx 'write-char)]) ($port-buffer p) idx 'write-char)])
($set-port-output-index! p 0) ($set-port-index! p 0)
($write-byte b p)) ($write-byte b p))
(error 'write-byte "port ~s is closed" p)))) (error 'write-byte "port ~s is closed" p))))
(error 'write-byte "~s is not an output-port" p)) (error 'write-byte "~s is not an output-port" p))
@ -102,16 +102,16 @@
(if (output-port? p) (if (output-port? p)
(if open? (if open?
(let ([bytes (do-write-buffer fd port-name (let ([bytes (do-write-buffer fd port-name
($port-output-buffer p) ($port-buffer p)
($port-output-index p) ($port-index p)
'flush-output-port)]) 'flush-output-port)])
($set-port-output-index! p 0)) ($set-port-index! p 0))
(error 'flush-output-port "port ~s is closed" p)) (error 'flush-output-port "port ~s is closed" p))
(error 'flush-output-port "~s is not an output-port" p))] (error 'flush-output-port "~s is not an output-port" p))]
[(close-port p) [(close-port p)
(when open? (when open?
(flush-output-port p) (flush-output-port p)
($set-port-output-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-output-port "cannot close ~s" port-name)))] (error 'close-output-port "cannot close ~s" port-name)))]

16
src/ikarus.io.output-strings.ss
View File

@ -112,16 +112,16 @@
[(write-byte b p) [(write-byte b p)
(if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255)) (if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
(if (output-port? p) (if (output-port? p)
(let ([idx ($port-output-index p)]) (let ([idx ($port-index p)])
(if ($fx< idx ($port-output-size p)) (if ($fx< idx ($port-size p))
(begin (begin
($bytevector-set! ($port-output-buffer p) idx b) ($bytevector-set! ($port-buffer p) idx b)
($set-port-output-index! p ($fxadd1 idx))) ($set-port-index! p ($fxadd1 idx)))
(if open? (if open?
(let ([buff ($port-output-buffer p)]) (let ([buff ($port-buffer p)])
(set! buffer-list (cons (bv-copy buff) buffer-list)) (set! buffer-list (cons (bv-copy buff) buffer-list))
($bytevector-set! buff 0 b) ($bytevector-set! buff 0 b)
($set-port-output-index! p 1)) ($set-port-index! p 1))
(error 'write-byte "port ~s is closed" p)))) (error 'write-byte "port ~s is closed" p))))
(error 'write-byte "~s is not an output-port" p)) (error 'write-byte "~s is not an output-port" p))
(error 'write-byte "~s is not a byte" b))] (error 'write-byte "~s is not a byte" b))]
@ -142,8 +142,8 @@
[(get-output-string p) [(get-output-string p)
(utf8-bytevector->string (utf8-bytevector->string
(concat (concat
($port-output-buffer p) ($port-buffer p)
($port-output-index p) ($port-index p)
buffer-list))] buffer-list))]
[else (error 'output-handler [else (error 'output-handler
"unhandled message ~s" (cons msg args))]))) "unhandled message ~s" (cons msg args))])))

7
src/makefile.ss
View File

@ -699,13 +699,6 @@
[$set-port-index! $ports] [$set-port-index! $ports]
[$set-port-size! $ports] [$set-port-size! $ports]
[$port-output-buffer $ports]
[$port-output-index $ports]
[$port-output-size $ports]
[$set-port-output-index! $ports]
[$set-port-output-size! $ports]
[$closure-code $codes] [$closure-code $codes]
[$code->closure $codes] [$code->closure $codes]
[$code-reloc-vector $codes] [$code-reloc-vector $codes]

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

@ -1421,27 +1421,25 @@
[(P x) (sec-tag-test (T x) vector-mask vector-tag #f output-port-tag)] [(P x) (sec-tag-test (T x) vector-mask vector-tag #f output-port-tag)]
[(E x) (nop)]) [(E x) (nop)])
(define (make-port handler buf/i idx/i sz/i buf/o idx/o sz/o tag) (define (make-port handler buf/i idx/i sz/i tag)
(with-tmp ([p (prm 'alloc (K (align port-size)) (K vector-tag))]) (with-tmp ([p (prm 'alloc (K (align port-size)) (K vector-tag))])
(prm 'mset p (K (- vector-tag)) (K tag)) (prm 'mset p (K (- vector-tag)) (K tag))
(prm 'mset p (K (- disp-port-buffer vector-tag)) (T buf/i)) (prm 'mset p (K (- disp-port-buffer vector-tag)) (T buf/i))
(prm 'mset p (K (- disp-port-index vector-tag)) (T idx/i)) (prm 'mset p (K (- disp-port-index vector-tag)) (T idx/i))
(prm 'mset p (K (- disp-port-size vector-tag)) (T sz/i)) (prm 'mset p (K (- disp-port-size vector-tag)) (T sz/i))
(prm 'mset p (K (- disp-port-handler vector-tag)) (T handler)) (prm 'mset p (K (- disp-port-handler vector-tag)) (T handler))
(prm 'mset p (K (- disp-port-output-buffer vector-tag)) (T buf/o)) (prm 'mset p (K (- disp-port-unused1 vector-tag)) (K 0))
(prm 'mset p (K (- disp-port-output-index vector-tag)) (T idx/o)) (prm 'mset p (K (- disp-port-unused2 vector-tag)) (K 0))
(prm 'mset p (K (- disp-port-output-size vector-tag)) (T sz/o)) (prm 'mset p (K (- disp-port-unused3 vector-tag)) (K 0))
p)) p))
(define-primop $make-port/input unsafe (define-primop $make-port/input unsafe
[(V handler buf/i idx/i sz/i buf/o idx/o sz/o) [(V handler buf/i idx/i sz/i)
(make-port handler buf/i idx/i sz/i buf/o idx/o sz/o (make-port handler buf/i idx/i sz/i input-port-tag)])
input-port-tag)])
(define-primop $make-port/output unsafe (define-primop $make-port/output unsafe
[(V handler buf/i idx/i sz/i buf/o idx/o sz/o) [(V handler buf/o idx/o sz/o)
(make-port handler buf/i idx/i sz/i buf/o idx/o sz/o (make-port handler buf/o idx/o sz/o output-port-tag)])
output-port-tag)])
(define-primop $port-handler unsafe (define-primop $port-handler unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-handler vector-tag)))]) [(V x) (prm 'mref (T x) (K (- disp-port-handler vector-tag)))])
@ -1459,20 +1457,6 @@
(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-output-buffer unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-output-buffer vector-tag)))])
(define-primop $port-output-index unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-output-index vector-tag)))])
(define-primop $port-output-size unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-output-size vector-tag)))])
(define-primop $set-port-output-index! unsafe
[(E x i) (prm 'mset (T x) (K (- disp-port-output-index vector-tag)) (T i))])
(define-primop $set-port-output-size! unsafe
[(E x i)
(seq*
(prm 'mset (T x) (K (- disp-port-output-index vector-tag)) (K 0))
(prm 'mset (T x) (K (- disp-port-output-size vector-tag)) (T i)))])
/section) /section)
(section ;;; interrupts-and-engines (section ;;; interrupts-and-engines