diff --git a/lab/io-test.ss b/lab/io-test.ss
index 42d6c6f..7f5ba70 100755
--- a/lab/io-test.ss
+++ b/lab/io-test.ss
@@ -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)
diff --git a/scheme/Makefile.am b/scheme/Makefile.am
index a395263..34ea0fb 100644
--- a/scheme/Makefile.am
+++ b/scheme/Makefile.am
@@ -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)"
diff --git a/scheme/Makefile.in b/scheme/Makefile.in
index 7b94eea..a098231 100644
--- a/scheme/Makefile.in
+++ b/scheme/Makefile.in
@@ -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
diff --git a/scheme/ikarus.boot.prebuilt b/scheme/ikarus.boot.prebuilt
index c53adcd..d1a7ee9 100644
Binary files a/scheme/ikarus.boot.prebuilt and b/scheme/ikarus.boot.prebuilt differ
diff --git a/scheme/ikarus.cafe.ss b/scheme/ikarus.cafe.ss
index 411c7a5..857f49f 100644
--- a/scheme/ikarus.cafe.ss
+++ b/scheme/ikarus.cafe.ss
@@ -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)
diff --git a/scheme/ikarus.codecs.ss b/scheme/ikarus.codecs.ss
index cb886dc..296af45 100644
--- a/scheme/ikarus.codecs.ss
+++ b/scheme/ikarus.codecs.ss
@@ -142,5 +142,6 @@
(f (cdr ls) (fxlogor (cdr a) n)))]
[else #f])))
+
)
diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss
index 8c5e1db..768e7b7 100644
--- a/scheme/ikarus.compiler.ss
+++ b/scheme/ikarus.compiler.ss
@@ -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)
diff --git a/scheme/ikarus.conditions.ss b/scheme/ikarus.conditions.ss
index 8122d2b..89c8d7f 100644
--- a/scheme/ikarus.conditions.ss
+++ b/scheme/ikarus.conditions.ss
@@ -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)
diff --git a/scheme/ikarus.fasl.write.ss b/scheme/ikarus.fasl.write.ss
index 0624aab..a313521 100644
--- a/scheme/ikarus.fasl.write.ss
+++ b/scheme/ikarus.fasl.write.ss
@@ -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)
diff --git a/scheme/ikarus.handlers.ss b/scheme/ikarus.handlers.ss
index 9bf218c..df37728 100644
--- a/scheme/ikarus.handlers.ss
+++ b/scheme/ikarus.handlers.ss
@@ -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)
diff --git a/scheme/ikarus.io-ports.ss b/scheme/ikarus.io-ports.ss
deleted file mode 100644
index f1578ea..0000000
--- a/scheme/ikarus.io-ports.ss
+++ /dev/null
@@ -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 .
-
-
-(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)))
-
- )
-
-
-
diff --git a/scheme/ikarus.io-primitives.ss b/scheme/ikarus.io-primitives.ss
deleted file mode 100644
index 0eb8778..0000000
--- a/scheme/ikarus.io-primitives.ss
+++ /dev/null
@@ -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 .
-
-
-(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)])))
- )
-
diff --git a/scheme/ikarus.io-primitives.unsafe.ss b/scheme/ikarus.io-primitives.unsafe.ss
deleted file mode 100644
index 9d10124..0000000
--- a/scheme/ikarus.io-primitives.unsafe.ss
+++ /dev/null
@@ -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 .
-
-
-(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))))
diff --git a/scheme/ikarus.io.input-files.ss b/scheme/ikarus.io.input-files.ss
deleted file mode 100644
index a5f783e..0000000
--- a/scheme/ikarus.io.input-files.ss
+++ /dev/null
@@ -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 .
-
-
-(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*)
- )
diff --git a/scheme/ikarus.io.input-strings.ss b/scheme/ikarus.io.input-strings.ss
deleted file mode 100644
index 2a2c707..0000000
--- a/scheme/ikarus.io.input-strings.ss
+++ /dev/null
@@ -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 .
-
-
-(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)
- (if ($fx< idx n)
- ($string-ref str idx)
- (if open?
- (eof-object)
- (error 'peek-char "port is closed" p)))]
- [(port-name p) '*string-port*]
- [(close-port p)
- (when open?
- (set! open? #f))]
- [else
- (error 'input-string-handler
- "message not handled" (cons msg args))])))))
-
- (define ($open-input-string str)
- (let ([port (make-input-port
- (make-input-string-handler str)
- '#vu8())])
- port))
-
- ;(define open-input-string
- ; (lambda (str)
- ; (unless (string? str)
- ; (error 'open-input-string "not a string" str))
- ; ($open-input-string str)))
-
- (define open-string-input-port
- (lambda (str)
- (unless (string? str)
- (error 'open-string-input-port "not a string" str))
- ($open-input-string str)))
-
- ;(define with-input-from-string
- ; (lambda (str proc)
- ; (unless (string? str)
- ; (error 'with-input-from-string "not a string" str))
- ; (unless (procedure? proc)
- ; (error 'with-input-from-string "not a procedure" proc))
- ; (let ([p ($open-input-string str)])
- ; (parameterize ([current-input-port p])
- ; (proc)))))
-
- )
-
diff --git a/scheme/ikarus.io.output-bytevectors.ss b/scheme/ikarus.io.output-bytevectors.ss
deleted file mode 100644
index 7c4cdf9..0000000
--- a/scheme/ikarus.io.output-bytevectors.ss
+++ /dev/null
@@ -1,200 +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 .
-
-
-(library (ikarus io output-bytevectors)
- (export open-output-bytevector get-output-bytevector
- with-output-to-bytevector open-bytevector-output-port
- call-with-bytevector-output-port)
- (import
- (ikarus system $bytevectors)
- (ikarus system $chars)
- (ikarus system $fx)
- (ikarus system $pairs)
- (ikarus system $ports)
- (ikarus system $io)
- (except (ikarus)
- open-output-bytevector get-output-bytevector
- with-output-to-bytevector open-bytevector-output-port
- call-with-bytevector-output-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 concat
- (lambda (bv i ls)
- (let ([n (sum i ls)])
- (let ([outbv ($make-bytevector n)])
- (let f ([n (copy outbv bv i n)] [ls ls])
- (if (null? ls)
- outbv
- (let ([a ($car ls)])
- (f (copy outbv a ($bytevector-length a) n) ($cdr ls)))))))))
- (define sum
- (lambda (ac ls)
- (cond
- [(null? ls) ac]
- [else (sum ($fx+ ac ($bytevector-length ($car ls))) ($cdr ls))])))
-
-
- (define copy
- (lambda (dst src n end)
- (let f ([di end]
- [si n])
- (cond
- [($fx= si 0) di]
- [else
- (let ([di ($fxsub1 di)] [si ($fxsub1 si)])
- ($bytevector-set! dst di ($bytevector-u8-ref src si))
- (f di si))]))))
-
- (define bv-copy
- (lambda (src)
- (let ([n ($bytevector-length src)])
- (let f ([src src] [dst ($make-bytevector n)] [i 0] [n n])
- (cond
- [($fx= i n) dst]
- [else
- ($bytevector-set! dst i ($bytevector-u8-ref src i))
- (f src dst ($fxadd1 i) n)])))))
-
-
-
- (define make-output-bytevector-handler
- (lambda ()
- (define buffer-list '())
- (define open? #t)
- (define output-handler
- (lambda (msg . args)
- (message-case msg args
- [(write-byte b p)
- (if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
- (if (output-port? p)
- (let ([idx ($port-index p)])
- (if ($fx< idx ($port-size p))
- (begin
- ($bytevector-set! ($port-buffer p) idx b)
- ($set-port-index! p ($fxadd1 idx)))
- (if open?
- (let ([buff ($port-buffer p)])
- (set! buffer-list (cons (bv-copy buff) buffer-list))
- ($bytevector-set! buff 0 b)
- ($set-port-index! p 1))
- (error 'write-byte "port is closed" p))))
- (error 'write-byte "not an output-port" p))
- (error 'write-byte "not a byte" b))]
- [(write-char c p)
- (if (char? c)
- (if (output-port? p)
- (let ([b ($char->fixnum c)])
- (if ($fx<= b 127)
- ($write-byte b p)
- (error 'write-char
- "BUG: multibyte write of is not implemented" c)))
- (error 'write-char "not an output-port" p))
- (error 'write-char "not a character" c))]
- [(flush-output-port p)
- (void)]
- [(close-port p)
- (set! open? #f)]
- [(port-name p) 'bytevector-port]
- [(get-output-bytevector p)
- (concat
- ($port-buffer p)
- ($port-index p)
- buffer-list)]
- [(reset-port p)
- ($set-port-index! p 0)
- (set! buffer-list '())]
- [else
- (error 'bytevector-output-handler
- "unhandled message" (cons msg args))])))
- output-handler))
-
- (define open-output-bytevector
- (lambda ()
- (make-output-port
- (make-output-bytevector-handler)
- ($make-bytevector 59))))
-
- (define get-output-bytevector
- (lambda (p)
- (if (output-port? p)
- (($port-handler p) 'get-output-bytevector p)
- (error 'get-output-bytevector "not an output port" p))))
-
- (define with-output-to-bytevector
- (lambda (f)
- (unless (procedure? f)
- (error 'with-output-to-bytevector "not a procedure" f))
- (let ([p (open-output-bytevector)])
- (parameterize ([current-output-port p]) (f))
- (get-output-bytevector p))))
-
- (define open-bytevector-output-port
- (case-lambda
- [()
- (let ([p (open-output-bytevector)])
- ;;; FIXME: should empty string
- (values p
- (lambda ()
- (let ([x (get-output-bytevector p)])
- (($port-handler p) 'reset-port p)
- x))))]
- [(transcoder)
- (if (not transcoder)
- (open-bytevector-output-port)
- (error 'open-bytevector-output-port
- (format "BUG: transcoder (~s) is not supported"
- transcoder)))]))
-
- (define call-with-bytevector-output-port
- (let ([who 'call-with-bytevector-output-port])
- (case-lambda
- [(proc)
- (unless (procedure? proc)
- (error who "not a procedure" proc))
- (let ([p (open-output-bytevector)])
- (proc p) ;;; why is this useful again?
- (let ([bv (get-output-bytevector p)])
- (close-output-port p)
- bv))]
- [(proc transcoder)
- (if (not transcoder)
- (call-with-bytevector-output-port proc)
- (error who
- (format "BUG: transcoder (~s) is not supported"
- transcoder)))])))
-
-)
diff --git a/scheme/ikarus.io.output-files.ss b/scheme/ikarus.io.output-files.ss
deleted file mode 100644
index f8f1bcf..0000000
--- a/scheme/ikarus.io.output-files.ss
+++ /dev/null
@@ -1,237 +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 .
-
-
-(library (ikarus io output-files)
- (export standard-output-port standard-error-port
- console-output-port current-output-port current-error-port
- open-output-file with-output-to-file call-with-output-file)
- (import
- (ikarus system $ports)
- (ikarus system $io)
- (ikarus system $strings)
- (ikarus system $chars)
- (ikarus system $bytevectors)
- (ikarus system $fx)
- (rnrs bytevectors)
- (except (ikarus)
- standard-output-port standard-error-port
- console-output-port current-output-port current-error-port
- open-output-file with-output-to-file call-with-output-file))
-
- (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-output-port p)
- (close-ports))])))
-
- (define do-write-buffer
- (lambda (fd port-name buff idx caller)
- (let ([bytes (foreign-call "ikrt_write_file" fd buff idx)])
- (if (fixnum? bytes)
- bytes
- (error caller "cannot write to file" port-name bytes)))))
-
- (define make-output-file-handler
- (lambda (fd port-name)
- (define open? #t)
- (define output-file-handler
- (lambda (msg . args)
- (message-case msg args
- [(write-byte b p)
- (if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
- (if (output-port? p)
- (let ([idx ($port-index p)])
- (if ($fx< idx ($port-size p))
- (begin
- ($bytevector-set! ($port-buffer p) idx b)
- ($set-port-index! p ($fxadd1 idx)))
- (if open?
- (let ([bytes (do-write-buffer fd port-name
- ($port-buffer p) idx 'write-char)])
- ($set-port-index! p 0)
- ($write-byte b p))
- (error 'write-byte "port is closed" p))))
- (error 'write-byte "not an output-port" p))
- (error 'write-byte "not a byte" b))]
- [(write-char c p)
- (if (char? c)
- (if (output-port? p)
- (let ([b ($char->fixnum c)])
- (if ($fx<= b 255)
- ($write-byte b p)
- (error 'write-char
- "BUG: multibyte write of not implemented" c)))
- (error 'write-char "not an output-port" p))
- (error 'write-char "not a character" c))]
- [(flush-output-port p)
- (if (output-port? p)
- (if open?
- (let ([bytes (do-write-buffer fd port-name
- ($port-buffer p)
- ($port-index p)
- 'flush-output-port)])
- ($set-port-index! p 0))
- (error 'flush-output-port "port is closed" p))
- (error 'flush-output-port "not an output-port" p))]
- [(close-port p)
- (when open?
- (flush-output-port p)
- ($set-port-size! p 0)
- (set! open? #f)
- (unless (foreign-call "ikrt_close_file" fd)
- (error 'close-output-port "cannot close" port-name)))]
- [(port-name p) port-name]
- [else (error 'output-file-handler
- "unhandled message" (cons msg args))])))
- output-file-handler))
- (define (option-id x)
- (case x
- [(error) 0]
- [(replace) 1]
- [(truncate) 2]
- [(append) 3]
- [else (error 'open-output-file "not a valid mode" x)]))
-
- (define $open-output-file
- (lambda (filename options)
- (close-ports)
- (let ([fd/error
- (foreign-call "ikrt_open_output_file"
- (string->utf8 filename)
- (option-id options))])
- (if (fixnum? fd/error)
- (let ([port
- (make-output-port
- (make-output-file-handler fd/error filename)
- ($make-bytevector 4096))])
- (guardian port)
- port)
- (error 'open-output-file "cannot open file" filename fd/error)))))
-
- (define *standard-output-port* #f)
-
- (define *standard-error-port* #f)
-
- (define *current-output-port* #f)
- (define *current-error-port* #f)
-
- (define standard-output-port
- (lambda () *standard-output-port*))
-
- (define standard-error-port
- (lambda () *standard-error-port*))
-
- (define console-output-port
- (lambda () *standard-output-port*))
-
- (define current-output-port
- (case-lambda
- [() *current-output-port*]
- [(p)
- (if (output-port? p)
- (set! *current-output-port* p)
- (error 'current-output-port "not an output port" p))]))
-
- (define current-error-port
- (case-lambda
- [() *current-error-port*]
- [(p)
- (if (output-port? p)
- (set! *current-error-port* p)
- (error 'current-error-port "not an error port" p))]))
-
- (define open-output-file
- (case-lambda
- [(filename)
- (if (string? filename)
- ($open-output-file filename 'error)
- (error 'open-output-file "not a string" filename))]
- [(filename options)
- (if (string? filename)
- ($open-output-file filename options)
- (error 'open-output-file "not a string" filename))]))
-
- (define with-output-to-file
- (lambda (name proc . args)
- (unless (string? name)
- (error 'with-output-to-file "not a string" name))
- (unless (procedure? proc)
- (error 'with-output-to-file "not a procedure" proc))
- (let ([p (apply open-output-file name args)]
- [shot #f])
- (call-with-values
- (lambda ()
- (parameterize ([current-output-port p])
- (proc)))
- (case-lambda
- [(v) (close-output-port p) v]
- [v*
- (close-output-port p)
- (apply values v*)])))))
-
- (define call-with-output-file
- (lambda (name proc . args)
- (unless (string? name)
- (error 'call-with-output-file "not a string" name))
- (unless (procedure? proc)
- (error 'call-with-output-file "not a procedure" proc))
- (let ([p (apply open-output-file name args)])
- (call-with-values (lambda () (proc p))
- (case-lambda
- [(v) (close-output-port p) v]
- [v*
- (close-output-port p)
- (apply values v*)])))))
-
- (set! *standard-output-port*
- (make-output-port
- (make-output-file-handler 1 '*stdout*)
- ($make-bytevector 4096)))
- (set! *current-output-port* *standard-output-port*)
- (set! *standard-error-port*
- (make-output-port
- (make-output-file-handler 2 '*stderr*)
- ($make-bytevector 4096)))
- (set! *current-error-port* *standard-error-port*)
-
-
- )
diff --git a/scheme/ikarus.io.output-strings.ss b/scheme/ikarus.io.output-strings.ss
deleted file mode 100644
index 61c1a86..0000000
--- a/scheme/ikarus.io.output-strings.ss
+++ /dev/null
@@ -1,192 +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 .
-
-
-(library (ikarus io output-strings)
- (export open-output-string get-output-string with-output-to-string
- open-string-output-port)
- (import
- (ikarus system $strings)
- (ikarus system $bytevectors)
- (ikarus system $chars)
- (ikarus system $fx)
- (ikarus system $pairs)
- (ikarus system $ports)
- (ikarus system $io)
- (except (ikarus) open-output-string get-output-string with-output-to-string
- open-string-output-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 concat-old
- (lambda (str i ls)
- (let ([n (sum i ls)])
- (let ([outstr (make-string n)])
- (let f ([n (copy outstr str i n)] [ls ls])
- (if (null? ls)
- outstr
- (let ([a ($car ls)])
- (f (copy outstr a (string-length a) n) ($cdr ls)))))))))
-
- (define concat
- (lambda (bv i ls)
- (let ([n (sum i ls)])
- (let ([outbv ($make-bytevector n)])
- (let f ([n (copy outbv bv i n)] [ls ls])
- (if (null? ls)
- outbv
- (let ([a ($car ls)])
- (f (copy outbv a ($bytevector-length a) n) ($cdr ls)))))))))
- (define sum
- (lambda (ac ls)
- (cond
- [(null? ls) ac]
- [else (sum ($fx+ ac ($bytevector-length ($car ls))) ($cdr ls))])))
-
- (define sum-old
- (lambda (ac ls)
- (cond
- [(null? ls) ac]
- [else (sum ($fx+ ac (string-length ($car ls))) ($cdr ls))])))
-
- (define copy-old
- (lambda (dst src n end)
- (let f ([di end]
- [si n])
- (cond
- [($fx= si 0) di]
- [else
- (let ([di ($fxsub1 di)] [si ($fxsub1 si)])
- (string-set! dst di (string-ref src si))
- (f di si))]))))
-
- (define copy
- (lambda (dst src n end)
- (let f ([di end]
- [si n])
- (cond
- [($fx= si 0) di]
- [else
- (let ([di ($fxsub1 di)] [si ($fxsub1 si)])
- ($bytevector-set! dst di ($bytevector-u8-ref src si))
- (f di si))]))))
-
- (define bv-copy
- (lambda (src)
- (let ([n ($bytevector-length src)])
- (let f ([src src] [dst ($make-bytevector n)] [i 0] [n n])
- (cond
- [($fx= i n) dst]
- [else
- ($bytevector-set! dst i ($bytevector-u8-ref src i))
- (f src dst ($fxadd1 i) n)])))))
-
-
-
- (define make-output-string-handler
- (lambda ()
- (define buffer-list '())
- (define open? #t)
- (define output-handler
- (lambda (msg . args)
- (message-case msg args
- [(write-byte b p)
- (if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
- (if (output-port? p)
- (let ([idx ($port-index p)])
- (if ($fx< idx ($port-size p))
- (begin
- ($bytevector-set! ($port-buffer p) idx b)
- ($set-port-index! p ($fxadd1 idx)))
- (if open?
- (let ([buff ($port-buffer p)])
- (set! buffer-list (cons (bv-copy buff) buffer-list))
- ($bytevector-set! buff 0 b)
- ($set-port-index! p 1))
- (error 'write-byte "port is closed" p))))
- (error 'write-byte "not an output-port" p))
- (error 'write-byte "not a byte" b))]
- [(write-char c p)
- (if (char? c)
- (if (output-port? p)
- (let ([b ($char->fixnum c)])
- (if ($fx<= b 127)
- ($write-byte b p)
- (error 'write-char
- "BUG: multibyte write of is not implemented" c)))
- (error 'write-char "not an output-port" p))
- (error 'write-char "not a character" c))]
- [(flush-output-port p)
- (void)]
- [(close-port p)
- (set! open? #f)]
- [(port-name p) 'string-port]
- [(get-output-string p)
- (utf8->string
- (concat
- ($port-buffer p)
- ($port-index p)
- buffer-list))]
- [else
- (error 'output-handler "unhandled message" (cons msg args))])))
- output-handler))
-
- (define open-output-string
- (lambda ()
- (make-output-port
- (make-output-string-handler)
- ($make-bytevector 59))))
-
- (define get-output-string
- (lambda (p)
- (if (output-port? p)
- (($port-handler p) 'get-output-string p)
- (error 'get-output-string "not an output port" p))))
-
- (define with-output-to-string
- (lambda (f)
- (unless (procedure? f)
- (error 'with-output-to-string "not a procedure" f))
- (let ([p (open-output-string)])
- (parameterize ([current-output-port p]) (f))
- (get-output-string p))))
-
- (define (open-string-output-port)
- (let ([p (open-output-string)])
- ;;; FIXME: should empty string
- (values p (lambda () (get-output-string p)))))
-
-
-)
diff --git a/lab/io-spec.ss b/scheme/ikarus.io.ss
similarity index 69%
rename from lab/io-spec.ss
rename to scheme/ikarus.io.ss
index 0fff140..d60000f 100644
--- a/lab/io-spec.ss
+++ b/scheme/ikarus.io.ss
@@ -21,6 +21,23 @@
;port-has-set-port-position!? set-port-position!
call-with-port
flush-output-port
+ put-u8
+ put-char write-char
+ put-string
+ open-bytevector-output-port
+ call-with-bytevector-output-port
+ open-string-output-port
+ call-with-string-output-port
+ standard-output-port standard-error-port
+ current-output-port current-error-port
+ open-file-output-port
+ console-output-port
+ console-input-port
+ newline
+ input-port-name
+ output-port-name
+ port-mode set-port-mode!
+ reset-input-port!
)
@@ -45,6 +62,23 @@
;port-has-set-port-position!? set-port-position!
call-with-port
flush-output-port
+ put-u8
+ put-char write-char
+ put-string
+ open-bytevector-output-port
+ call-with-bytevector-output-port
+ open-string-output-port
+ call-with-string-output-port
+ standard-output-port standard-error-port
+ current-output-port current-error-port
+ open-file-output-port
+ console-output-port
+ console-input-port
+ newline
+ input-port-name
+ output-port-name
+ port-mode set-port-mode!
+ reset-input-port!
))
(define-syntax define-rrr
@@ -123,6 +157,17 @@
(fxior fast-get-tag fast-get-latin-tag)]
[else 0]))
+ (define (output-transcoder-attrs x)
+ (cond
+ [(not x) ;;; binary input port
+ (fxior fast-put-tag fast-put-byte-tag)]
+ [(and (eq? 'latin-1-codec (transcoder-codec x))
+ (eq? 'none (transcoder-eol-style x)))
+ (fxior fast-put-tag fast-put-latin-tag)]
+ [(and (eq? 'utf-8-codec (transcoder-codec x))
+ (eq? 'none (transcoder-eol-style x)))
+ (fxior fast-put-tag fast-put-utf8-tag)]
+ [else 0]))
(define open-bytevector-input-port
(case-lambda
@@ -147,6 +192,111 @@
#f ;;; close
)]))
+ (define open-bytevector-output-port
+ (case-lambda
+ [() (open-bytevector-output-port #f)]
+ [(transcoder)
+ (define who 'open-bytevector-output-port)
+ (unless (or (not transcoder) (transcoder? transcoder))
+ (error who "invalid transcoder value" transcoder))
+ (let ([buf* '()] [buffer-size 256])
+ (let ([p
+ ($make-port 0 buffer-size (make-bytevector buffer-size) 0
+ transcoder
+ #f
+ (output-transcoder-attrs transcoder)
+ "*bytevector-output-port*"
+ #f
+ (lambda (bv i c)
+ (unless (= c 0)
+ (let ([x (make-bytevector c)])
+ (bytevector-copy! bv i x 0 c)
+ (set! buf* (cons x buf*))))
+ c)
+ #f ;;; FIXME: get-position
+ #f ;;; FIXME: set-position!
+ #f)])
+ (values
+ p
+ (lambda ()
+ (define (append-bv-buf* ls)
+ (let f ([ls ls] [i 0])
+ (cond
+ [(null? ls)
+ (values (make-bytevector i) 0)]
+ [else
+ (let* ([a (car ls)]
+ [n (bytevector-length a)])
+ (let-values ([(bv i) (f (cdr ls) (fx+ i n))])
+ (bytevector-copy! a 0 bv i n)
+ (values bv (fx+ i n))))])))
+ (unless ($port-closed? p)
+ (flush-output-port p))
+ (let-values ([(bv len) (append-bv-buf* buf*)])
+ (set! buf* '())
+ bv)))))]))
+
+ (define call-with-bytevector-output-port
+ (case-lambda
+ [(proc) (call-with-bytevector-output-port proc #f)]
+ [(proc transcoder)
+ (define who 'call-with-bytevector-output-port)
+ (unless (procedure? proc)
+ (error who "not a procedure" proc))
+ (unless (or (not transcoder) (transcoder? transcoder))
+ (error who "invalid transcoder argument" transcoder))
+ (let-values ([(p extract)
+ (open-bytevector-output-port transcoder)])
+ (proc p)
+ (extract))]))
+
+ (define (call-with-string-output-port proc)
+ (define who 'call-with-string-output-port)
+ (unless (procedure? proc)
+ (error who "not a procedure" proc))
+ (let-values ([(p extract) (open-string-output-port)])
+ (proc p)
+ (extract)))
+
+ (define (open-string-output-port)
+ (define who 'open-string-output-port)
+ (let ([buf* '()] [buffer-size 256])
+ (let ([p
+ ($make-port 0 buffer-size (make-string buffer-size) 0
+ #t ;;; transcoder
+ #f
+ (fxior fast-put-tag fast-put-char-tag)
+ "*string-output-port*"
+ #f
+ (lambda (str i c)
+ (unless (= c 0)
+ (let ([x (make-string c)])
+ (string-copy! str i x 0 c)
+ (set! buf* (cons x buf*))))
+ c)
+ #f ;;; FIXME: get-position
+ #f ;;; FIXME: set-position!
+ #f)])
+ (values
+ p
+ (lambda ()
+ (define (append-str-buf* ls)
+ (let f ([ls ls] [i 0])
+ (cond
+ [(null? ls)
+ (values (make-string i) 0)]
+ [else
+ (let* ([a (car ls)]
+ [n (string-length a)])
+ (let-values ([(bv i) (f (cdr ls) (fx+ i n))])
+ (string-copy! a 0 bv i n)
+ (values bv (fx+ i n))))])))
+ (unless ($port-closed? p)
+ (flush-output-port p))
+ (let-values ([(bv len) (append-str-buf* buf*)])
+ (set! buf* '())
+ bv))))))
+
(define (open-string-input-port str)
(unless (string? str)
(error 'open-string-input-port str))
@@ -170,6 +320,7 @@
(unless ($port? p) (error who "not a port" p))
(when ($port-transcoder p) (error who "not a binary port" p))
(let ([read! ($port-read! p)]
+ [write! ($port-write! p)]
[closed? ($port-closed? p)])
($set-port-closed?! p #t)
($make-port
@@ -179,15 +330,19 @@
($port-base-index p)
transcoder
closed?
- (if read! (input-transcoder-attrs transcoder) 0)
+ (cond
+ [read! (input-transcoder-attrs transcoder)]
+ [write! (output-transcoder-attrs transcoder)]
+ [else
+ (error 'transcoded-port
+ "port is neither input nor output!")])
($port-id p)
read!
- ($port-write! p)
+ write!
($port-get-position p)
($port-set-position! p)
($port-close p))))
-
(define (output-port? p)
(and ($port? p)
($port-write! p)
@@ -198,6 +353,21 @@
($port-read! p)
#t))
+ (define (reset-input-port! p)
+ (if (input-port? p)
+ ($set-port-index! p ($port-size p))
+ (error 'reset-input-port! "not an input port" p)))
+
+ (define (input-port-name p)
+ (if (input-port? p)
+ ($port-id p)
+ (error 'input-port-name "not an input port" p)))
+
+ (define (output-port-name p)
+ (if (output-port? p)
+ ($port-id p)
+ (error 'output-port-name "not an output port" p)))
+
(define (textual-port? p)
(and ($port? p)
($port-transcoder p)
@@ -213,22 +383,51 @@
(and (transcoder? tr) tr))
(error 'port-transcoder "not a port" p)))
- (define (flush-output-port p)
- (unless (output-port? p)
- (error 'flush-output-port "not an output port" p))
- (when ($port-closed? p)
- (error 'flush-output-port "port is closed" p))
- (let ([idx ($port-index p)] [size ($port-size p)])
- (unless (fx= idx size)
- (let ([cnt (fx- size idx)])
- (let ([bytes (($port-write! p) ($port-buffer p) idx cnt)])
- (unless (and (fixnum? bytes) (fx>= bytes 0) (fx<= bytes cnt))
- (error 'flush-output-port
- "write! returned an invalid value"
- bytes))
- ($set-port-index! p (fx+ idx bytes))
- (unless (fx= bytes cnt)
- (flush-output-port p)))))))
+ (define (port-mode p)
+ (if ($port? p)
+ (if (fxzero? (fxand ($port-attrs p) r6rs-mode-tag))
+ 'ikarus-mode
+ 'r6rs-mode)
+ (error 'port-mode "not a port" p)))
+
+ (define (set-port-mode! p mode)
+ (if ($port? p)
+ (case mode
+ [(r6rs-mode)
+ ($set-port-attrs! p
+ (fxior ($port-attrs p) r6rs-mode-tag))]
+ [(ikarus-mode)
+ ($set-port-attrs! p
+ (fxand ($port-attrs p) (fxnot r6rs-mode-tag)))]
+ [else (error 'set-port-mode! "invalid mode" mode)])
+ (error 'set-port-mode! "not a port" p)))
+
+
+ (define flush-output-port
+ (case-lambda
+ [() (flush-output-port (*the-output-port*))]
+ [(p)
+ (unless (output-port? p)
+ (error 'flush-output-port "not an output port" p))
+ (when ($port-closed? p)
+ (error 'flush-output-port "port is closed" p))
+ (let ([idx ($port-index p)]
+ [buf ($port-buffer p)])
+ (unless (fx= idx 0)
+ (let ([bytes (($port-write! p) buf 0 idx)])
+ (unless (and (fixnum? bytes) (fx>= bytes 0) (fx<= bytes idx))
+ (error 'flush-output-port
+ "write! returned an invalid value"
+ bytes))
+ (cond
+ [(fx= bytes idx)
+ ($set-port-index! p 0)]
+ [(fx= bytes 0)
+ (error 'flush-output-port "could not write bytes to sink")]
+ [else
+ (bytevector-copy! buf bytes buf 0 (fx- idx bytes))
+ ($set-port-index! p (fx- idx bytes))
+ (flush-output-port p)]))))]))
(define ($close-port p)
(cond
@@ -741,11 +940,11 @@
(define (io-error who id err)
(let ([msg
- (let ([err (- err)])
+ (let ([err (fxnot err)])
(cond
[(fx< err (vector-length io-errors-vec))
- "unknown error"]
- [else (vector-ref io-errors-vec err)]))])
+ (vector-ref io-errors-vec err)]
+ [else "unknown error"]))])
(raise
(condition
(make-who-condition who)
@@ -777,13 +976,52 @@
(lambda (err)
(io-error 'close id err))])))))
- (define (open-file-handle filename who)
+ (define (fh->output-port fd id size transcoder close?)
+ ($make-port 0 size (make-bytevector size) 0
+ transcoder
+ #f ;;; closed?
+ (output-transcoder-attrs transcoder)
+ id
+ #f
+ (lambda (bv idx cnt)
+ (let ([bytes
+ (foreign-call "ikrt_write_fd" fd bv idx
+ (fxmin read-size cnt))])
+ (when (fx< bytes 0) (io-error 'write id bytes))
+ bytes))
+ #f ;;; get-position
+ #f ;;; set-position!
+ (and close?
+ (lambda ()
+ (cond
+ [(foreign-call "ikrt_close_fd" fd) =>
+ (lambda (err)
+ (io-error 'close id err))])))))
+
+ (define (open-input-file-handle filename who)
(let ([fh (foreign-call "ikrt_open_input_fd"
(string->utf8 filename))])
(cond
[(fx< fh 0) (io-error who filename fh)]
[else fh])))
+ (define (open-output-file-handle filename file-options who)
+ (let ([opt (case file-options
+ [(fo:default) 0]
+ [(fo:no-create) 1]
+ [(fo:no-fail) 2]
+ [(fo:no-fail/no-create) 3]
+ [(fo:no-truncate) 4]
+ [(fo:no-truncate/no-create) 5]
+ [(fo:no-truncate/no-fail) 6]
+ [(fo:no-truncate/no-fail/no-create) 7]
+ [else (error who "invalid file option" file-options)])])
+ (let ([fh (foreign-call "ikrt_open_output_fd"
+ (string->utf8 filename)
+ opt)])
+ (cond
+ [(fx< fh 0) (io-error who filename fh)]
+ [else fh]))))
(define open-file-input-port
(case-lambda
@@ -796,25 +1034,46 @@
[(filename file-options buffer-mode transcoder)
(unless (string? filename)
(error 'open-file-input-port "invalid filename" filename))
+ (unless (or (not transcoder) (transcoder? transcoder))
+ (error 'open-file-input-port "invalid transcoder" transcoder))
; FIXME: file-options ignored
; FIXME: buffer-mode ignored
(fh->input-port
- (open-file-handle filename 'open-file-input-port)
+ (open-input-file-handle filename 'open-file-input-port)
filename
file-buffer-size
- (cond
- [(or (not transcoder) (transcoder? transcoder))
- transcoder]
- [else (error 'open-file-input-port
- "invalid transcoder"
- transcoder)])
+ transcoder
+ #t)]))
+
+
+ (define open-file-output-port
+ (case-lambda
+ [(filename)
+ (open-file-output-port filename (file-options) 'block #f)]
+ [(filename file-options)
+ (open-file-output-port filename file-options 'block #f)]
+ [(filename file-options buffer-mode)
+ (open-file-output-port filename file-options buffer-mode #f)]
+ [(filename file-options buffer-mode transcoder)
+ (unless (string? filename)
+ (error 'open-file-output-port "invalid filename" filename))
+ ; FIXME: file-options ignored
+ ; FIXME: buffer-mode ignored
+ (unless (or (not transcoder) (transcoder? transcoder))
+ (error 'open-file-output-port "invalid transcoder" transcoder))
+ (fh->output-port
+ (open-output-file-handle filename file-options
+ 'open-file-output-port)
+ filename
+ file-buffer-size
+ transcoder
#t)]))
(define (open-input-file filename)
(unless (string? filename)
(error 'open-input-file "invalid filename" filename))
(fh->input-port
- (open-file-handle filename 'open-input-file)
+ (open-input-file-handle filename 'open-input-file)
filename
file-buffer-size
(native-transcoder)
@@ -827,7 +1086,7 @@
(error 'call-with-input-file "not a procedure" proc))
(call-with-port
(fh->input-port
- (open-file-handle filename 'call-with-input-file)
+ (open-input-file-handle filename 'call-with-input-file)
filename
file-buffer-size
(native-transcoder)
@@ -841,7 +1100,7 @@
(error 'with-input-from-file "not a procedure" proc))
(let ([p
(fh->input-port
- (open-file-handle filename 'with-input-from-file)
+ (open-input-file-handle filename 'with-input-from-file)
filename
file-buffer-size
(native-transcoder)
@@ -852,11 +1111,35 @@
(define (standard-input-port)
(fh->input-port 0 '*stdin* 256 #f #f))
+ (define (standard-output-port)
+ (fh->output-port 1 '*stdout* 256 #f #f))
+
+ (define (standard-error-port)
+ (fh->output-port 2 '*stderr* 256 #f #f))
+
(define *the-input-port*
(make-parameter
(transcoded-port (standard-input-port) (native-transcoder))))
+ (define *the-output-port*
+ (make-parameter
+ (transcoded-port (standard-output-port) (native-transcoder))))
+
+ (define *the-error-port*
+ (make-parameter
+ (transcoded-port (standard-error-port) (native-transcoder))))
+
+ (define console-output-port
+ (let ([p (*the-output-port*)])
+ (lambda () p)))
+
+ (define console-input-port
+ (let ([p (*the-input-port*)])
+ (lambda () p)))
+
(define (current-input-port) (*the-input-port*))
+ (define (current-output-port) (*the-output-port*))
+ (define (current-error-port) (*the-error-port*))
(define (call-with-port p proc)
(if ($port? p)
@@ -1106,24 +1389,115 @@
(error 'get-string-all "not a textual port" p))
(error 'get-string-all "not an input port" p)))
- )
-
-#!eof
-
;;; ----------------------------------------------------------
- ;;; do input ports first.
- ;;; ----------------------------------------------------------
- (module (put-char)
- (define-rrr put-char-utf8-mode)
- (define-rrr put-char-latin-mode)
- (define-rrr put-char-char-mode)
- (define-rrr slow-put-char)
+ (module (put-char write-char put-string)
+ (define (put-char-utf8-mode p b who)
+ (cond
+ [(fx< b 128)
+ (flush-output-port p)
+ (let ([i ($port-index p)] [j ($port-size p)])
+ (cond
+ [(fx< i j)
+ (bytevector-u8-set! ($port-buffer p) i b)
+ ($set-port-index! p (fx+ i 1))]
+ [else
+ (error who "insufficient space on port" p)]))]
+ [(fx<= b #x7FF)
+ (let ([i ($port-index p)]
+ [j ($port-size p)]
+ [buf ($port-buffer p)])
+ (cond
+ [(fx< (fx+ i 1) j)
+ (bytevector-u8-set! buf i
+ (fxior #b11000000 (fxsra b 6)))
+ (bytevector-u8-set! buf (fx+ i 1)
+ (fxior #b10000000 (fxand b #b111111)))
+ ($set-port-index! p (fx+ i 2))]
+ [else
+ (flush-output-port p)
+ (put-char-utf8-mode p b who)]))]
+ [(fx<= b #xFFFF)
+ (let ([i ($port-index p)]
+ [j ($port-size p)]
+ [buf ($port-buffer p)])
+ (cond
+ [(fx< (fx+ i 2) j)
+ (bytevector-u8-set! buf i
+ (fxior #b11100000 (fxsra b 12)))
+ (bytevector-u8-set! buf (fx+ i 1)
+ (fxior #b10000000 (fxand (fxsra b 6) #b111111)))
+ (bytevector-u8-set! buf (fx+ i 2)
+ (fxior #b10000000 (fxand b #b111111)))
+ ($set-port-index! p (fx+ i 3))]
+ [else
+ (flush-output-port p)
+ (put-char-utf8-mode p b who)]))]
+ [else
+ (let ([i ($port-index p)]
+ [j ($port-size p)]
+ [buf ($port-buffer p)])
+ (cond
+ [(fx< (fx+ i 3) j)
+ (bytevector-u8-set! buf i
+ (fxior #b11110000 (fxsra b 18)))
+ (bytevector-u8-set! buf (fx+ i 1)
+ (fxior #b10000000 (fxand (fxsra b 12) #b111111)))
+ (bytevector-u8-set! buf (fx+ i 2)
+ (fxior #b10000000 (fxand (fxsra b 6) #b111111)))
+ (bytevector-u8-set! buf (fx+ i 3)
+ (fxior #b10000000 (fxand b #b111111)))
+ ($set-port-index! p (fx+ i 4))]
+ [else
+ (flush-output-port p)
+ (put-char-utf8-mode p b who)]))]))
+ (define (put-char-latin-mode p b who)
+ (cond
+ [(fx< b 256)
+ (flush-output-port p)
+ (let ([i ($port-index p)] [j ($port-size p)])
+ (cond
+ [(fx< i j)
+ (bytevector-u8-set! ($port-buffer p) i b)
+ ($set-port-index! p (fx+ i 1))]
+ [else
+ (error who "insufficient space in port" p)]))]
+ [else
+ (case (transcoder-error-handling-mode (port-transcoder p))
+ [(ignore) (void)]
+ [(replace) (put-char p #\?)]
+ [(raise)
+ (raise (make-i/o-encoding-error p))]
+ [else (error who "BUG: invalid error handling mode" p)])]))
+ (define (put-char-char-mode p c who)
+ (flush-output-port p)
+ (let ([i ($port-index p)] [j ($port-size p)])
+ (cond
+ [(fx< i j)
+ (string-set! ($port-buffer p) i c)
+ ($set-port-index! p (fx+ i 1))]
+ [else
+ (error who "insufficient space in port" p)])))
;;;
- (define (put-char p c)
- (define who 'put-char)
+ (define write-char
+ (case-lambda
+ [(c p) (do-put-char p c 'write-char)]
+ [(c) (do-put-char (*the-output-port*) c 'write-char)]))
+ (define (put-char p c)
+ (do-put-char p c 'put-char))
+ (define (put-string p str)
+ (unless (string? str) (error 'put-string "not a string" str))
+ (unless (output-port? p)
+ (error 'put-string "not an output port" p))
+ (unless (textual-port? p)
+ (error 'put-string "not a textual port" p))
+ (let f ([i 0] [n (string-length str)])
+ (unless (fx= i n)
+ (do-put-char p (string-ref str i) 'put-string)
+ (f (fx+ i 1) n))))
+ (define (do-put-char p c who)
(unless (char? c) (error who "not a char" c))
(let ([m ($port-put-mode p)])
(cond
@@ -1132,8 +1506,8 @@
(let ([b (char->integer c)])
(cond
[(and (fx< i ($port-size p)) (fx< b 128))
- ($set-port-index! p (fx+ i 1))
- (bytevector-u8-set! ($port-buffer p) i b)]
+ (bytevector-u8-set! ($port-buffer p) i b)
+ ($set-port-index! p (fx+ i 1))]
[else
(put-char-utf8-mode p b who)])))]
[(eq? m fast-put-char-tag)
@@ -1149,15 +1523,53 @@
(let ([b (char->integer c)])
(cond
[(and (fx< i ($port-size p)) (fx< b 256))
- ($set-port-index! p (fx+ i 1))
- (bytevector-u8-set! ($port-buffer p) i b)]
+ (bytevector-u8-set! ($port-buffer p) i b)
+ ($set-port-index! p (fx+ i 1))]
[else
(put-char-latin-mode p b who)])))]
- [else (slow-put-char p c who)]))))
+ [else
+ (if (output-port? p)
+ (error who "not a textual port" p)
+ (error who "not an output port" p))]))))
+ (define newline
+ (case-lambda
+ [()
+ (put-char (*the-output-port*) #\newline)
+ (flush-output-port (*the-output-port*))]
+ [(p)
+ (unless (output-port? p)
+ (error 'newline "not an output port" p))
+ (unless (textual-port? p)
+ (error 'newline "not a textual port" p))
+ (when ($port-closed? p)
+ (error 'newline "port is closed" p))
+ (put-char p #\newline)
+ (flush-output-port p)]))
+
+
+
(module (put-u8)
- (define-rrr put-u8-byte-mode)
- (define-rrr slow-put-u8)
+ (define (put-u8-byte-mode p b who)
+ (let ([write! ($port-write! p)])
+ (let ([i ($port-index p)]
+ [buf ($port-buffer p)])
+ (let ([bytes (write! buf 0 i)])
+ (when (or (not (fixnum? bytes))
+ (fx< bytes 0)
+ (fx> bytes i))
+ (error who "write! returned an invalid value" bytes))
+ (cond
+ [(fx= bytes i)
+ (bytevector-u8-set! buf 0 b)
+ ($set-port-index! p 1)]
+ [(fx= bytes 0)
+ (error who "could not write bytes to sink")]
+ [else
+ (let ([i (fx- i bytes)])
+ (bytevector-copy! buf bytes buf 0 i)
+ (bytevector-u8-set! buf i b)
+ ($set-port-index! p (fx+ i 1)))])))))
;;;
(define (put-u8 p b)
(define who 'put-u8)
@@ -1172,4 +1584,11 @@
(bytevector-u8-set! ($port-buffer p) i b)]
[else
(put-u8-byte-mode p b who)]))]
- [else (slow-put-u8 p b who)]))))
+ [else
+ (if (output-port? p)
+ (error who "not a binary port" p)
+ (error who "not an output port" p))]))))
+
+
+ )
+
diff --git a/scheme/ikarus.predicates.ss b/scheme/ikarus.predicates.ss
index 57b825c..390d92f 100644
--- a/scheme/ikarus.predicates.ss
+++ b/scheme/ikarus.predicates.ss
@@ -21,15 +21,13 @@
boolean? char? vector? bytevector? string? procedure? null? pair?
symbol? code? not weak-pair? eq? eqv? equal? boolean=?
symbol=? finite? infinite? nan? real-valued?
- rational-valued? integer-valued?
- output-port? input-port? port? transcoder?)
-
+ rational-valued? integer-valued? transcoder?)
(import
(except (ikarus) fixnum? flonum? bignum? ratnum? number? complex? real?
rational? integer? exact? inexact? eof-object? bwp-object?
immediate? boolean? char? vector? bytevector? string? procedure?
null? pair? weak-pair? symbol? code? not eq? eqv? equal?
- transcoder? port? input-port? output-port? boolean=? symbol=?
+ transcoder? boolean=? symbol=?
finite? infinite? nan? real-valued? rational-valued?
integer-valued?)
(ikarus system $fx)
@@ -41,8 +39,7 @@
(rename (only (ikarus) fixnum? flonum? bignum? ratnum? eof-object?
bwp-object? immediate? boolean? char? vector? string?
bytevector? procedure? null? pair? symbol? code? eq?
- transcoder?
- port? input-port? output-port?)
+ transcoder?)
(fixnum? sys:fixnum?)
(flonum? sys:flonum?)
(bignum? sys:bignum?)
@@ -62,9 +59,6 @@
(code? sys:code?)
(eq? sys:eq?)
(transcoder? sys:transcoder?)
- (port? sys:port?)
- (input-port? sys:input-port?)
- (output-port? sys:output-port?)
))
(define fixnum?
@@ -258,12 +252,5 @@
(and (sys:bytevector? y) (bytevector=? x y))]
[else #f]))))
- (define port?
- (lambda (x) (sys:port? x)))
- (define input-port?
- (lambda (x) (sys:input-port? x)))
- (define output-port?
- (lambda (x) (sys:output-port? x)))
-
)
diff --git a/scheme/ikarus.strings.ss b/scheme/ikarus.strings.ss
index 7c69309..6ad883d 100644
--- a/scheme/ikarus.strings.ss
+++ b/scheme/ikarus.strings.ss
@@ -18,7 +18,8 @@
(export string-length string-ref string-set! make-string string->list
string-append substring string list->string uuid
string-copy string-for-each string-fill!
- string=? string? string>=?)
+ string=? string? string>=?
+ string-copy!)
(import
(ikarus system $strings)
(ikarus system $fx)
@@ -29,7 +30,7 @@
string->list string-append substring string
list->string uuid string-copy string-for-each
string=? string? string>=?
- string-fill!))
+ string-fill! string-copy!))
(define string-length
@@ -453,6 +454,46 @@
($string-set! v i fill)
(f v ($fxadd1 i) n fill))))
+
+ (define string-copy!
+ (lambda (src src-start dst dst-start k)
+ (cond
+ [(or (not (fixnum? src-start)) ($fx< src-start 0))
+ (error 'string-copy! "not a valid starting index" src-start)]
+ [(or (not (fixnum? dst-start)) ($fx< dst-start 0))
+ (error 'string-copy! "not a valid starting index" dst-start)]
+ [(or (not (fixnum? k)) ($fx< k 0))
+ (error 'string-copy! "not a valid length" k)]
+ [(not (string? src))
+ (error 'string-copy! "not a string" src)]
+ [(not (string? dst))
+ (error 'string-copy! "not a string" dst)]
+ [(let ([n ($fx+ src-start k)])
+ (or ($fx< n 0) ($fx> n ($string-length src))))
+ (error 'string-copy! "out of range" src-start k)]
+ [(let ([n ($fx+ dst-start k)])
+ (or ($fx< n 0) ($fx> n ($string-length dst))))
+ (error 'string-copy! "out of range" dst-start k)]
+ [(eq? src dst)
+ (cond
+ [($fx< dst-start src-start)
+ (let f ([src src] [si src-start] [di dst-start] [sj ($fx+ src-start k)])
+ (unless ($fx= si sj)
+ ($string-set! src di ($string-ref src si))
+ (f src ($fxadd1 si) ($fxadd1 di) sj)))]
+ [($fx< src-start dst-start)
+ (let f ([src src] [si ($fx+ src-start k)] [di ($fx+ dst-start k)] [sj src-start])
+ (unless ($fx= si sj)
+ (let ([si ($fxsub1 si)] [di ($fxsub1 di)])
+ ($string-set! src di ($string-ref src si))
+ (f src si di sj))))]
+ [else (void)])]
+ [else
+ (let f ([src src] [si src-start] [dst dst] [di dst-start] [sj ($fx+ src-start k)])
+ (unless ($fx= si sj)
+ ($string-set! dst di ($string-ref src si))
+ (f src ($fxadd1 si) dst ($fxadd1 di) sj)))])))
+
(define uuid
(lambda ()
(let ([s ($make-bytevector 16)])
diff --git a/scheme/ikarus.unicode-data.ss b/scheme/ikarus.unicode-data.ss
index 5e35ffe..c19e5dc 100644
--- a/scheme/ikarus.unicode-data.ss
+++ b/scheme/ikarus.unicode-data.ss
@@ -230,23 +230,24 @@
(error 'char-ci>=? "not a char" x))]))
(define ($string-foldcase str)
- (let f ([str str] [i 0] [n (string-length str)] [p (open-output-string)])
- (cond
- [($fx= i n) (get-output-string p)]
- [else
- (let* ([n ($char->fixnum ($string-ref str i))])
- (let ([n/ls
- (vector-ref string-foldcase-adjustment-vector
- (binary-search n charcase-search-vector))])
- (if (fixnum? n/ls)
- ($write-char ($fixnum->char ($fx+ n n/ls)) p)
- (let f ([ls n/ls])
- ($write-char ($car ls) p)
- (let ([ls ($cdr ls)])
- (if (pair? ls)
- (f ls)
- ($write-char ls p)))))))
- (f str ($fxadd1 i) n p)])))
+ (let-values ([(p e) (open-string-output-port)])
+ (let f ([str str] [i 0] [n (string-length str)])
+ (cond
+ [($fx= i n) (e)]
+ [else
+ (let* ([n ($char->fixnum ($string-ref str i))])
+ (let ([n/ls
+ (vector-ref string-foldcase-adjustment-vector
+ (binary-search n charcase-search-vector))])
+ (if (fixnum? n/ls)
+ (write-char ($fixnum->char ($fx+ n n/ls)) p)
+ (let f ([ls n/ls])
+ (write-char ($car ls) p)
+ (let ([ls ($cdr ls)])
+ (if (pair? ls)
+ (f ls)
+ (write-char ls p)))))))
+ (f str ($fxadd1 i) n)]))))
(define (string-foldcase str)
(if (string? str)
diff --git a/scheme/ikarus.writer.ss b/scheme/ikarus.writer.ss
index f9fc444..b8bfc27 100644
--- a/scheme/ikarus.writer.ss
+++ b/scheme/ikarus.writer.ss
@@ -790,9 +790,9 @@
(lambda (fmt . args)
(unless (string? fmt)
(error 'format "not a string" fmt))
- (let ([p (open-output-string)])
+ (let-values ([(p e) (open-string-output-port)])
(formatter 'format p fmt args)
- (get-output-string p))))
+ (e))))
(define printf
(lambda (fmt . args)
diff --git a/scheme/last-revision b/scheme/last-revision
index 87577dc..c124326 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1202
+1203
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 9e661ae..86942a5 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -66,14 +66,8 @@
"ikarus.guardians.ss"
"ikarus.command-line.ss"
"ikarus.codecs.ss"
- "ikarus.io-ports.ss"
- "ikarus.io-primitives.unsafe.ss"
- "ikarus.io-primitives.ss"
- "ikarus.io.input-files.ss"
- "ikarus.io.output-files.ss"
- "ikarus.io.input-strings.ss"
- "ikarus.io.output-strings.ss"
- "ikarus.io.output-bytevectors.ss"
+ "ikarus.bytevectors.ss"
+ "ikarus.io.ss"
"ikarus.hash-tables.ss"
"ikarus.writer.ss"
"ikarus.reader.ss"
@@ -95,11 +89,11 @@
"ikarus.posix.ss"
"ikarus.timer.ss"
"ikarus.time-and-date.ss"
- "ikarus.bytevectors.ss"
"ikarus.sort.ss"
"ikarus.promises.ss"
"ikarus.enumerations.ss"
- "ikarus.main.ss"))
+ "ikarus.main.ss"
+ ))
(define ikarus-system-macros
'([define (define)]
@@ -890,6 +884,7 @@
[bytevector->u8-list i r bv]
[bytevector->uint-list i r bv]
[bytevector-copy i r bv]
+ [string-copy! i]
[bytevector-copy! i r bv]
[bytevector-fill! i r bv]
[bytevector-ieee-double-native-ref i r bv]
@@ -1140,7 +1135,7 @@
[open-bytevector-output-port i r ip]
[open-file-input-port r ip]
[open-file-input/output-port r ip]
- [open-file-output-port r ip]
+ [open-file-output-port i r ip]
[open-string-input-port i r ip]
[open-string-output-port i r ip]
[output-port-buffer-mode r ip]
@@ -1179,7 +1174,7 @@
[display i r is se]
[newline i r is se]
[open-input-file i r is se]
- [open-output-file i r is se]
+ ;[open-output-file i r is se]
[peek-char i r is se]
[read i r is se]
[read-char i r is se]
@@ -1404,6 +1399,7 @@
(case-lambda
[() set]
[(x) (set! set (cons x set))]))))
+
(import (ikarus makefile collections))
(define (assq1 x ls)
@@ -1581,11 +1577,12 @@
(reverse (cons* (car code*) code (cdr code*)))
export-locs)))))
+
(verify-map)
(time-it "the entire bootstrap process"
(lambda ()
- (let-values ([(core* locs)
+ (let-values ([(core* locs)
(time-it "macro expansion"
(lambda ()
(parameterize ([current-library-collection
@@ -1597,7 +1594,9 @@
[(assq x locs) => cdr]
[else
(error 'bootstrap "no location for primitive" x)])))
- (let ([p (open-output-file "ikarus.boot" 'replace)])
+
+ (let ([p (open-file-output-port "ikarus.boot"
+ (file-options no-fail))])
(time-it "code generation and serialization"
(lambda ()
(for-each
@@ -1606,6 +1605,7 @@
core*)))
(close-output-port p)))))
+
(printf "Happy Happy Joy Joy\n")
diff --git a/scheme/pass-specify-rep-primops.ss b/scheme/pass-specify-rep-primops.ss
index cd9f336..11b3a2d 100644
--- a/scheme/pass-specify-rep-primops.ss
+++ b/scheme/pass-specify-rep-primops.ss
@@ -1740,6 +1740,7 @@
/section)
+#;
(section ;;; ports
(define-primop port? safe
diff --git a/src/ikarus-io.c b/src/ikarus-io.c
index 04c242a..73516d5 100644
--- a/src/ikarus-io.c
+++ b/src/ikarus-io.c
@@ -55,6 +55,36 @@ ikrt_open_input_fd(ikp fn, ikpcb* pcb){
}
}
+ikp
+ikrt_open_output_fd(ikp fn, ikp ikopts, ikpcb* pcb){
+ int opts = unfix(ikopts);
+ int mode = 0;
+ switch (opts){
+ /* mode 0: error if exists, create if does not exist */
+ case 0: mode = O_WRONLY | O_CREAT | O_EXCL; break;
+ /* mode 1: truncate if exists, error if not exists */
+ case 1: mode = O_WRONLY | O_TRUNC; break;
+ /* mode 2: truncate if exists, create if not exist */
+ case 2: mode = O_WRONLY | O_TRUNC | O_CREAT ; break;
+ /* mode 3: truncate if exists, error if not exists */
+ case 3: mode = O_WRONLY | O_TRUNC ; break;
+ case 4: mode = O_WRONLY | O_CREAT | O_EXCL ; break;
+ case 5: mode = O_WRONLY | O_CREAT ; break;
+ case 6: mode = O_WRONLY | O_CREAT ; break;
+ case 7: mode = O_WRONLY ; break;
+ }
+ int fh = open((char*)(fn+off_bytevector_data),
+ mode,
+ S_IRUSR | S_IWUSR | S_IRGRP | S_IROTH);
+ if(fh > 0){
+ return fix(fh);
+ } else {
+ return ikrt_io_error();
+ }
+}
+
+
+
ikp
ikrt_read_fd(ikp fd, ikp bv, ikp off, ikp cnt, ikpcb* pcb){
ssize_t bytes =
@@ -68,3 +98,16 @@ ikrt_read_fd(ikp fd, ikp bv, ikp off, ikp cnt, ikpcb* pcb){
}
}
+ikp
+ikrt_write_fd(ikp fd, ikp bv, ikp off, ikp cnt, ikpcb* pcb){
+ ssize_t bytes =
+ write(unfix(fd),
+ (char*)(bv+off_bytevector_data+unfix(off)),
+ unfix(cnt));
+ if(bytes >= 0){
+ return fix(bytes);
+ } else {
+ return ikrt_io_error();
+ }
+}
+
diff --git a/src/ikarus-runtime.c b/src/ikarus-runtime.c
index 3906c87..284d6e3 100644
--- a/src/ikarus-runtime.c
+++ b/src/ikarus-runtime.c
@@ -1151,3 +1151,9 @@ ikrt_exit(ikp status, ikpcb* pcb){
assert(total_allocated_pages == 0);
exit((int)status);
}
+
+ikp
+ikrt_debug(ikp x){
+ fprintf(stderr, "DEBUG 0x%08x\n", (int)x);
+ return 0;
+};