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

moved output strings, file descriptors, and port mode into a port "cookie"

This commit is contained in:
Abdulaziz Ghuloum 2009-05-30 13:18:43 +03:00
parent eec9453fc7
commit 3099d1d629
3 changed files with 43 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
scheme/ikarus.compiler.ss
View File

@ -650,6 +650,18 @@
[body (E body)]) [body (E body)])
(import (only (ikarus) map)) (import (only (ikarus) map))
(list 'letrec (map list lhs* rhs*) body))] (list 'letrec (map list lhs* rhs*) body))]
[(recbind lhs* rhs* body)
(let* ([lhs* (map Var lhs*)]
[rhs* (map E rhs*)]
[body (E body)])
(import (only (ikarus) map))
(list 'letrec (map list lhs* rhs*) body))]
[(rec*bind lhs* rhs* body)
(let* ([lhs* (map Var lhs*)]
[rhs* (map E rhs*)]
[body (E body)])
(import (only (ikarus) map))
(list 'letrec* (map list lhs* rhs*) body))]
[(seq e0 e1) [(seq e0 e1)
(cons 'begin (cons 'begin
(let f ([e0 e0] [e* (list e1)]) (let f ([e0 e0] [e* (list e1)])

62
scheme/ikarus.io.ss
View File

@ -225,7 +225,7 @@
(define fast-u16be-text-tag #b00000010000000) (define fast-u16be-text-tag #b00000010000000)
(define fast-u16le-text-tag #b00000100000000) (define fast-u16le-text-tag #b00000100000000)
(define init-u16-text-tag #b00000110000000) (define init-u16-text-tag #b00000110000000)
(define r6rs-mode-tag #b01000000000000) ; (define r6rs-mode-tag #b01000000000000)
(define closed-port-tag #b10000000000000) (define closed-port-tag #b10000000000000)
(define port-type-mask #b00000000001111) (define port-type-mask #b00000000001111)
@ -256,6 +256,11 @@
(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 reader))
(define (default-cookie fd) (make-cookie fd 'ikarus-mode #f))
(define (port-id p) (define (port-id p)
(if (port? p) (if (port? p)
($port-id p) ($port-id p)
@ -326,7 +331,6 @@
(and ($port-set-position! p) #t) (and ($port-set-position! p) #t)
(die who "not a port" p))) (die who "not a port" p)))
(define guarded-port (define guarded-port
(let ([G (make-guardian)]) (let ([G (make-guardian)])
(define (clean-up) (define (clean-up)
@ -337,7 +341,7 @@
(clean-up))])) (clean-up))]))
(lambda (p) (lambda (p)
(clean-up) (clean-up)
(when (fixnum? ($port-cookie p)) (when (fixnum? (cookie-dest ($port-cookie p)))
(G p)) (G p))
p))) p)))
@ -345,13 +349,15 @@
read! write! get-position set-position! close buffer-size) read! write! get-position set-position! close buffer-size)
(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 #f (vector 0)))) get-position set-position! close
(default-cookie #f) (vector 0))))
(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 #f (vector 0)))) get-position set-position! close
(default-cookie #f) (vector 0))))
(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)
@ -489,7 +495,7 @@
#t ;;; get-position #t ;;; get-position
#t ;;; set-position! #t ;;; set-position!
#f ;;; close #f ;;; close
#f (default-cookie #f)
(vector 0))])) (vector 0))]))
(define open-bytevector-output-port (define open-bytevector-output-port
@ -517,7 +523,7 @@
#t ;;; get-position #t ;;; get-position
#f ;;; set-position! #f ;;; set-position!
#f ;;; close #f ;;; close
#f ;;; cookie (default-cookie #f) ;;; cookie
(vector 0))]) (vector 0))])
(values (values
p p
@ -581,12 +587,9 @@
(parameterize ([current-output-port p]) (parameterize ([current-output-port p])
(proc))) (proc)))
(define-struct output-string-cookie (strings))
(define (open-output-string) (define (open-output-string)
(define who 'open-output-string) (define who 'open-output-string)
(let ([cookie (make-output-string-cookie '())] (let ([cookie (default-cookie '())]
[buffer-size 256]) [buffer-size 256])
($make-port ($make-port
(fxior textual-output-port-bits fast-char-text-tag) (fxior textual-output-port-bits fast-char-text-tag)
@ -598,8 +601,7 @@
(unless (= c 0) (unless (= c 0)
(let ([x (make-string c)]) (let ([x (make-string c)])
(string-copy! str i x 0 c) (string-copy! str i x 0 c)
(set-output-string-cookie-strings! cookie (set-cookie-dest! cookie (cons x (cookie-dest cookie)))))
(cons x (output-string-cookie-strings cookie)))))
c) c)
#t ;;; get-position #t ;;; get-position
#f ;;; set-position! #f ;;; set-position!
@ -613,7 +615,7 @@
p p
(lambda () (lambda ()
(let ([str (get-output-string p)]) (let ([str (get-output-string p)])
(set-output-string-cookie-strings! ($port-cookie p) '()) (set-cookie-dest! ($port-cookie p) '())
str))))) str)))))
(define (get-output-string-cookie-data cookie) (define (get-output-string-cookie-data cookie)
@ -628,7 +630,7 @@
(let-values ([(bv i) (f (cdr ls) (fx+ i n))]) (let-values ([(bv i) (f (cdr ls) (fx+ i n))])
(string-copy! a 0 bv i n) (string-copy! a 0 bv i n)
(values bv (fx+ i n))))]))) (values bv (fx+ i n))))])))
(let ([buf* (output-string-cookie-strings cookie)]) (let ([buf* (cookie-dest cookie)])
(let-values ([(bv len) (append-str-buf* buf*)]) (let-values ([(bv len) (append-str-buf* buf*)])
bv))) bv)))
@ -636,7 +638,9 @@
(if (port? p) (if (port? p)
(let ([cookie ($port-cookie p)]) (let ([cookie ($port-cookie p)])
(cond (cond
[(output-string-cookie? cookie) [(and (cookie? cookie)
(let ([x (cookie-dest cookie)])
(or (null? x) (pair? x))))
(unless ($port-closed? p) (unless ($port-closed? p)
(flush-output-port p)) (flush-output-port p))
(get-output-string-cookie-data cookie)] (get-output-string-cookie-data cookie)]
@ -659,7 +663,7 @@
#t ;;; get-position #t ;;; get-position
#t ;;; set-position! #t ;;; set-position!
#f ;;; close #f ;;; close
#f ;;; cookie (default-cookie #f) ;;; cookie
(vector 0))) (vector 0)))
(define (open-string-input-port str) (define (open-string-input-port str)
@ -735,20 +739,14 @@
(define (port-mode p) (define (port-mode p)
(if (port? p) (if (port? p)
(if (fxzero? (fxand ($port-attrs p) r6rs-mode-tag)) (cookie-mode ($port-cookie p))
'ikarus-mode
'r6rs-mode)
(die 'port-mode "not a port" p))) (die 'port-mode "not a port" p)))
(define (set-port-mode! p mode) (define (set-port-mode! p mode)
(if (port? p) (if (port? p)
(case mode (case mode
[(r6rs-mode) [(r6rs-mode ikarus-mode)
($set-port-attrs! p (set-cookie-mode! ($port-cookie p) mode)]
(fxior ($port-attrs p) r6rs-mode-tag))]
[(ikarus-mode)
($set-port-attrs! p
(fxand ($port-attrs p) (fxnot r6rs-mode-tag)))]
[else (die 'set-port-mode! "invalid mode" mode)]) [else (die 'set-port-mode! "invalid mode" mode)])
(die 'set-port-mode! "not a port" p))) (die 'set-port-mode! "not a port" p)))
@ -1505,7 +1503,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])
fd (default-cookie fd)
(vector 0))]) (vector 0))])
(guarded-port port))) (guarded-port port)))
@ -1545,7 +1543,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])
fd (default-cookie fd)
(vector 0))]) (vector 0))])
(guarded-port port))) (guarded-port port)))
@ -2546,11 +2544,11 @@
(define who 'unregister-callback) (define who 'unregister-callback)
(cond (cond
[(output-port? what) [(output-port? what)
(let ([c ($port-cookie what)]) (let ([c (cookie-dest ($port-cookie what))])
(unless (fixnum? c) (die who "not a file-based port" what)) (unless (fixnum? c) (die who "not a file-based port" what))
(rem-io-event c))] (rem-io-event c))]
[(input-port? what) [(input-port? what)
(let ([c ($port-cookie what)]) (let ([c (cookie-dest ($port-cookie what))])
(unless (fixnum? c) (die who "not a file-based port" what)) (unless (fixnum? c) (die who "not a file-based port" what))
(rem-io-event c))] (rem-io-event c))]
[(tcp-server? what) [(tcp-server? what)
@ -2563,11 +2561,11 @@
(die who "not a procedure" proc)) (die who "not a procedure" proc))
(cond (cond
[(output-port? what) [(output-port? what)
(let ([c ($port-cookie what)]) (let ([c (cookie-dest ($port-cookie what))])
(unless (fixnum? c) (die who "not a file-based port" what)) (unless (fixnum? c) (die who "not a file-based port" what))
(add-io-event c proc 'w))] (add-io-event c proc 'w))]
[(input-port? what) [(input-port? what)
(let ([c ($port-cookie what)]) (let ([c (cookie-dest ($port-cookie what))])
(unless (fixnum? c) (die who "not a file-based port" what)) (unless (fixnum? c) (die who "not a file-based port" what))
(add-io-event c proc 'r))] (add-io-event c proc 'r))]
[(tcp-server? what) [(tcp-server? what)

2
scheme/last-revision
View File

@ -1 +1 @@
1801 1802