New IO layer is installed. Still buggy in some area but can be used
for bootstrapping at least.
This commit is contained in:
parent
ea96ab85db
commit
0e38534d2e
|
@ -9,7 +9,11 @@
|
|||
get-bytevector-n get-bytevector-n!
|
||||
get-string-n get-string-n! get-line port?
|
||||
close-input-port close-output-port flush-output-port
|
||||
open-input-file call-with-input-file with-input-from-file)
|
||||
open-input-file call-with-input-file with-input-from-file
|
||||
put-char put-u8 open-bytevector-output-port
|
||||
call-with-bytevector-output-port open-string-output-port
|
||||
write-char current-output-port current-error-port
|
||||
standard-output-port standard-error-port put-string)
|
||||
|
||||
(io-spec))
|
||||
|
||||
|
@ -403,7 +407,74 @@
|
|||
|
||||
(assert (= (file-size "SRFI-1.ss") 56573))
|
||||
|
||||
(define (file->bytevector filename)
|
||||
(let ([p (open-file-input-port filename (file-options) 'block #f)])
|
||||
(u8-list->bytevector
|
||||
(let f ()
|
||||
(let ([x (get-u8 p)])
|
||||
(if (eof-object? x)
|
||||
(begin (close-input-port p) '())
|
||||
(cons x (f))))))))
|
||||
|
||||
(define (bytevector->binary-port bv p)
|
||||
(let f ([i 0])
|
||||
(unless (fx= i (bytevector-length bv))
|
||||
(put-u8 p (bytevector-u8-ref bv i))
|
||||
(f (fx+ i 1)))))
|
||||
|
||||
(define (bytevector->textual-port bv p)
|
||||
(let f ([i 0])
|
||||
(unless (fx= i (bytevector-length bv))
|
||||
(put-char p (integer->char (bytevector-u8-ref bv i)))
|
||||
(f (fx+ i 1)))))
|
||||
|
||||
(let ([bv (file->bytevector "SRFI-1.ss")])
|
||||
(let-values ([(p extract) (open-bytevector-output-port #f)])
|
||||
(bytevector->binary-port bv p)
|
||||
(let ([bv2 (extract)])
|
||||
(assert (bytevector=? bv bv2))
|
||||
(assert (bytevector=? #vu8() (extract))))))
|
||||
|
||||
(let ([bv (file->bytevector "SRFI-1.ss")])
|
||||
(let-values ([(p extract) (open-bytevector-output-port
|
||||
(native-transcoder))])
|
||||
(bytevector->textual-port bv p)
|
||||
(let ([bv2 (extract)])
|
||||
(assert (bytevector=? bv bv2))
|
||||
(assert (bytevector=? #vu8() (extract))))))
|
||||
|
||||
(let ([bv (file->bytevector "SRFI-1.ss")])
|
||||
(let-values ([(p extract) (open-bytevector-output-port
|
||||
(make-transcoder (latin-1-codec)))])
|
||||
(bytevector->textual-port bv p)
|
||||
(let ([bv2 (extract)])
|
||||
(assert (bytevector=? bv bv2))
|
||||
(assert (bytevector=? #vu8() (extract))))))
|
||||
|
||||
(let ([bv (file->bytevector "SRFI-1.ss")])
|
||||
(let-values ([(p extract) (open-string-output-port)])
|
||||
(bytevector->textual-port bv p)
|
||||
(let ([str (extract)])
|
||||
(assert (bytevector=? bv (string->utf8 str)))
|
||||
(assert (string=? "" (extract))))))
|
||||
|
||||
(let ([p (standard-output-port)])
|
||||
(bytevector->binary-port
|
||||
(string->utf8 "HELLO THERE\n")
|
||||
p)
|
||||
(flush-output-port p))
|
||||
|
||||
(let ([p (current-output-port)])
|
||||
(bytevector->textual-port
|
||||
(string->utf8 "HELLO THERE\n")
|
||||
p)
|
||||
(flush-output-port p))
|
||||
|
||||
(let ([p (current-output-port)])
|
||||
(put-string p "HELLO THERE\n")
|
||||
(flush-output-port p))
|
||||
|
||||
(open-file-output-port "bar" (file-options no-truncate))
|
||||
|
||||
;(run-exhaustive-tests)
|
||||
;(run-interactive-tests)
|
||||
|
|
|
@ -1,7 +1,30 @@
|
|||
|
||||
nodist_pkglib_DATA=ikarus.boot
|
||||
EXTRA_DIST=ikarus.boot.prebuilt ikarus.enumerations.ss ikarus.exceptions.ss ikarus.apply.ss ikarus.bytevectors.ss ikarus.cafe.ss ikarus.chars.ss ikarus.code-objects.ss ikarus.codecs.ss ikarus.collect.ss ikarus.command-line.ss ikarus.compiler.altcogen.ss ikarus.compiler.ss ikarus.control.ss ikarus.date-string.ss ikarus.fasl.ss ikarus.fasl.write.ss ikarus.fixnums.ss ikarus.guardians.ss ikarus.handlers.ss ikarus.hash-tables.ss ikarus.intel-assembler.ss ikarus.io-ports.ss ikarus.io-primitives.ss ikarus.io-primitives.unsafe.ss ikarus.io.input-files.ss ikarus.io.input-strings.ss ikarus.io.output-files.ss ikarus.io.output-strings.ss ikarus.io.output-bytevectors.ss ikarus.lists.ss ikarus.load.ss ikarus.main.ss ikarus.multiple-values.ss ikarus.numerics.ss ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.ss ikarus.pretty-print.ss ikarus.promises.ss ikarus.reader.ss ikarus.records.procedural.ss ikarus.conditions.ss ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss ikarus.unicode-conversion.ss ikarus.unicode-data.ss ikarus.vectors.ss ikarus.writer.ss makefile.ss pass-specify-rep-primops.ss pass-specify-rep.ss psyntax.builders.ss psyntax.compat.ss psyntax.config.ss psyntax.expander.ss psyntax.internal.ss psyntax.library-manager.ss r6rs-records.ss ikarus/code-objects.ss ikarus/compiler.ss ikarus/intel-assembler.ss ikarus/fasl/write.ss unicode/unicode-char-cases.ss unicode/unicode-charinfo.ss
|
||||
|
||||
EXTRA_DIST=ikarus.boot.prebuilt ikarus.enumerations.ss \
|
||||
ikarus.exceptions.ss ikarus.apply.ss ikarus.bytevectors.ss \
|
||||
ikarus.cafe.ss ikarus.chars.ss ikarus.code-objects.ss \
|
||||
ikarus.codecs.ss ikarus.collect.ss ikarus.command-line.ss \
|
||||
ikarus.compiler.altcogen.ss ikarus.compiler.ss ikarus.control.ss \
|
||||
ikarus.date-string.ss ikarus.fasl.ss ikarus.fasl.write.ss \
|
||||
ikarus.fixnums.ss ikarus.guardians.ss ikarus.handlers.ss \
|
||||
ikarus.hash-tables.ss ikarus.intel-assembler.ss \
|
||||
ikarus.lists.ss ikarus.load.ss \
|
||||
ikarus.main.ss ikarus.multiple-values.ss ikarus.numerics.ss \
|
||||
ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.ss \
|
||||
ikarus.pretty-print.ss ikarus.promises.ss ikarus.reader.ss \
|
||||
ikarus.records.procedural.ss ikarus.conditions.ss \
|
||||
ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \
|
||||
ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss \
|
||||
ikarus.unicode-conversion.ss ikarus.unicode-data.ss \
|
||||
ikarus.vectors.ss ikarus.writer.ss makefile.ss \
|
||||
pass-specify-rep-primops.ss pass-specify-rep.ss psyntax.builders.ss \
|
||||
psyntax.compat.ss psyntax.config.ss psyntax.expander.ss \
|
||||
psyntax.internal.ss psyntax.library-manager.ss r6rs-records.ss \
|
||||
ikarus/code-objects.ss ikarus/compiler.ss ikarus/intel-assembler.ss \
|
||||
ikarus/fasl/write.ss unicode/unicode-char-cases.ss \
|
||||
unicode/unicode-charinfo.ss ikarus.io.ss
|
||||
|
||||
all: $(nodist_pkglib_DATA)
|
||||
|
||||
revno = "$(shell sed 's/ .*//' ../.bzr/branch/last-revision 2>/dev/null)"
|
||||
|
|
|
@ -156,33 +156,29 @@ top_builddir = @top_builddir@
|
|||
top_srcdir = @top_srcdir@
|
||||
nodist_pkglib_DATA = ikarus.boot
|
||||
EXTRA_DIST = ikarus.boot.prebuilt ikarus.enumerations.ss \
|
||||
ikarus.exceptions.ss ikarus.apply.ss ikarus.bytevectors.ss \
|
||||
ikarus.cafe.ss ikarus.chars.ss ikarus.code-objects.ss \
|
||||
ikarus.codecs.ss ikarus.collect.ss ikarus.command-line.ss \
|
||||
ikarus.compiler.altcogen.ss ikarus.compiler.ss \
|
||||
ikarus.control.ss ikarus.date-string.ss ikarus.fasl.ss \
|
||||
ikarus.fasl.write.ss ikarus.fixnums.ss ikarus.guardians.ss \
|
||||
ikarus.handlers.ss ikarus.hash-tables.ss \
|
||||
ikarus.intel-assembler.ss ikarus.io-ports.ss \
|
||||
ikarus.io-primitives.ss ikarus.io-primitives.unsafe.ss \
|
||||
ikarus.io.input-files.ss ikarus.io.input-strings.ss \
|
||||
ikarus.io.output-files.ss ikarus.io.output-strings.ss \
|
||||
ikarus.io.output-bytevectors.ss ikarus.lists.ss ikarus.load.ss \
|
||||
ikarus.main.ss ikarus.multiple-values.ss ikarus.numerics.ss \
|
||||
ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.ss \
|
||||
ikarus.pretty-print.ss ikarus.promises.ss ikarus.reader.ss \
|
||||
ikarus.records.procedural.ss ikarus.conditions.ss \
|
||||
ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \
|
||||
ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss \
|
||||
ikarus.trace.ss ikarus.unicode-conversion.ss \
|
||||
ikarus.unicode-data.ss ikarus.vectors.ss ikarus.writer.ss \
|
||||
makefile.ss pass-specify-rep-primops.ss pass-specify-rep.ss \
|
||||
psyntax.builders.ss psyntax.compat.ss psyntax.config.ss \
|
||||
psyntax.expander.ss psyntax.internal.ss \
|
||||
psyntax.library-manager.ss r6rs-records.ss \
|
||||
ikarus/code-objects.ss ikarus/compiler.ss \
|
||||
ikarus/intel-assembler.ss ikarus/fasl/write.ss \
|
||||
unicode/unicode-char-cases.ss unicode/unicode-charinfo.ss
|
||||
ikarus.exceptions.ss ikarus.apply.ss ikarus.bytevectors.ss \
|
||||
ikarus.cafe.ss ikarus.chars.ss ikarus.code-objects.ss \
|
||||
ikarus.codecs.ss ikarus.collect.ss ikarus.command-line.ss \
|
||||
ikarus.compiler.altcogen.ss ikarus.compiler.ss ikarus.control.ss \
|
||||
ikarus.date-string.ss ikarus.fasl.ss ikarus.fasl.write.ss \
|
||||
ikarus.fixnums.ss ikarus.guardians.ss ikarus.handlers.ss \
|
||||
ikarus.hash-tables.ss ikarus.intel-assembler.ss \
|
||||
ikarus.lists.ss ikarus.load.ss \
|
||||
ikarus.main.ss ikarus.multiple-values.ss ikarus.numerics.ss \
|
||||
ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.ss \
|
||||
ikarus.pretty-print.ss ikarus.promises.ss ikarus.reader.ss \
|
||||
ikarus.records.procedural.ss ikarus.conditions.ss \
|
||||
ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \
|
||||
ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss \
|
||||
ikarus.unicode-conversion.ss ikarus.unicode-data.ss \
|
||||
ikarus.vectors.ss ikarus.writer.ss makefile.ss \
|
||||
pass-specify-rep-primops.ss pass-specify-rep.ss psyntax.builders.ss \
|
||||
psyntax.compat.ss psyntax.config.ss psyntax.expander.ss \
|
||||
psyntax.internal.ss psyntax.library-manager.ss r6rs-records.ss \
|
||||
ikarus/code-objects.ss ikarus/compiler.ss ikarus/intel-assembler.ss \
|
||||
ikarus/fasl/write.ss unicode/unicode-char-cases.ss \
|
||||
unicode/unicode-charinfo.ss ikarus.io.ss
|
||||
|
||||
revno = "$(shell sed 's/ .*//' ../.bzr/branch/last-revision 2>/dev/null)"
|
||||
CLEANFILES = $(nodist_pkglib_DATA) ikarus.config.ss
|
||||
MAINTAINERCLEANFILES = last-revision
|
||||
|
|
Binary file not shown.
|
@ -72,8 +72,8 @@ description:
|
|||
(lambda (con)
|
||||
(reset-input-port! (console-input-port))
|
||||
(flush-output-port (console-output-port))
|
||||
(display "Unhandled exception\n" (standard-error-port))
|
||||
(print-condition con)
|
||||
(display "Unhandled exception\n" (console-output-port))
|
||||
(print-condition con (console-output-port))
|
||||
(k (void)))
|
||||
(lambda ()
|
||||
(display-prompt 0)
|
||||
|
|
|
@ -142,5 +142,6 @@
|
|||
(f (cdr ls) (fxlogor (cdr a) n)))]
|
||||
[else #f])))
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
|
|
@ -1967,20 +1967,20 @@
|
|||
(define transcoder-codec:utf-8 #b010)
|
||||
(define transcoder-codec:utf-16 #b011)
|
||||
|
||||
(define port-tag #x3F) ;;; 0011_F
|
||||
(define output-port-tag #x7F) ;;; 0011_F
|
||||
(define input-port-tag #xBF) ;;; 1011_F
|
||||
(define port-mask #x3F) ;;; 0011_F
|
||||
(define port-type-mask #xFF) ;;; 1111_F
|
||||
;(define port-tag #x3F) ;;; 0011_F
|
||||
;(define output-port-tag #x7F) ;;; 0011_F
|
||||
;(define input-port-tag #xBF) ;;; 1011_F
|
||||
;(define port-mask #x3F) ;;; 0011_F
|
||||
;(define port-type-mask #xFF) ;;; 1111_F
|
||||
|
||||
(define disp-port-buffer 4)
|
||||
(define disp-port-index 8)
|
||||
(define disp-port-size 12)
|
||||
(define disp-port-handler 16)
|
||||
(define disp-port-attributes 20)
|
||||
(define disp-port-unused1 24)
|
||||
(define disp-port-unused2 28)
|
||||
(define port-size 32)
|
||||
;(define disp-port-buffer 4)
|
||||
;(define disp-port-index 8)
|
||||
;(define disp-port-size 12)
|
||||
;(define disp-port-handler 16)
|
||||
;(define disp-port-attributes 20)
|
||||
;(define disp-port-unused1 24)
|
||||
;(define disp-port-unused2 28)
|
||||
;(define port-size 32)
|
||||
|
||||
|
||||
|
||||
|
|
|
@ -377,7 +377,7 @@
|
|||
(newline p)]))
|
||||
(case-lambda
|
||||
[(x)
|
||||
(print-condition x (standard-error-port))]
|
||||
(print-condition x (console-output-port))]
|
||||
[(x port)
|
||||
(if (output-port? port)
|
||||
(print-condition x port)
|
||||
|
|
|
@ -29,8 +29,13 @@
|
|||
(ikarus system $flonums)
|
||||
(ikarus system $bignums)
|
||||
(except (ikarus code-objects) procedure-annotation)
|
||||
(except (ikarus) fasl-write))
|
||||
(except (ikarus) fasl-write write-byte))
|
||||
|
||||
(define-syntax write-byte
|
||||
(syntax-rules ()
|
||||
[(_ byte port)
|
||||
(put-u8 port byte)]))
|
||||
|
||||
(define (put-tag c p)
|
||||
(write-byte (char->integer c) p))
|
||||
|
||||
|
@ -221,7 +226,7 @@
|
|||
[else (error 'fasl-write "not fasl-writable" x)])))
|
||||
(define (write-bytevector x i j p)
|
||||
(unless ($fx= i j)
|
||||
($write-byte ($bytevector-u8-ref x i) p)
|
||||
(write-byte ($bytevector-u8-ref x i) p)
|
||||
(write-bytevector x ($fxadd1 i) j p)))
|
||||
(define fasl-write-object
|
||||
(lambda (x p h m)
|
||||
|
|
|
@ -46,7 +46,8 @@
|
|||
(make-parameter
|
||||
(lambda ()
|
||||
(import (ikarus system interrupts))
|
||||
(set-port-output-index! (console-output-port) 0)
|
||||
; FIXME
|
||||
;(set-port-output-index! (console-output-port) 0)
|
||||
(raise-continuable
|
||||
(condition
|
||||
(make-interrupted-condition)
|
||||
|
|
|
@ -1,201 +0,0 @@
|
|||
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
|
||||
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
|
||||
;;;
|
||||
;;; This program is free software: you can redistribute it and/or modify
|
||||
;;; it under the terms of the GNU General Public License version 3 as
|
||||
;;; published by the Free Software Foundation.
|
||||
;;;
|
||||
;;; This program is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;; General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
|
||||
(library (ikarus io-ports)
|
||||
(export make-input-port make-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!
|
||||
port-mode set-port-mode!)
|
||||
(import
|
||||
(ikarus system $ports)
|
||||
(ikarus system $strings)
|
||||
(ikarus system $bytevectors)
|
||||
(ikarus system $fx)
|
||||
(except (ikarus)
|
||||
make-input-port make-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!
|
||||
port-mode set-port-mode!))
|
||||
;;; 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)
|
||||
;;; (port-buffer port)
|
||||
;;; (port-index port)
|
||||
;;; (port-size port)
|
||||
;;;
|
||||
;;; * Mutators:
|
||||
;;; (set-port-index! port fixnum)
|
||||
;;; (set-port-size! port fixnum)
|
||||
;;;
|
||||
(define $make-input-port
|
||||
(lambda (handler buffer)
|
||||
($make-port/input handler buffer 0 ($bytevector-length buffer))))
|
||||
;;;
|
||||
(define make-input-port
|
||||
(lambda (handler buffer)
|
||||
(if (procedure? handler)
|
||||
(if (bytevector? buffer)
|
||||
($make-input-port handler buffer)
|
||||
(error 'make-input-port "not a bytevector" buffer))
|
||||
(error 'make-input-port "not a procedure" handler))))
|
||||
;;;
|
||||
(define $make-output-port
|
||||
(lambda (handler buffer)
|
||||
($make-port/output handler buffer 0 ($bytevector-length buffer))))
|
||||
;;;
|
||||
(define make-output-port
|
||||
(lambda (handler buffer)
|
||||
(if (procedure? handler)
|
||||
(if (bytevector? buffer)
|
||||
($make-output-port handler buffer)
|
||||
(error 'make-output-port "not a bytevector" buffer))
|
||||
(error 'make-output-port "not a procedure" handler))))
|
||||
;;;
|
||||
(define port-handler
|
||||
(lambda (x)
|
||||
(if (port? x)
|
||||
($port-handler x)
|
||||
(error 'port-handler "not a port" x))))
|
||||
;;;
|
||||
(define port-input-buffer
|
||||
(lambda (x)
|
||||
(if (input-port? x)
|
||||
($port-buffer x)
|
||||
(error 'port-input-buffer "not an input-port" x))))
|
||||
;;;
|
||||
(define port-input-index
|
||||
(lambda (x)
|
||||
(if (input-port? x)
|
||||
($port-index x)
|
||||
(error 'port-input-index "not an input-port" x))))
|
||||
;;;
|
||||
(define port-input-size
|
||||
(lambda (x)
|
||||
(if (input-port? x)
|
||||
($port-size x)
|
||||
(error 'port-input-size "not an input-port" x))))
|
||||
;;;
|
||||
(define port-output-buffer
|
||||
(lambda (x)
|
||||
(if (output-port? x)
|
||||
($port-buffer x)
|
||||
(error 'port-output-buffer "not an output-port" x))))
|
||||
;;;
|
||||
(define port-output-index
|
||||
(lambda (x)
|
||||
(if (output-port? x)
|
||||
($port-index x)
|
||||
(error 'port-output-index "not an output-port" x))))
|
||||
;;;
|
||||
(define port-output-size
|
||||
(lambda (x)
|
||||
(if (output-port? x)
|
||||
($port-size x)
|
||||
(error 'port-output-size "not an output-port" x))))
|
||||
;;;
|
||||
(define set-port-input-index!
|
||||
(lambda (p i)
|
||||
(if (input-port? p)
|
||||
(if (fixnum? i)
|
||||
(if ($fx>= i 0)
|
||||
(if ($fx<= i ($port-size p))
|
||||
($set-port-index! p i)
|
||||
(error 'set-port-input-index! "index is too big" i))
|
||||
(error 'set-port-input-index! "index is negative" i))
|
||||
(error 'set-port-input-index! "not a valid index" i))
|
||||
(error 'set-port-input-index! "not an input-port" p))))
|
||||
;;;
|
||||
(define set-port-input-size!
|
||||
(lambda (p i)
|
||||
(if (input-port? p)
|
||||
(if (fixnum? i)
|
||||
(if ($fx>= i 0)
|
||||
(if ($fx<= i ($bytevector-length ($port-buffer p)))
|
||||
(begin
|
||||
($set-port-index! p 0)
|
||||
($set-port-size! p i))
|
||||
(error 'set-port-input-size! "size is too big" i))
|
||||
(error 'set-port-input-size! "size is negative" i))
|
||||
(error 'set-port-input-size! "not a valid size" i))
|
||||
(error 'set-port-input-size! "not an input-port" p))))
|
||||
;;;
|
||||
(define set-port-output-index!
|
||||
(lambda (p i)
|
||||
(if (output-port? p)
|
||||
(if (fixnum? i)
|
||||
(if ($fx>= i 0)
|
||||
(if ($fx<= i ($port-size p))
|
||||
($set-port-index! p i)
|
||||
(error 'set-port-output-index! "index is too big" i))
|
||||
(error 'set-port-output-index! "index is negative" i))
|
||||
(error 'set-port-output-index! "not a valid index" i))
|
||||
(error 'set-port-output-index! "not an output-port" p))))
|
||||
;;;
|
||||
(define set-port-output-size!
|
||||
(lambda (p i)
|
||||
(if (output-port? p)
|
||||
(if (fixnum? i)
|
||||
(if ($fx>= i 0)
|
||||
(if ($fx<= i ($bytevector-length ($port-buffer p)))
|
||||
(begin
|
||||
($set-port-index! p 0)
|
||||
($set-port-size! p i))
|
||||
(error 'set-port-output-size! "size is too big" i))
|
||||
(error 'set-port-output-size! "size is negative" i))
|
||||
(error 'set-port-output-size! "not a valid size" i))
|
||||
(error 'set-port-output-size! "not an output-port" p))))
|
||||
|
||||
(define (port-mode p)
|
||||
(if (port? p)
|
||||
(let ([attr ($port-attributes p)])
|
||||
(case (fxand attr 1)
|
||||
[(0) 'ikarus-mode]
|
||||
[else 'r6rs-mode]))
|
||||
(error 'port-mode "not a port" p)))
|
||||
|
||||
(define (set-port-mode! p m)
|
||||
(if (port? p)
|
||||
(let ([attr ($port-attributes p)])
|
||||
($set-port-attributes! p
|
||||
(case m
|
||||
[(ikarus-mode) (fxand attr (fxnot 1))]
|
||||
[(r6rs-mode) (fxior attr 1)]
|
||||
[else (error 'set-port-mode! "invalid mode" m)])))
|
||||
(error 'port-mode "not a port" p)))
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
|
@ -1,461 +0,0 @@
|
|||
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
|
||||
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
|
||||
;;;
|
||||
;;; This program is free software: you can redistribute it and/or modify
|
||||
;;; it under the terms of the GNU General Public License version 3 as
|
||||
;;; published by the Free Software Foundation.
|
||||
;;;
|
||||
;;; This program is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;; General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
|
||||
(library (ikarus io-primitives)
|
||||
(export read-char ; ok
|
||||
peek-char ; ok
|
||||
write-char
|
||||
write-byte
|
||||
put-u8
|
||||
put-char
|
||||
put-string
|
||||
put-bytevector
|
||||
get-char ; ok
|
||||
get-u8 ; ok
|
||||
lookahead-u8 ; ok
|
||||
get-string-n ; ok
|
||||
get-string-n! ; ok
|
||||
get-bytevector-n ; ok
|
||||
get-bytevector-n! ; ok
|
||||
newline ; ok
|
||||
port-name
|
||||
input-port-name
|
||||
output-port-name
|
||||
close-input-port
|
||||
reset-input-port!
|
||||
close-port
|
||||
flush-output-port
|
||||
close-output-port
|
||||
get-line ; ok
|
||||
)
|
||||
(import
|
||||
(ikarus system $io)
|
||||
(ikarus system $fx)
|
||||
(ikarus system $ports)
|
||||
(except (ikarus) read-char peek-char write-char write-byte
|
||||
put-u8 put-char put-string put-bytevector
|
||||
get-char get-u8 lookahead-u8
|
||||
get-string-n get-string-n!
|
||||
get-bytevector-n get-bytevector-n!
|
||||
newline port-name input-port-name output-port-name
|
||||
close-input-port reset-input-port! flush-output-port
|
||||
close-output-port close-port get-line))
|
||||
|
||||
(define write-char
|
||||
(case-lambda
|
||||
[(c)
|
||||
(if (char? c)
|
||||
($write-char c (current-output-port))
|
||||
(error 'write-char "not a character" c))]
|
||||
[(c p)
|
||||
(if (char? c)
|
||||
(if (output-port? p)
|
||||
($write-char c p)
|
||||
(error 'write-char "not an output-port" p))
|
||||
(error 'write-char "not a character" c))]))
|
||||
|
||||
(define put-char
|
||||
(lambda (p c)
|
||||
(if (char? c)
|
||||
(if (output-port? p)
|
||||
($write-char c p)
|
||||
(error 'put-char "not an output-port" p))
|
||||
(error 'put-char "not a character" c))))
|
||||
|
||||
(define write-byte
|
||||
(case-lambda
|
||||
[(b)
|
||||
(if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
|
||||
($write-byte b (current-output-port))
|
||||
(error 'write-byte "not a byte" b))]
|
||||
[(b p)
|
||||
(if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
|
||||
(if (output-port? p)
|
||||
($write-byte b p)
|
||||
(error 'write-byte "not an output-port" p))
|
||||
(error 'write-byte "not a byte" b))]))
|
||||
|
||||
(define put-u8
|
||||
(lambda (p b)
|
||||
(if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
|
||||
(if (output-port? p)
|
||||
($write-byte b p)
|
||||
(error 'put-u8 "not an output-port" p))
|
||||
(error 'put-u8 "not a u8" b))))
|
||||
;;;
|
||||
(define newline
|
||||
(case-lambda
|
||||
[()
|
||||
($write-char #\newline (current-output-port))
|
||||
($flush-output-port (current-output-port))]
|
||||
[(p)
|
||||
(if (output-port? p)
|
||||
(begin
|
||||
($write-char #\newline p)
|
||||
($flush-output-port p))
|
||||
(error 'newline "not an output port" p))]))
|
||||
;;;
|
||||
(define port-name
|
||||
(lambda (p)
|
||||
(if (port? p)
|
||||
(($port-handler p) 'port-name p)
|
||||
(error 'port-name "not a port" p))))
|
||||
|
||||
(define input-port-name
|
||||
(lambda (p)
|
||||
(if (port? p)
|
||||
(($port-handler p) 'port-name p)
|
||||
(error 'input-port-name "not a port" p))))
|
||||
|
||||
(define output-port-name
|
||||
(lambda (p)
|
||||
(if (port? p)
|
||||
(($port-handler p) 'port-name p)
|
||||
(error 'output-port-name "not a port" p))))
|
||||
|
||||
(define get-char
|
||||
(lambda (p)
|
||||
(if (input-port? p)
|
||||
($read-char p)
|
||||
(error 'get-char "not an input-port" p))))
|
||||
|
||||
(define get-u8
|
||||
(lambda (p)
|
||||
(if (input-port? p)
|
||||
($get-u8 p)
|
||||
(error 'get-u8 "not an input-port" p))))
|
||||
|
||||
(define lookahead-u8
|
||||
(lambda (p)
|
||||
(if (input-port? p)
|
||||
($lookahead-u8 p)
|
||||
(error 'lookahead-u8 "not an input-port" p))))
|
||||
|
||||
(define read-char
|
||||
(case-lambda
|
||||
[() ($read-char (current-input-port))]
|
||||
[(p)
|
||||
(if (input-port? p)
|
||||
($read-char p)
|
||||
(error 'read-char "not an input-port" p))]))
|
||||
;;;
|
||||
(define peek-char
|
||||
(case-lambda
|
||||
[() ($peek-char (current-input-port))]
|
||||
[(p)
|
||||
(if (input-port? p)
|
||||
($peek-char p)
|
||||
(error 'peek-char "not an input-port" p))]))
|
||||
;;;
|
||||
(define reset-input-port!
|
||||
(case-lambda
|
||||
[() ($reset-input-port! (current-input-port))]
|
||||
[(p)
|
||||
(if (input-port? p)
|
||||
($reset-input-port! p)
|
||||
(error 'reset-input-port! "not an input-port" p))]))
|
||||
;;;
|
||||
(define close-input-port
|
||||
(case-lambda
|
||||
[() ($close-input-port (current-input-port))]
|
||||
[(p)
|
||||
(if (input-port? p)
|
||||
($close-input-port p)
|
||||
(error 'close-input-port! "not an input-port" p))]))
|
||||
;;;
|
||||
(define close-output-port
|
||||
(case-lambda
|
||||
[() ($close-output-port (current-output-port))]
|
||||
[(p)
|
||||
(if (output-port? p)
|
||||
($close-output-port p)
|
||||
(error 'close-output-port "not an output-port" p))]))
|
||||
;;;
|
||||
(define (close-port p)
|
||||
(cond
|
||||
[(input-port? p) ($close-input-port p)]
|
||||
[(output-port? p) ($close-output-port p)]
|
||||
[else (error 'close-port "not a port" p)]))
|
||||
|
||||
;;;
|
||||
(define flush-output-port
|
||||
(case-lambda
|
||||
[() ($flush-output-port (current-output-port))]
|
||||
[(p)
|
||||
(if (output-port? p)
|
||||
($flush-output-port p)
|
||||
(error 'flush-output-port "not an output-port" p))]))
|
||||
|
||||
(define (get-line p)
|
||||
(define (get-it p)
|
||||
(let f ([p p] [n 0] [ac '()])
|
||||
(let ([x ($read-char p)])
|
||||
(cond
|
||||
[(eqv? x #\newline)
|
||||
(make-it n ac)]
|
||||
[(eof-object? x)
|
||||
(if (null? ac) x (make-it n ac))]
|
||||
[else (f p (+ n 1) (cons x ac))]))))
|
||||
(define (make-it n revls)
|
||||
(let f ([s (make-string n)] [i (- n 1)] [ls revls])
|
||||
(cond
|
||||
[(pair? ls)
|
||||
(string-set! s i (car ls))
|
||||
(f s (- i 1) (cdr ls))]
|
||||
[else s])))
|
||||
(if (input-port? p)
|
||||
(get-it p)
|
||||
(error 'get-line "not an input port" p)))
|
||||
|
||||
(module (put-string)
|
||||
(import (ikarus system $strings)
|
||||
(ikarus system $fx))
|
||||
(define ($put-string p s i j)
|
||||
(unless ($fx= i j)
|
||||
($write-char ($string-ref s i) p)
|
||||
($put-string p s ($fx+ i 1) j)))
|
||||
(define put-string
|
||||
(case-lambda
|
||||
[(p s)
|
||||
(unless (output-port? p)
|
||||
(error 'put-string "not an output port" p))
|
||||
(unless (string? s)
|
||||
(error 'put-string "not a string" s))
|
||||
($put-string p s 0 (string-length s))]
|
||||
[(p s i)
|
||||
(unless (output-port? p)
|
||||
(error 'put-string "not an output port" p))
|
||||
(unless (string? s)
|
||||
(error 'put-string "not a string" s))
|
||||
(let ([len ($string-length s)])
|
||||
(unless (fixnum? i)
|
||||
(error 'put-string "starting index is not a fixnum" i))
|
||||
(when (or ($fx< i 0) ($fx> i len))
|
||||
(error 'put-string
|
||||
(format "starting index is out of range 0..~a" len)
|
||||
i))
|
||||
($put-string p s i len))]
|
||||
[(p s i c)
|
||||
(unless (output-port? p)
|
||||
(error 'put-string "not an output port" p))
|
||||
(unless (string? s)
|
||||
(error 'put-string "not a string" s))
|
||||
(let ([len ($string-length s)])
|
||||
(unless (fixnum? i)
|
||||
(error 'put-string "starting index is not a fixnum" i))
|
||||
(when (or ($fx< i 0) ($fx> i len))
|
||||
(error 'put-string
|
||||
(format "starting index is out of range 0..~a" len)
|
||||
i))
|
||||
(unless (fixnum? c)
|
||||
(error 'put-string "count is not a fixnum" c))
|
||||
(let ([j (+ i c)])
|
||||
(when (or ($fx< c 0) (> j len))
|
||||
(error 'put-string
|
||||
(format "count is out of range 0..~a" (- len i))
|
||||
c))
|
||||
($put-string p s i j)))])))
|
||||
|
||||
(module (put-bytevector)
|
||||
(import (ikarus system $bytevectors)
|
||||
(ikarus system $fx))
|
||||
(define ($put-bytevector p bv i j)
|
||||
(unless ($fx= i j)
|
||||
($write-byte ($bytevector-u8-ref bv i) p)
|
||||
($put-bytevector p bv ($fx+ i 1) j)))
|
||||
(define put-bytevector
|
||||
(case-lambda
|
||||
[(p s)
|
||||
(unless (output-port? p)
|
||||
(error 'put-bytevector "not an output port" p))
|
||||
(unless (bytevector? s)
|
||||
(error 'put-bytevector "not a bytevector" s))
|
||||
($put-bytevector p s 0 (bytevector-length s))]
|
||||
[(p s i)
|
||||
(unless (output-port? p)
|
||||
(error 'put-bytevector "not an output port" p))
|
||||
(unless (bytevector? s)
|
||||
(error 'put-bytevector "not a bytevector" s))
|
||||
(let ([len ($bytevector-length s)])
|
||||
(unless (fixnum? i)
|
||||
(error 'put-bytevector "starting index is not a fixnum" i))
|
||||
(when (or ($fx< i 0) ($fx> i len))
|
||||
(error 'put-bytevector
|
||||
(format "starting index is out of range 0..~a" len)
|
||||
i))
|
||||
($put-bytevector p s i len))]
|
||||
[(p s i c)
|
||||
(unless (output-port? p)
|
||||
(error 'put-bytevector "not an output port" p))
|
||||
(unless (bytevector? s)
|
||||
(error 'put-bytevector "not a bytevector" s))
|
||||
(let ([len ($bytevector-length s)])
|
||||
(unless (fixnum? i)
|
||||
(error 'put-bytevector "starting index is not a fixnum" i))
|
||||
(when (or ($fx< i 0) ($fx> i len))
|
||||
(error 'put-bytevector
|
||||
(format "starting index is out of range 0..~a" len)
|
||||
i))
|
||||
(unless (fixnum? c)
|
||||
(error 'put-bytevector "count is not a fixnum" c))
|
||||
(let ([j (+ i c)])
|
||||
(when (or ($fx< c 0) (> j len))
|
||||
(error 'put-bytevector
|
||||
(format "count is out of range 0..~a" (- len i))
|
||||
c))
|
||||
($put-bytevector p s i j)))])))
|
||||
|
||||
|
||||
(define (get-string-n p n)
|
||||
(import (ikarus system $fx) (ikarus system $strings))
|
||||
(unless (input-port? p)
|
||||
(error 'get-string-n "not an input port" p))
|
||||
(unless (fixnum? n)
|
||||
(error 'get-string-n "count is not a fixnum" n))
|
||||
(cond
|
||||
[($fx> n 0)
|
||||
(let ([s ($make-string n)])
|
||||
(let f ([p p] [n n] [s s] [i 0])
|
||||
(let ([x ($read-char p)])
|
||||
(cond
|
||||
[(eof-object? x)
|
||||
(if ($fx= i 0)
|
||||
(eof-object)
|
||||
(substring s 0 i))]
|
||||
[else
|
||||
($string-set! s i x)
|
||||
(let ([i ($fxadd1 i)])
|
||||
(if ($fx= i n)
|
||||
s
|
||||
(f p n s i)))]))))]
|
||||
[($fx= n 0) ""]
|
||||
[else (error 'get-string-n "count is negative" n)]))
|
||||
|
||||
(define (get-string-n! p s i c)
|
||||
(import (ikarus system $fx) (ikarus system $strings))
|
||||
(unless (input-port? p)
|
||||
(error 'get-string-n! "not an input port" p))
|
||||
(unless (string? s)
|
||||
(error 'get-string-n! "not a string" s))
|
||||
(let ([len ($string-length s)])
|
||||
(unless (fixnum? i)
|
||||
(error 'get-string-n! "starting index is not a fixnum" i))
|
||||
(when (or ($fx< i 0) ($fx> i len))
|
||||
(error 'get-string-n!
|
||||
(format "starting index is out of range 0..~a" len)
|
||||
i))
|
||||
(unless (fixnum? c)
|
||||
(error 'get-string-n! "count is not a fixnum" c))
|
||||
(cond
|
||||
[($fx> c 0)
|
||||
(let ([j (+ i c)])
|
||||
(when (> j len)
|
||||
(error 'get-string-n!
|
||||
(format "count is out of range 0..~a" (- len i))
|
||||
c))
|
||||
(let ([x ($read-char p)])
|
||||
(cond
|
||||
[(eof-object? x) x]
|
||||
[else
|
||||
($string-set! s i x)
|
||||
(let f ([p p] [s s] [start i] [i 1] [c c])
|
||||
(let ([x ($read-char p)])
|
||||
(cond
|
||||
[(eof-object? x) i]
|
||||
[else
|
||||
($string-set! s ($fx+ start i) x)
|
||||
(let ([i ($fxadd1 i)])
|
||||
(if ($fx= i c)
|
||||
i
|
||||
(f p s start i c)))])))])))]
|
||||
[($fx= c 0) 0]
|
||||
[else (error 'get-string-n! "count is negative" c)])))
|
||||
|
||||
(define (get-bytevector-n p n)
|
||||
(import (ikarus system $fx) (ikarus system $bytevectors))
|
||||
(define (subbytevector s n)
|
||||
(let ([p ($make-bytevector n)])
|
||||
(let f ([s s] [n n] [p p])
|
||||
(let ([n ($fx- n 1)])
|
||||
($bytevector-set! p n ($bytevector-u8-ref s n))
|
||||
(if ($fx= n 0)
|
||||
p
|
||||
(f s n p))))))
|
||||
(unless (input-port? p)
|
||||
(error 'get-bytevector-n "not an input port" p))
|
||||
(unless (fixnum? n)
|
||||
(error 'get-bytevector-n "count is not a fixnum" n))
|
||||
(cond
|
||||
[($fx> n 0)
|
||||
(let ([s ($make-bytevector n)])
|
||||
(let f ([p p] [n n] [s s] [i 0])
|
||||
(let ([x ($get-u8 p)])
|
||||
(cond
|
||||
[(eof-object? x)
|
||||
(if ($fx= i 0)
|
||||
(eof-object)
|
||||
(subbytevector s i))]
|
||||
[else
|
||||
($bytevector-set! s i x)
|
||||
(let ([i ($fxadd1 i)])
|
||||
(if ($fx= i n)
|
||||
s
|
||||
(f p n s i)))]))))]
|
||||
[($fx= n 0) '#vu8()]
|
||||
[else (error 'get-bytevector-n "count is negative" n)]))
|
||||
|
||||
|
||||
(define (get-bytevector-n! p s i c)
|
||||
(import (ikarus system $fx) (ikarus system $bytevectors))
|
||||
(unless (input-port? p)
|
||||
(error 'get-bytevector-n! "not an input port" p))
|
||||
(unless (bytevector? s)
|
||||
(error 'get-bytevector-n! "not a bytevector" s))
|
||||
(let ([len ($bytevector-length s)])
|
||||
(unless (fixnum? i)
|
||||
(error 'get-bytevector-n! "starting index is not a fixnum" i))
|
||||
(when (or ($fx< i 0) ($fx> i len))
|
||||
(error 'get-bytevector-n!
|
||||
(format "starting index is out of range 0..~a" len)
|
||||
i))
|
||||
(unless (fixnum? c)
|
||||
(error 'get-bytevector-n! "count is not a fixnum" c))
|
||||
(cond
|
||||
[($fx> c 0)
|
||||
(let ([j (+ i c)])
|
||||
(when (> j len)
|
||||
(error 'get-bytevector-n!
|
||||
(format "count is out of range 0..~a" (- len i))
|
||||
c))
|
||||
(let ([x ($get-u8 p)])
|
||||
(cond
|
||||
[(eof-object? x) x]
|
||||
[else
|
||||
($bytevector-set! s i x)
|
||||
(let f ([p p] [s s] [start i] [i 1] [c c])
|
||||
(let ([x ($get-u8 p)])
|
||||
(cond
|
||||
[(eof-object? x) i]
|
||||
[else
|
||||
($bytevector-set! s ($fx+ start i) x)
|
||||
(let ([i ($fxadd1 i)])
|
||||
(if ($fx= i c)
|
||||
i
|
||||
(f p s start i c)))])))])))]
|
||||
[($fx= c 0) 0]
|
||||
[else (error 'get-bytevector-n! "count is negative" c)])))
|
||||
)
|
||||
|
|
@ -1,127 +0,0 @@
|
|||
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
|
||||
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
|
||||
;;;
|
||||
;;; This program is free software: you can redistribute it and/or modify
|
||||
;;; it under the terms of the GNU General Public License version 3 as
|
||||
;;; published by the Free Software Foundation.
|
||||
;;;
|
||||
;;; This program is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;; General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
|
||||
(library (ikarus io-primitives unsafe)
|
||||
(export $write-char
|
||||
$write-byte
|
||||
$read-char
|
||||
$get-u8
|
||||
$lookahead-u8
|
||||
$peek-char
|
||||
$reset-input-port!
|
||||
$flush-output-port
|
||||
$close-input-port
|
||||
$close-output-port
|
||||
)
|
||||
(import
|
||||
(ikarus)
|
||||
(ikarus system $ports)
|
||||
(ikarus system $strings)
|
||||
(ikarus system $chars)
|
||||
(ikarus system $bytevectors)
|
||||
(ikarus system $fx))
|
||||
|
||||
(define $write-char
|
||||
(lambda (c p)
|
||||
(let ([b ($char->fixnum c)])
|
||||
(cond
|
||||
[($fx<= b #x7F)
|
||||
($write-byte b p)]
|
||||
[($fx<= b #x7FF)
|
||||
($write-byte
|
||||
($fxlogor #b11000000 ($fxsra b 6)) p)
|
||||
($write-byte
|
||||
($fxlogor #b10000000 ($fxlogand b #b111111)) p)]
|
||||
[($fx<= b #xFFFF)
|
||||
($write-byte
|
||||
($fxlogor #b11100000 ($fxsra b 12)) p)
|
||||
($write-byte
|
||||
($fxlogor #b10000000 ($fxlogand ($fxsra b 6) #b111111)) p)
|
||||
($write-byte
|
||||
($fxlogor #b10000000 ($fxlogand b #b111111)) p)]
|
||||
[else
|
||||
($write-byte
|
||||
($fxlogor #b11110000 ($fxsra b 18)) p)
|
||||
($write-byte
|
||||
($fxlogor #b10000000 ($fxlogand ($fxsra b 12) #b111111)) p)
|
||||
($write-byte
|
||||
($fxlogor #b10000000 ($fxlogand ($fxsra b 6) #b111111)) p)
|
||||
($write-byte
|
||||
($fxlogor #b10000000 ($fxlogand b #b111111)) p)]))))
|
||||
|
||||
(define $write-byte
|
||||
(lambda (b p)
|
||||
(let ([idx (port-output-index p)])
|
||||
(if ($fx< idx ($port-size p))
|
||||
(begin
|
||||
($bytevector-set! ($port-buffer p) idx b)
|
||||
($set-port-index! p ($fxadd1 idx)))
|
||||
(($port-handler p) 'write-byte b p)))))
|
||||
|
||||
(define $read-char
|
||||
(lambda (p)
|
||||
(let ([idx ($port-index p)])
|
||||
(if ($fx< idx ($port-size p))
|
||||
(let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
|
||||
(cond
|
||||
[($fx<= b 127)
|
||||
($set-port-index! p ($fxadd1 idx))
|
||||
($fixnum->char b)]
|
||||
[else (($port-handler p) 'read-char p)]))
|
||||
(($port-handler p) 'read-char p)))))
|
||||
|
||||
(define $get-u8
|
||||
(lambda (p)
|
||||
(let ([idx ($port-index p)])
|
||||
(if ($fx< idx ($port-size p))
|
||||
(let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
|
||||
($set-port-index! p ($fxadd1 idx))
|
||||
b)
|
||||
(($port-handler p) 'get-u8 p)))))
|
||||
|
||||
(define $lookahead-u8
|
||||
(lambda (p)
|
||||
(let ([idx ($port-index p)])
|
||||
(if ($fx< idx ($port-size p))
|
||||
($bytevector-u8-ref ($port-buffer p) idx)
|
||||
(($port-handler p) 'lookahead-u8 p)))))
|
||||
|
||||
(define $peek-char
|
||||
(lambda (p)
|
||||
(let ([idx ($port-index p)])
|
||||
(if ($fx< idx ($port-size p))
|
||||
(let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
|
||||
(cond
|
||||
[($fx<= b 127)
|
||||
($fixnum->char b)]
|
||||
[else (($port-handler p) 'peek-char p)]))
|
||||
(($port-handler p) 'peek-char p)))))
|
||||
|
||||
(define $reset-input-port!
|
||||
(lambda (p)
|
||||
($set-port-size! p 0)))
|
||||
|
||||
(define $close-input-port
|
||||
(lambda (p)
|
||||
(($port-handler p) 'close-port p)))
|
||||
|
||||
(define $close-output-port
|
||||
(lambda (p)
|
||||
(($port-handler p) 'close-port p)))
|
||||
|
||||
(define $flush-output-port
|
||||
(lambda (p)
|
||||
(($port-handler p) 'flush-output-port p))))
|
|
@ -1,282 +0,0 @@
|
|||
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
|
||||
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
|
||||
;;;
|
||||
;;; This program is free software: you can redistribute it and/or modify
|
||||
;;; it under the terms of the GNU General Public License version 3 as
|
||||
;;; published by the Free Software Foundation.
|
||||
;;;
|
||||
;;; This program is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;; General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
|
||||
(library (ikarus io input-files)
|
||||
(export open-input-file
|
||||
current-input-port ; ok?
|
||||
console-input-port
|
||||
standard-input-port ; ok
|
||||
with-input-from-file
|
||||
call-with-input-file
|
||||
)
|
||||
(import
|
||||
(ikarus system $ports)
|
||||
(ikarus system $io)
|
||||
(ikarus system $fx)
|
||||
(ikarus system $strings)
|
||||
(ikarus system $bytevectors)
|
||||
(ikarus system $chars)
|
||||
(rnrs bytevectors)
|
||||
(except (ikarus)
|
||||
open-input-file current-input-port console-input-port
|
||||
with-input-from-file call-with-input-file
|
||||
standard-input-port current-input-port))
|
||||
|
||||
(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" (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" (cons tmsg targs)))]))
|
||||
(case tmsg
|
||||
[(msg-name)
|
||||
(match-and-bind targs (msg-arg* ...) (begin b b* ...))] ...
|
||||
[else else1 else2 ...]))]))
|
||||
|
||||
(define guardian (make-guardian))
|
||||
|
||||
(define close-ports
|
||||
(lambda ()
|
||||
(cond
|
||||
[(guardian) =>
|
||||
(lambda (p)
|
||||
(close-input-port p)
|
||||
(close-ports))])))
|
||||
|
||||
(define refill-buffer!
|
||||
(lambda (p bytes)
|
||||
(error 'refill-buffer! "not implemented")))
|
||||
|
||||
(define read-multibyte-char
|
||||
(lambda (p b0)
|
||||
(let ([idx ($port-index p)]
|
||||
[size ($port-size p)])
|
||||
(cond
|
||||
[($fx= ($fxlogand b0 #b11100000) #b11000000)
|
||||
;;; 2-byte utf8 sequence
|
||||
(unless ($fx< ($fx+ idx 1) size)
|
||||
(refill-buffer! p 1))
|
||||
(let ([b1 ($bytevector-u8-ref
|
||||
($port-buffer p)
|
||||
($fxadd1 idx))])
|
||||
(unless ($fx= ($fxlogand b1 #b11000000) #b10000000)
|
||||
(error 'read-char "invalid utf8 sequence" b0 b1))
|
||||
($set-port-index! p ($fx+ idx 2))
|
||||
($fixnum->char
|
||||
($fx+ ($fxsll ($fxlogand b0 #b11111) 6)
|
||||
($fxlogand b1 #b111111))))]
|
||||
[else
|
||||
(error 'read-multibyte
|
||||
"BUG: bytesequence is not supported yet" b0)]))))
|
||||
|
||||
(define peek-multibyte-char
|
||||
(lambda (p)
|
||||
(error 'peek-multibyte-char "not implemented")))
|
||||
|
||||
(define make-input-file-handler
|
||||
(lambda (fd port-name)
|
||||
(let ((open? #t))
|
||||
(lambda (msg . args)
|
||||
(message-case msg args
|
||||
[(read-char p)
|
||||
(unless (input-port? p)
|
||||
(error 'read-char "not an input port" p))
|
||||
(let ([idx ($port-index p)])
|
||||
(if ($fx< idx ($port-size p))
|
||||
(let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
|
||||
(cond
|
||||
[($fx< b 128)
|
||||
($set-port-index! p ($fxadd1 idx))
|
||||
($fixnum->char b)]
|
||||
[else (read-multibyte-char p b)]))
|
||||
(if open?
|
||||
(let ([bytes
|
||||
(foreign-call "ikrt_read"
|
||||
fd ($port-buffer p))])
|
||||
(cond
|
||||
[($fx> bytes 0)
|
||||
($set-port-size! p bytes)
|
||||
($read-char p)]
|
||||
[($fx= bytes 0)
|
||||
(eof-object)]
|
||||
[else
|
||||
(error 'read-char "Cannot read from file"
|
||||
port-name)]))
|
||||
(error 'read-char "port is closed" p))))]
|
||||
[(get-u8 p)
|
||||
(unless (input-port? p)
|
||||
(error 'get-u8 "not an input port" p))
|
||||
(let ([idx ($port-index p)])
|
||||
(if ($fx< idx ($port-size p))
|
||||
(let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
|
||||
($set-port-index! p ($fxadd1 idx))
|
||||
b)
|
||||
(if open?
|
||||
(let ([bytes
|
||||
(foreign-call "ikrt_read"
|
||||
fd ($port-buffer p))])
|
||||
(cond
|
||||
[($fx> bytes 0)
|
||||
($set-port-size! p bytes)
|
||||
($get-u8 p)]
|
||||
[($fx= bytes 0)
|
||||
(eof-object)]
|
||||
[else
|
||||
(error 'get-u8 "Cannot read from file" port-name)]))
|
||||
(error 'get-u8 "port is closed" p))))]
|
||||
[(peek-char p)
|
||||
(unless (input-port? p)
|
||||
(error 'peek-char "not an input port" p))
|
||||
(let ([idx ($port-index p)])
|
||||
(if ($fx< idx ($port-size p))
|
||||
(let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
|
||||
(cond
|
||||
[($fx< b 128) ($fixnum->char b)]
|
||||
[else (peek-multibyte-char p)]))
|
||||
(if open?
|
||||
(let ([bytes
|
||||
(foreign-call "ikrt_read" fd
|
||||
(port-input-buffer p))])
|
||||
(cond
|
||||
[(not bytes)
|
||||
(error 'peek-char
|
||||
"Cannot read from file" port-name)]
|
||||
[($fx= bytes 0)
|
||||
(eof-object)]
|
||||
[else
|
||||
($set-port-size! p bytes)
|
||||
($peek-char p)]))
|
||||
(error 'peek-char "port is closed" p))))]
|
||||
[(lookahead-u8 p)
|
||||
(unless (input-port? p)
|
||||
(error 'lookahead-u8 "not an input port" p))
|
||||
(let ([idx ($port-index p)])
|
||||
(if ($fx< idx ($port-size p))
|
||||
($bytevector-u8-ref ($port-buffer p) idx)
|
||||
(if open?
|
||||
(let ([bytes
|
||||
(foreign-call "ikrt_read" fd
|
||||
(port-input-buffer p))])
|
||||
(cond
|
||||
[(not bytes)
|
||||
(error 'lookahead-u8
|
||||
"Cannot read from file" port-name)]
|
||||
[($fx= bytes 0)
|
||||
(eof-object)]
|
||||
[else
|
||||
($bytevector-u8-ref ($port-buffer p) 0)]))
|
||||
(error 'lookahead-u8 "port is closed" p))))]
|
||||
[(port-name p) port-name]
|
||||
[(close-port p)
|
||||
(unless (input-port? p)
|
||||
(error 'close-input-port "not an input port" p))
|
||||
(when open?
|
||||
($set-port-size! p 0)
|
||||
(set! open? #f)
|
||||
(unless (foreign-call "ikrt_close_file" fd)
|
||||
(error 'close-input-port "cannot close port" port-name)))]
|
||||
[else
|
||||
(error 'input-file-handler
|
||||
"message not handled" (cons msg args))])))))
|
||||
|
||||
(define $open-input-file
|
||||
(lambda (filename)
|
||||
(close-ports)
|
||||
(let ([fd/error (foreign-call "ikrt_open_input_file"
|
||||
(string->utf8 filename))])
|
||||
(if (fixnum? fd/error)
|
||||
(let ([port (make-input-port
|
||||
(make-input-file-handler fd/error filename)
|
||||
($make-bytevector 4096))])
|
||||
(set-port-input-size! port 0)
|
||||
(guardian port)
|
||||
port)
|
||||
(error 'open-input-file "cannot open file"
|
||||
filename fd/error)))))
|
||||
|
||||
(define open-input-file
|
||||
(lambda (filename)
|
||||
(if (string? filename)
|
||||
($open-input-file filename)
|
||||
(error 'open-input-file "not a string" filename))))
|
||||
|
||||
(define with-input-from-file
|
||||
(lambda (name proc)
|
||||
(unless (string? name)
|
||||
(error 'with-input-from-file "not a string" name))
|
||||
(unless (procedure? proc)
|
||||
(error 'with-input-from-file "not a procedure" proc))
|
||||
(let ([p ($open-input-file name)])
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(parameterize ([current-input-port p])
|
||||
(proc)))
|
||||
(case-lambda
|
||||
[(v) (close-input-port p) v]
|
||||
[v*
|
||||
(close-input-port p)
|
||||
(apply values v*)])))))
|
||||
|
||||
(define call-with-input-file
|
||||
(lambda (name proc)
|
||||
(unless (string? name)
|
||||
(error 'call-with-input-file "not a string" name))
|
||||
(unless (procedure? proc)
|
||||
(error 'call-with-input-file "not a procedure" proc))
|
||||
(let ([p ($open-input-file name)])
|
||||
(call-with-values (lambda () (proc p))
|
||||
(case-lambda
|
||||
[(v) (close-input-port p) v]
|
||||
[v*
|
||||
(close-input-port p)
|
||||
(apply values v*)])))))
|
||||
|
||||
(define *standard-input-port* #f)
|
||||
(define *current-input-port* #f)
|
||||
|
||||
(define console-input-port
|
||||
(lambda () *standard-input-port*))
|
||||
|
||||
(define standard-input-port
|
||||
(lambda () *standard-input-port*))
|
||||
|
||||
(define current-input-port
|
||||
(case-lambda
|
||||
[() *current-input-port*]
|
||||
[(p)
|
||||
(if (input-port? p)
|
||||
(set! *current-input-port* p)
|
||||
(error 'current-input-port "not an input-port" p))]))
|
||||
|
||||
(set! *standard-input-port*
|
||||
(let ([p (make-input-port
|
||||
(make-input-file-handler 0 '*stdin*)
|
||||
($make-bytevector 4096))])
|
||||
(set-port-input-size! p 0)
|
||||
p))
|
||||
(set! *current-input-port* *standard-input-port*)
|
||||
)
|
|
@ -1,106 +0,0 @@
|
|||
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
|
||||
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
|
||||
;;;
|
||||
;;; This program is free software: you can redistribute it and/or modify
|
||||
;;; it under the terms of the GNU General Public License version 3 as
|
||||
;;; published by the Free Software Foundation.
|
||||
;;;
|
||||
;;; This program is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;; General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
|
||||
(library (ikarus io input-strings)
|
||||
(export open-string-input-port)
|
||||
(import
|
||||
(ikarus system $strings)
|
||||
(ikarus system $bytevectors)
|
||||
(ikarus system $fx)
|
||||
(ikarus system $pairs)
|
||||
(ikarus system $ports)
|
||||
(ikarus system $io)
|
||||
(except (ikarus) open-string-input-port ))
|
||||
|
||||
(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" (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" (cons tmsg targs)))]))
|
||||
(case tmsg
|
||||
[(msg-name)
|
||||
(match-and-bind targs (msg-arg* ...) (begin b b* ...))] ...
|
||||
[else else1 else2 ...]))]))
|
||||
|
||||
(define make-input-string-handler
|
||||
(lambda (str)
|
||||
(let ((open? #t) (idx 0) (n (string-length str)))
|
||||
(lambda (msg . args)
|
||||
(message-case msg args
|
||||
[(read-char p)
|
||||
(if ($fx< idx n)
|
||||
(let ([c ($string-ref str idx)])
|
||||
(set! idx ($fxadd1 idx))
|
||||
c)
|
||||
(if open?
|
||||
(eof-object)
|
||||
(error 'read-char "port is closed" p)))]
|
||||
[(peek-char p)
|
||||