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-close (* 10 wordsize))
(define disp-port-cookie (* 11 wordsize))
(define disp-port-position (* 12 wordsize))
(define disp-port-unused (* 13 wordsize))
(define disp-port-unused1 (* 12 wordsize))
(define disp-port-unused2 (* 13 wordsize))
(define port-size (* 14 wordsize))
(define disp-tcbucket-tconc 0)

66
scheme/ikarus.io.ss
View File

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

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

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