2007-05-05 18:04:38 -04:00
|
|
|
|
|
|
|
(library (ikarus io-ports)
|
2007-08-26 20:04:00 -04:00
|
|
|
(export make-input-port make-output-port
|
2007-05-05 18:04:38 -04:00
|
|
|
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
|
2007-05-06 18:25:53 -04:00
|
|
|
(ikarus system $ports)
|
|
|
|
(ikarus system $strings)
|
2007-05-17 06:27:59 -04:00
|
|
|
(ikarus system $bytevectors)
|
2007-05-06 18:25:53 -04:00
|
|
|
(ikarus system $fx)
|
2007-08-25 10:49:39 -04:00
|
|
|
(except (ikarus)
|
|
|
|
make-input-port make-output-port
|
|
|
|
port-handler
|
2007-05-05 18:04:38 -04:00
|
|
|
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:
|
|
|
|
;;; (make-input-port handler input-buffer)
|
|
|
|
;;; (make-output-port handler output-buffer)
|
|
|
|
;;;
|
|
|
|
;;; * Predicates:
|
|
|
|
;;; (port? x)
|
|
|
|
;;; (input-port? x)
|
|
|
|
;;; (output-port? x)
|
|
|
|
;;;
|
|
|
|
;;; * Accessors:
|
|
|
|
;;; (port-handler port)
|
2007-08-26 20:04:00 -04:00
|
|
|
;;; (port-buffer port)
|
|
|
|
;;; (port-index port)
|
|
|
|
;;; (port-size port)
|
2007-05-05 18:04:38 -04:00
|
|
|
;;;
|
|
|
|
;;; * Mutators:
|
2007-08-26 20:04:00 -04:00
|
|
|
;;; (set-port-index! port fixnum)
|
|
|
|
;;; (set-port-size! port fixnum)
|
2007-05-05 18:04:38 -04:00
|
|
|
;;;
|
|
|
|
(define $make-input-port
|
|
|
|
(lambda (handler buffer)
|
2007-08-25 11:24:05 -04:00
|
|
|
($make-port/input handler buffer 0 ($bytevector-length buffer))))
|
2007-05-05 18:04:38 -04:00
|
|
|
;;;
|
|
|
|
(define make-input-port
|
|
|
|
(lambda (handler buffer)
|
|
|
|
(if (procedure? handler)
|
2007-05-17 06:27:59 -04:00
|
|
|
(if (bytevector? buffer)
|
2007-05-05 18:04:38 -04:00
|
|
|
($make-input-port handler buffer)
|
2007-05-17 06:27:59 -04:00
|
|
|
(error 'make-input-port "~s is not a bytevector" buffer))
|
2007-05-05 18:04:38 -04:00
|
|
|
(error 'make-input-port "~s is not a procedure" handler))))
|
|
|
|
;;;
|
|
|
|
(define $make-output-port
|
|
|
|
(lambda (handler buffer)
|
2007-08-25 11:24:05 -04:00
|
|
|
($make-port/output handler buffer 0 ($bytevector-length buffer))))
|
2007-05-05 18:04:38 -04:00
|
|
|
;;;
|
|
|
|
(define make-output-port
|
|
|
|
(lambda (handler buffer)
|
|
|
|
(if (procedure? handler)
|
2007-05-18 16:07:58 -04:00
|
|
|
(if (bytevector? buffer)
|
2007-05-05 18:04:38 -04:00
|
|
|
($make-output-port handler buffer)
|
2007-05-18 16:07:58 -04:00
|
|
|
(error 'make-output-port "~s is not a bytevector" buffer))
|
2007-05-05 18:04:38 -04:00
|
|
|
(error 'make-output-port "~s is not a procedure" handler))))
|
|
|
|
;;;
|
|
|
|
(define port-handler
|
|
|
|
(lambda (x)
|
|
|
|
(if (port? x)
|
|
|
|
($port-handler x)
|
|
|
|
(error 'port-handler "~s is not a port" x))))
|
|
|
|
;;;
|
|
|
|
(define port-input-buffer
|
|
|
|
(lambda (x)
|
|
|
|
(if (input-port? x)
|
2007-08-25 11:06:30 -04:00
|
|
|
($port-buffer x)
|
2007-05-05 18:04:38 -04:00
|
|
|
(error 'port-input-buffer "~s is not an input-port" x))))
|
|
|
|
;;;
|
|
|
|
(define port-input-index
|
|
|
|
(lambda (x)
|
|
|
|
(if (input-port? x)
|
2007-08-25 11:06:30 -04:00
|
|
|
($port-index x)
|
2007-05-05 18:04:38 -04:00
|
|
|
(error 'port-input-index "~s is not an input-port" x))))
|
|
|
|
;;;
|
|
|
|
(define port-input-size
|
|
|
|
(lambda (x)
|
|
|
|
(if (input-port? x)
|
2007-08-25 11:06:30 -04:00
|
|
|
($port-size x)
|
2007-05-05 18:04:38 -04:00
|
|
|
(error 'port-input-size "~s is not an input-port" x))))
|
|
|
|
;;;
|
|
|
|
(define port-output-buffer
|
|
|
|
(lambda (x)
|
|
|
|
(if (output-port? x)
|
2007-08-25 11:24:05 -04:00
|
|
|
($port-buffer x)
|
2007-05-05 18:04:38 -04:00
|
|
|
(error 'port-output-buffer "~s is not an output-port" x))))
|
|
|
|
;;;
|
|
|
|
(define port-output-index
|
|
|
|
(lambda (x)
|
|
|
|
(if (output-port? x)
|
2007-08-25 11:24:05 -04:00
|
|
|
($port-index x)
|
2007-05-05 18:04:38 -04:00
|
|
|
(error 'port-output-index "~s is not an output-port" x))))
|
|
|
|
;;;
|
|
|
|
(define port-output-size
|
|
|
|
(lambda (x)
|
|
|
|
(if (output-port? x)
|
2007-08-25 11:24:05 -04:00
|
|
|
($port-size x)
|
2007-05-05 18:04:38 -04:00
|
|
|
(error 'port-output-size "~s is not an output-port" x))))
|
|
|
|
;;;
|
|
|
|
(define set-port-input-index!
|
|
|
|
(lambda (p i)
|
|
|
|
(if (input-port? p)
|
|
|
|
(if (fixnum? i)
|
|
|
|
(if ($fx>= i 0)
|
2007-08-25 11:06:30 -04:00
|
|
|
(if ($fx<= i ($port-size p))
|
|
|
|
($set-port-index! p i)
|
2007-05-05 18:04:38 -04:00
|
|
|
(error 'set-port-input-index! "index ~s is too big" i))
|
|
|
|
(error 'set-port-input-index! "index ~s is negative" i))
|
|
|
|
(error 'set-port-input-index! "~s is not a valid index" i))
|
|
|
|
(error 'set-port-input-index! "~s is not an input-port" p))))
|
|
|
|
;;;
|
|
|
|
(define set-port-input-size!
|
|
|
|
(lambda (p i)
|
|
|
|
(if (input-port? p)
|
|
|
|
(if (fixnum? i)
|
|
|
|
(if ($fx>= i 0)
|
2007-08-25 11:06:30 -04:00
|
|
|
(if ($fx<= i ($bytevector-length ($port-buffer p)))
|
2007-05-05 18:04:38 -04:00
|
|
|
(begin
|
2007-08-25 11:06:30 -04:00
|
|
|
($set-port-index! p 0)
|
|
|
|
($set-port-size! p i))
|
2007-05-05 18:04:38 -04:00
|
|
|
(error 'set-port-input-size! "size ~s is too big" i))
|
|
|
|
(error 'set-port-input-size! "size ~s is negative" i))
|
|
|
|
(error 'set-port-input-size! "~s is not a valid size" i))
|
|
|
|
(error 'set-port-input-size! "~s is not an input-port" p))))
|
|
|
|
;;;
|
|
|
|
(define set-port-output-index!
|
|
|
|
(lambda (p i)
|
|
|
|
(if (output-port? p)
|
|
|
|
(if (fixnum? i)
|
|
|
|
(if ($fx>= i 0)
|
2007-08-25 11:24:05 -04:00
|
|
|
(if ($fx<= i ($port-size p))
|
|
|
|
($set-port-index! p i)
|
2007-05-05 18:04:38 -04:00
|
|
|
(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! "~s is not a valid index" i))
|
|
|
|
(error 'set-port-output-index! "~s is not an output-port" p))))
|
|
|
|
;;;
|
|
|
|
(define set-port-output-size!
|
|
|
|
(lambda (p i)
|
|
|
|
(if (output-port? p)
|
|
|
|
(if (fixnum? i)
|
|
|
|
(if ($fx>= i 0)
|
2007-08-25 11:24:05 -04:00
|
|
|
(if ($fx<= i ($bytevector-length ($port-buffer p)))
|
2007-05-05 18:04:38 -04:00
|
|
|
(begin
|
2007-08-25 11:24:05 -04:00
|
|
|
($set-port-index! p 0)
|
|
|
|
($set-port-size! p i))
|
2007-05-05 18:04:38 -04:00
|
|
|
(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! "~s is not a valid size" i))
|
|
|
|
(error 'set-port-output-size! "~s is not an output-port" p)))))
|
2007-08-26 20:04:00 -04:00
|
|
|
|
|
|
|
|
|
|
|
|