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

moved port position into cookie instead of being its own vector.

This commit is contained in:
Abdulaziz Ghuloum 2009-05-30 13:34:18 +03:00
parent 3099d1d629
commit 5f4151a2e9
5 changed files with 50 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
scheme/ikarus.compiler.ss
View File

@ -2011,8 +2011,8 @@
(define disp-port-set-position! (* 9 wordsize)) (define disp-port-set-position! (* 9 wordsize))
(define disp-port-close (* 10 wordsize)) (define disp-port-close (* 10 wordsize))
(define disp-port-cookie (* 11 wordsize)) (define disp-port-cookie (* 11 wordsize))
(define disp-port-position (* 12 wordsize)) (define disp-port-unused1 (* 12 wordsize))
(define disp-port-unused (* 13 wordsize)) (define disp-port-unused2 (* 13 wordsize))
(define port-size (* 14 wordsize)) (define port-size (* 14 wordsize))
(define disp-tcbucket-tconc 0) (define disp-tcbucket-tconc 0)

66
scheme/ikarus.io.ss
View File

@ -256,10 +256,9 @@
(import (ikarus system $fx)) (import (ikarus system $fx))
($fxlogand ($port-tag x) fast-attrs-mask)))) ($fxlogand ($port-tag x) fast-attrs-mask))))
(define-struct cookie (dest mode pos reader))
(define-struct cookie (dest mode reader)) (define (default-cookie fd) (make-cookie fd 'ikarus-mode 0 #f))
(define (default-cookie fd) (make-cookie fd 'ikarus-mode #f))
(define (port-id p) (define (port-id p)
(if (port? p) (if (port? p)
@ -268,14 +267,14 @@
(define (input-port-byte-position p) (define (input-port-byte-position p)
(if (input-port? p) (if (input-port? p)
(let ([pos-vec ($port-position p)]) (let ([cookie ($port-cookie p)])
(+ (vector-ref pos-vec 0) (fx+ ($port-index p) 1))) (+ (cookie-pos cookie) (fx+ ($port-index p) 1)))
(error 'input-port-byte-position "not an input port" p))) (error 'input-port-byte-position "not an input port" p)))
(define (port-position p) (define (port-position p)
(define who 'port-position) (define who 'port-position)
(if (port? p) (if (port? p)
(let ([pos-vec ($port-position p)] (let ([cookie ($port-cookie p)]
[index ($port-index p)] [index ($port-index p)]
[get-position ($port-get-position p)]) [get-position ($port-get-position p)])
(cond (cond
@ -287,7 +286,7 @@
(+ pos index)) (+ pos index))
(die who "invalid returned value from get-position" p)))] (die who "invalid returned value from get-position" p)))]
[(eqv? get-position #t) [(eqv? get-position #t)
(+ (vector-ref pos-vec 0) index)] (+ (cookie-pos cookie) index)]
[else [else
(die who "port does not support port-position operation" p)])) (die who "port does not support port-position operation" p)]))
(die who "not a port" p))) (die who "not a port" p)))
@ -303,8 +302,8 @@
(setpos! pos) (setpos! pos)
($set-port-index! p 0) ($set-port-index! p 0)
($set-port-size! p 0) ($set-port-size! p 0)
(let ([pos-vec ($port-position p)]) (let ([cookie ($port-cookie p)])
(vector-set! pos-vec 0 pos))] (set-cookie-pos! cookie pos))]
[(eqv? setpos! #t) [(eqv? setpos! #t)
(if (<= pos ($port-size p)) (if (<= pos ($port-size p))
($set-port-index! p pos) ($set-port-index! p pos)
@ -350,14 +349,14 @@
(let ([bv (make-bytevector buffer-size)]) (let ([bv (make-bytevector buffer-size)])
($make-port attrs 0 init-size bv #f id read! write! ($make-port attrs 0 init-size bv #f id read! write!
get-position set-position! close get-position set-position! close
(default-cookie #f) (vector 0)))) (default-cookie #f))))
(define ($make-custom-textual-port attrs init-size id (define ($make-custom-textual-port attrs init-size id
read! write! get-position set-position! close buffer-size) read! write! get-position set-position! close buffer-size)
(let ([bv (make-string buffer-size)]) (let ([bv (make-string buffer-size)])
($make-port attrs 0 init-size bv #t id read! write! ($make-port attrs 0 init-size bv #t id read! write!
get-position set-position! close get-position set-position! close
(default-cookie #f) (vector 0)))) (default-cookie #f))))
(define (make-custom-binary-input-port id (define (make-custom-binary-input-port id
read! get-position set-position! close) read! get-position set-position! close)
@ -495,8 +494,7 @@
#t ;;; get-position #t ;;; get-position
#t ;;; set-position! #t ;;; set-position!
#f ;;; close #f ;;; close
(default-cookie #f) (default-cookie #f))]))
(vector 0))]))
(define open-bytevector-output-port (define open-bytevector-output-port
(case-lambda (case-lambda
@ -523,8 +521,7 @@
#t ;;; get-position #t ;;; get-position
#f ;;; set-position! #f ;;; set-position!
#f ;;; close #f ;;; close
(default-cookie #f) ;;; cookie (default-cookie #f))])
(vector 0))])
(values (values
p p
(lambda () (lambda ()
@ -606,8 +603,7 @@
#t ;;; get-position #t ;;; get-position
#f ;;; set-position! #f ;;; set-position!
#f ;;; close! #f ;;; close!
cookie cookie)))
(vector 0))))
(define (open-string-output-port) (define (open-string-output-port)
(let ([p (open-output-string)]) (let ([p (open-output-string)])
@ -663,8 +659,7 @@
#t ;;; get-position #t ;;; get-position
#t ;;; set-position! #t ;;; set-position!
#f ;;; close #f ;;; close
(default-cookie #f) ;;; cookie (default-cookie #f)))
(vector 0)))
(define (open-string-input-port str) (define (open-string-input-port str)
(open-string-input-port/id str "*string-input-port*")) (open-string-input-port/id str "*string-input-port*"))
@ -699,8 +694,7 @@
($port-get-position p) ($port-get-position p)
($port-set-position! p) ($port-set-position! p)
($port-close p) ($port-close p)
($port-cookie p) ($port-cookie p)))))
(vector 0)))))
(define (reset-input-port! p) (define (reset-input-port! p)
(if (input-port? p) (if (input-port? p)
@ -757,8 +751,8 @@
(let ([bytes (($port-write! p) bv 0 1)]) (let ([bytes (($port-write! p) bv 0 1)])
(cond (cond
[(eq? bytes 1) [(eq? bytes 1)
(let ([pos-vec ($port-position p)]) (let ([cookie ($port-cookie p)])
(vector-set! pos-vec 0 (+ (vector-ref pos-vec 0) 1)))] (set-cookie-pos! cookie (+ (cookie-pos cookie) 1)))]
[(eq? bytes 0) [(eq? bytes 0)
($mark-port-closed! p) ($mark-port-closed! p)
(die who "could not write bytes to sink")] (die who "could not write bytes to sink")]
@ -771,8 +765,8 @@
(let ([bytes (($port-write! p) str 0 1)]) (let ([bytes (($port-write! p) str 0 1)])
(cond (cond
[(eq? bytes 1) [(eq? bytes 1)
(let ([pos-vec ($port-position p)]) (let ([cookie ($port-cookie p)])
(vector-set! pos-vec 0 (+ (vector-ref pos-vec 0) 1)))] (set-cookie-pos! cookie (+ (cookie-pos cookie) 1)))]
[(eq? bytes 0) [(eq? bytes 0)
($mark-port-closed! p) ($mark-port-closed! p)
(die who "could not write char to sink")] (die who "could not write char to sink")]
@ -796,8 +790,8 @@
(die 'flush-output-port (die 'flush-output-port
"write! returned an invalid value" "write! returned an invalid value"
bytes)) bytes))
(let ([pos-vec ($port-position p)]) (let ([cookie ($port-cookie p)])
(vector-set! pos-vec 0 (+ (vector-ref pos-vec 0) bytes))) (set-cookie-pos! cookie (+ (cookie-pos cookie) bytes)))
(cond (cond
[(fx= bytes idx) [(fx= bytes idx)
($set-port-index! p 0)] ($set-port-index! p 0)]
@ -840,8 +834,8 @@
(let ([bv ($port-buffer p)] [i ($port-index p)] [j ($port-size p)]) (let ([bv ($port-buffer p)] [i ($port-index p)] [j ($port-size p)])
(let ([c0 (fx- j i)]) (let ([c0 (fx- j i)])
(unless (fx= c0 0) (bytevector-copy! bv i bv 0 c0)) (unless (fx= c0 0) (bytevector-copy! bv i bv 0 c0))
(let ([pos-vec ($port-position p)]) (let ([cookie ($port-cookie p)])
(vector-set! pos-vec 0 (+ (vector-ref pos-vec 0) i))) (set-cookie-pos! cookie (+ (cookie-pos cookie) i)))
(let* ([max (fx- (bytevector-length bv) c0)] (let* ([max (fx- (bytevector-length bv) c0)]
[c1 (($port-read! p) bv c0 max)]) [c1 (($port-read! p) bv c0 max)])
(unless (fixnum? c1) (unless (fixnum? c1)
@ -1128,8 +1122,8 @@
(die who "invalid return value from read!" n)) (die who "invalid return value from read!" n))
(unless (<= 0 n (string-length str)) (unless (<= 0 n (string-length str))
(die who "return value from read! is out of range" n)) (die who "return value from read! is out of range" n))
(let ([idx ($port-index p)] [pos-vec ($port-position p)]) (let ([idx ($port-index p)] [cookie ($port-cookie p)])
(vector-set! pos-vec 0 (+ idx (vector-ref pos-vec 0)))) (set-cookie-pos! cookie (+ idx (cookie-pos cookie))))
($set-port-index! p 0) ($set-port-index! p 0)
($set-port-size! p n) ($set-port-size! p n)
(cond (cond
@ -1182,8 +1176,8 @@
(die who "invalid return value from read!" n)) (die who "invalid return value from read!" n))
(unless (<= 0 n (string-length str)) (unless (<= 0 n (string-length str))
(die who "return value from read! is out of range" n)) (die who "return value from read! is out of range" n))
(let ([idx ($port-index p)] [pos-vec ($port-position p)]) (let ([idx ($port-index p)] [cookie ($port-cookie p)])
(vector-set! pos-vec 0 (+ idx (vector-ref pos-vec 0)))) (set-cookie-pos! cookie (+ idx (cookie-pos cookie))))
($set-port-size! p n) ($set-port-size! p n)
(cond (cond
[(fx= n 0) [(fx= n 0)
@ -1503,8 +1497,7 @@
[(procedure? close) close] [(procedure? close) close]
[(eqv? close #t) (file-close-proc id fd)] [(eqv? close #t) (file-close-proc id fd)]
[else #f]) [else #f])
(default-cookie fd) (default-cookie fd))])
(vector 0))])
(guarded-port port))) (guarded-port port)))
@ -1543,8 +1536,7 @@
[(procedure? close) close] [(procedure? close) close]
[(eqv? close #t) (file-close-proc id fd)] [(eqv? close #t) (file-close-proc id fd)]
[else #f]) [else #f])
(default-cookie fd) (default-cookie fd))])
(vector 0))])
(guarded-port port))) (guarded-port port)))
(define (file-close-proc id fd) (define (file-close-proc id fd)

2
scheme/last-revision
View File

@ -1 +1 @@
1802 1803

2
scheme/makefile.ss
View File

@ -1420,8 +1420,6 @@
[$set-port-size! $io] [$set-port-size! $io]
[$port-attrs $io] [$port-attrs $io]
[$set-port-attrs! $io] [$set-port-attrs! $io]
[$port-position $io]
[$set-port-position! $io]
;;; ;;;
[&condition-rtd] [&condition-rtd]
[&condition-rcd] [&condition-rcd]

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

@ -2249,25 +2249,24 @@
(define port-attrs-shift 6) (define port-attrs-shift 6)
(define-primop $make-port unsafe (define-primop $make-port unsafe
[(V attrs idx sz buf tr id read write getp setp cl cookie pos) [(V attrs idx sz buf tr id read write getp setp cl cookie)
(with-tmp ([pos (T pos)]) (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))
(prm 'mset p (K (- vector-tag)) (prm 'logor (prm 'sll (T attrs) (K port-attrs-shift)) (K port-tag)))
(prm 'logor (prm 'sll (T attrs) (K port-attrs-shift)) (K port-tag))) (prm 'mset p (K (- disp-port-index vector-tag)) (T idx))
(prm 'mset p (K (- disp-port-index vector-tag)) (T idx)) (prm 'mset p (K (- disp-port-size vector-tag)) (T sz))
(prm 'mset p (K (- disp-port-size vector-tag)) (T sz)) (prm 'mset p (K (- disp-port-buffer vector-tag)) (T buf))
(prm 'mset p (K (- disp-port-buffer vector-tag)) (T buf)) (prm 'mset p (K (- disp-port-transcoder vector-tag)) (T tr))
(prm 'mset p (K (- disp-port-transcoder vector-tag)) (T tr)) (prm 'mset p (K (- disp-port-id vector-tag)) (T id))
(prm 'mset p (K (- disp-port-id vector-tag)) (T id)) (prm 'mset p (K (- disp-port-read! vector-tag)) (T read))
(prm 'mset p (K (- disp-port-read! vector-tag)) (T read)) (prm 'mset p (K (- disp-port-write! vector-tag)) (T write))
(prm 'mset p (K (- disp-port-write! vector-tag)) (T write)) (prm 'mset p (K (- disp-port-get-position vector-tag)) (T getp))
(prm 'mset p (K (- disp-port-get-position vector-tag)) (T getp)) (prm 'mset p (K (- disp-port-set-position! vector-tag)) (T setp))
(prm 'mset p (K (- disp-port-set-position! vector-tag)) (T setp)) (prm 'mset p (K (- disp-port-close vector-tag)) (T cl))
(prm 'mset p (K (- disp-port-close vector-tag)) (T cl)) (prm 'mset p (K (- disp-port-cookie vector-tag)) (T cookie))
(prm 'mset p (K (- disp-port-cookie vector-tag)) (T cookie)) (prm 'mset p (K (- disp-port-unused1 vector-tag)) (K 0))
(prm 'mset p (K (- disp-port-position vector-tag)) pos) (prm 'mset p (K (- disp-port-unused2 vector-tag)) (K 0))
(prm 'mset p (K (- disp-port-unused vector-tag)) (K 0)) p)])
p))])
(define-primop $port-index unsafe (define-primop $port-index unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-index vector-tag)))]) [(V x) (prm 'mref (T x) (K (- disp-port-index vector-tag)))])
@ -2291,8 +2290,6 @@
[(V x) (prm 'mref (T x) (K (- disp-port-close vector-tag)))]) [(V x) (prm 'mref (T x) (K (- disp-port-close vector-tag)))])
(define-primop $port-cookie unsafe (define-primop $port-cookie unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-cookie vector-tag)))]) [(V x) (prm 'mref (T x) (K (- disp-port-cookie vector-tag)))])
(define-primop $port-position unsafe
[(V x) (prm 'mref (T x) (K (- disp-port-position vector-tag)))])
(define-primop $port-attrs unsafe (define-primop $port-attrs unsafe
[(V x) [(V x)
(prm 'sra (prm 'sra
@ -2314,8 +2311,6 @@
[(E x i) (prm 'mset (T x) (K (- disp-port-index vector-tag)) (T i))]) [(E x i) (prm 'mset (T x) (K (- disp-port-index vector-tag)) (T i))])
(define-primop $set-port-size! unsafe (define-primop $set-port-size! unsafe
[(E x i) (prm 'mset (T x) (K (- disp-port-size vector-tag)) (T i))]) [(E x i) (prm 'mset (T x) (K (- disp-port-size vector-tag)) (T i))])
(define-primop $set-port-position! unsafe
[(E x i) (prm 'mset (T x) (K (- disp-port-position vector-tag)) (T i))])
(define-primop $set-port-attrs! unsafe (define-primop $set-port-attrs! unsafe
[(E x i) [(E x i)
(prm 'mset (T x) (prm 'mset (T x)