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

* (ikarus io-ports) now exports make-input-port, make-output-port, 

make-input/output-port port-handler port-input-buffer port-output-buffer
  port-input-index set-port-input-index! port-input-size set-port-input-size!
  port-output-index set-port-output-index! port-output-size set-port-output-size!
This commit is contained in:
Abdulaziz Ghuloum 2007-05-05 18:03:28 -04:00
parent 55f1a1282e
commit 27f45ae065
2 changed files with 235 additions and 204 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.

167
src/libchezio.ss
View File

@ -1,30 +1,32 @@
(library (ikarus chez-io)
(export)
(import (scheme))
(define-syntax message-case
(syntax-rules (else)
[(_ msg args
[(msg-name msg-arg* ...) b b* ...] ...
[else else1 else2 ...])
(let ([tmsg msg] [targs args])
(define-syntax match-and-bind
(syntax-rules ()
[(__ y () body)
(if (null? y)
body
(error 'message-case "unmatched ~s" (cons tmsg targs)))]
[(__ y (a a* (... ...)) body)
(if (pair? y)
(let ([a (car y)] [d (cdr y)])
(match-and-bind d (a* (... ...)) body))
(error 'message-case "unmatched ~s" (cons tmsg targs)))]))
(case tmsg
[(msg-name)
(match-and-bind targs (msg-arg* ...) (begin b b* ...))] ...
[else else1 else2 ...]))]))
(let () ;;; GENERIC PORTS: BASIC PRIMITIVES
(library (ikarus io-ports)
(export make-input-port make-output-port make-input/output-port
port-handler
port-input-buffer port-output-buffer
port-input-index set-port-input-index!
port-input-size set-port-input-size!
port-output-index set-port-output-index!
port-output-size set-port-output-size!)
(import
(only (scheme) $make-port/input $make-port/output
$make-port/both $port-handler
$port-input-buffer $port-output-buffer
$port-input-index $set-port-input-index!
$port-input-size $set-port-input-size!
$port-output-index $set-port-output-index!
$port-output-size $set-port-output-size!
$string-length $fx<= $fx>=)
(except (ikarus) make-input-port make-output-port
make-input/output-port port-handler
port-input-buffer port-output-buffer
port-input-index set-port-input-index!
port-input-size set-port-input-size!
port-output-index set-port-output-index!
port-output-size set-port-output-size!)
)
;;; GENERIC PORTS: BASIC PRIMITIVES
;;;
;;; Exports:
;;; * Constructors:
@ -56,11 +58,11 @@
;;; (set-port-output-size! port fixnum)
;;;
;;;
(primitive-set! '$make-input-port
(define $make-input-port
(lambda (handler buffer)
($make-port/input handler buffer 0 ($string-length buffer) #f 0 0)))
;;;
(primitive-set! 'make-input-port
(define make-input-port
(lambda (handler buffer)
(if (procedure? handler)
(if (string? buffer)
@ -68,11 +70,11 @@
(error 'make-input-port "~s is not a string" buffer))
(error 'make-input-port "~s is not a procedure" handler))))
;;;
(primitive-set! '$make-output-port
(define $make-output-port
(lambda (handler buffer)
($make-port/output handler #f 0 0 buffer 0 ($string-length buffer))))
;;;
(primitive-set! 'make-output-port
(define make-output-port
(lambda (handler buffer)
(if (procedure? handler)
(if (string? buffer)
@ -80,13 +82,13 @@
(error 'make-output-port "~s is not a string" buffer))
(error 'make-output-port "~s is not a procedure" handler))))
;;;
(primitive-set! '$make-input/output-port
(define $make-input/output-port
(lambda (handler input-buffer output-buffer)
($make-port/both handler
input-buffer 0 ($string-length input-buffer)
output-buffer 0 ($string-length output-buffer))))
;;;
(primitive-set! 'make-input/output-port
(define make-input/output-port
(lambda (handler input-buffer output-buffer)
(if (procedure? handler)
(if (string? input-buffer)
@ -98,73 +100,73 @@
(error 'make-input/output-port "~s is not a string" input-buffer))
(error 'make-input/output-port "~s is not a procedure" handler))))
;;;
(primitive-set! '$port-handler
(lambda (x) ($port-handler x)))
;;; XXX (primitive-set! '$port-handler
;;; XXX (lambda (x) ($port-handler x)))
;;;
(primitive-set! 'port-handler
(define port-handler
(lambda (x)
(if (port? x)
($port-handler x)
(error 'port-handler "~s is not a port" x))))
;;;
(primitive-set! '$port-input-buffer
(lambda (x) ($port-input-buffer x)))
;;; XXX (define $port-input-buffer
;;; XXX (lambda (x) ($port-input-buffer x)))
;;;
(primitive-set! 'port-input-buffer
(define port-input-buffer
(lambda (x)
(if (input-port? x)
($port-input-buffer x)
(error 'port-input-buffer "~s is not an input-port" x))))
;;;
(primitive-set! '$port-input-index
(lambda (x) ($port-input-index x)))
;;; XXX (primitive-set! '$port-input-index
;;; XXX (lambda (x) ($port-input-index x)))
;;;
(primitive-set! 'port-input-index
(define port-input-index
(lambda (x)
(if (input-port? x)
($port-input-index x)
(error 'port-input-index "~s is not an input-port" x))))
;;;
(primitive-set! '$port-input-size
(lambda (x) ($port-input-size x)))
;;; XXX (primitive-set! '$port-input-size
;;; XXX (lambda (x) ($port-input-size x)))
;;;
(primitive-set! 'port-input-size
(define port-input-size
(lambda (x)
(if (input-port? x)
($port-input-size x)
(error 'port-input-size "~s is not an input-port" x))))
;;;
(primitive-set! '$port-output-buffer
(lambda (x) ($port-output-buffer x)))
;;; XXX (define '$port-output-buffer
;;; XXX (lambda (x) ($port-output-buffer x)))
;;;
(primitive-set! 'port-output-buffer
(define port-output-buffer
(lambda (x)
(if (output-port? x)
($port-output-buffer x)
(error 'port-output-buffer "~s is not an output-port" x))))
;;;
(primitive-set! '$port-output-index
(lambda (x) ($port-output-index x)))
;;; XXX (primitive-set! '$port-output-index
;;; XXX (lambda (x) ($port-output-index x)))
;;;
(primitive-set! 'port-output-index
(define port-output-index
(lambda (x)
(if (output-port? x)
($port-output-index x)
(error 'port-output-index "~s is not an output-port" x))))
;;;
(primitive-set! '$port-output-size
(lambda (x) ($port-output-size x)))
;;; XXX (primitive-set! '$port-output-size
;;; XXX (lambda (x) ($port-output-size x)))
;;;
(primitive-set! 'port-output-size
(define port-output-size
(lambda (x)
(if (output-port? x)
($port-output-size x)
(error 'port-output-size "~s is not an output-port" x))))
;;;
(primitive-set! '$set-port-input-index!
(lambda (p i) ($set-port-input-index! p i)))
;;; XXX (define '$set-port-input-index!
;;; XXX (lambda (p i) ($set-port-input-index! p i)))
;;;
(primitive-set! 'set-port-input-index!
(define set-port-input-index!
(lambda (p i)
(if (input-port? p)
(if (fixnum? i)
@ -176,12 +178,12 @@
(error 'set-port-input-index! "~s is not a valid index" i))
(error 'set-port-input-index! "~s is not an input-port" p))))
;;;
(primitive-set! '$set-port-input-size!
(lambda (p i)
($set-port-input-index! p 0)
($set-port-input-size! p i)))
;;; XXX (primitive-set! '$set-port-input-size!
;;; XXX (lambda (p i)
;;; XXX ($set-port-input-index! p 0)
;;; XXX ($set-port-input-size! p i)))
;;;
(primitive-set! 'set-port-input-size!
(define set-port-input-size!
(lambda (p i)
(if (input-port? p)
(if (fixnum? i)
@ -195,10 +197,10 @@
(error 'set-port-input-size! "~s is not a valid size" i))
(error 'set-port-input-size! "~s is not an input-port" p))))
;;;
(primitive-set! '$set-port-output-index!
(lambda (p i) ($set-port-output-index! p i)))
;;; XXX (primitive-set! '$set-port-output-index!
;;; XXX (lambda (p i) ($set-port-output-index! p i)))
;;;
(primitive-set! 'set-port-output-index!
(define set-port-output-index!
(lambda (p i)
(if (output-port? p)
(if (fixnum? i)
@ -210,12 +212,12 @@
(error 'set-port-output-index! "~s is not a valid index" i))
(error 'set-port-output-index! "~s is not an output-port" p))))
;;;
(primitive-set! '$set-port-output-size!
(lambda (p i)
($set-port-output-index! p 0)
($set-port-output-size! p i)))
;;; XXX (primitive-set! '$set-port-output-size!
;;; XXX (lambda (p i)
;;; XXX ($set-port-output-index! p 0)
;;; XXX ($set-port-output-size! p i)))
;;;
(primitive-set! 'set-port-output-size!
(define set-port-output-size!
(lambda (p i)
(if (output-port? p)
(if (fixnum? i)
@ -229,6 +231,35 @@
(error 'set-port-output-size! "~s is not a valid size" i))
(error 'set-port-output-size! "~s is not an output-port" p)))))
(library (ikarus chez-io)
(export)
(import (scheme))
(define-syntax message-case
(syntax-rules (else)
[(_ msg args
[(msg-name msg-arg* ...) b b* ...] ...
[else else1 else2 ...])
(let ([tmsg msg] [targs args])
(define-syntax match-and-bind
(syntax-rules ()
[(__ y () body)
(if (null? y)
body
(error 'message-case "unmatched ~s" (cons tmsg targs)))]
[(__ y (a a* (... ...)) body)
(if (pair? y)
(let ([a (car y)] [d (cdr y)])
(match-and-bind d (a* (... ...)) body))
(error 'message-case "unmatched ~s" (cons tmsg targs)))]))
(case tmsg
[(msg-name)
(match-and-bind targs (msg-arg* ...) (begin b b* ...))] ...
[else else1 else2 ...]))]))
(let () ;;; IO PRIMITIVES
;;;
(primitive-set! '$write-char