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

New IO layer is installed. Still buggy in some area but can be used 

for bootstrapping at least.
This commit is contained in:
Abdulaziz Ghuloum 2007-12-10 07:28:03 -05:00
parent ea96ab85db
commit 0e38534d2e
28 changed files with 749 additions and 1960 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
lab/io-test.ss
View File

@ -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)

25
scheme/Makefile.am
View File

@ -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)"

50
scheme/Makefile.in
View File

@ -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

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

4
scheme/ikarus.cafe.ss
View File

@ -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)

1
scheme/ikarus.codecs.ss
View File

@ -142,5 +142,6 @@
(f (cdr ls) (fxlogor (cdr a) n)))]
[else #f])))
)

26
scheme/ikarus.compiler.ss
View File

@ -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)

2
scheme/ikarus.conditions.ss
View File

@ -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)

9
scheme/ikarus.fasl.write.ss
View File

@ -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)

3
scheme/ikarus.handlers.ss
View File

@ -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)

201
scheme/ikarus.io-ports.ss
View File

@ -1,201 +0,0 @@
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(library (ikarus io-ports)
(export make-input-port make-output-port
port-handler
port-input-buffer port-output-buffer
port-input-index set-port-input-index!
port-input-size set-port-input-size!
port-output-index set-port-output-index!
port-output-size set-port-output-size!
port-mode set-port-mode!)
(import
(ikarus system $ports)
(ikarus system $strings)
(ikarus system $bytevectors)
(ikarus system $fx)
(except (ikarus)
make-input-port make-output-port
port-handler
port-input-buffer port-output-buffer
port-input-index set-port-input-index!
port-input-size set-port-input-size!
port-output-index set-port-output-index!
port-output-size set-port-output-size!
port-mode set-port-mode!))
;;; GENERIC PORTS: BASIC PRIMITIVES
;;;
;;; Exports:
;;; * Constructors:
;;; (make-input-port handler input-buffer)
;;; (make-output-port handler output-buffer)
;;;
;;; * Predicates:
;;; (port? x)
;;; (input-port? x)
;;; (output-port? x)
;;;
;;; * Accessors:
;;; (port-handler port)
;;; (port-buffer port)
;;; (port-index port)
;;; (port-size port)
;;;
;;; * Mutators:
;;; (set-port-index! port fixnum)
;;; (set-port-size! port fixnum)
;;;
(define $make-input-port
(lambda (handler buffer)
($make-port/input handler buffer 0 ($bytevector-length buffer))))
;;;
(define make-input-port
(lambda (handler buffer)
(if (procedure? handler)
(if (bytevector? buffer)
($make-input-port handler buffer)
(error 'make-input-port "not a bytevector" buffer))
(error 'make-input-port "not a procedure" handler))))
;;;
(define $make-output-port
(lambda (handler buffer)
($make-port/output handler buffer 0 ($bytevector-length buffer))))
;;;
(define make-output-port
(lambda (handler buffer)
(if (procedure? handler)
(if (bytevector? buffer)
($make-output-port handler buffer)
(error 'make-output-port "not a bytevector" buffer))
(error 'make-output-port "not a procedure" handler))))
;;;
(define port-handler
(lambda (x)
(if (port? x)
($port-handler x)
(error 'port-handler "not a port" x))))
;;;
(define port-input-buffer
(lambda (x)
(if (input-port? x)
($port-buffer x)
(error 'port-input-buffer "not an input-port" x))))
;;;
(define port-input-index
(lambda (x)
(if (input-port? x)
($port-index x)
(error 'port-input-index "not an input-port" x))))
;;;
(define port-input-size
(lambda (x)
(if (input-port? x)
($port-size x)
(error 'port-input-size "not an input-port" x))))
;;;
(define port-output-buffer
(lambda (x)
(if (output-port? x)
($port-buffer x)
(error 'port-output-buffer "not an output-port" x))))
;;;
(define port-output-index
(lambda (x)
(if (output-port? x)
($port-index x)
(error 'port-output-index "not an output-port" x))))
;;;
(define port-output-size
(lambda (x)
(if (output-port? x)
($port-size x)
(error 'port-output-size "not an output-port" x))))
;;;
(define set-port-input-index!
(lambda (p i)
(if (input-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i ($port-size p))
($set-port-index! p i)
(error 'set-port-input-index! "index is too big" i))
(error 'set-port-input-index! "index is negative" i))
(error 'set-port-input-index! "not a valid index" i))
(error 'set-port-input-index! "not an input-port" p))))
;;;
(define set-port-input-size!
(lambda (p i)
(if (input-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i ($bytevector-length ($port-buffer p)))
(begin
($set-port-index! p 0)
($set-port-size! p i))
(error 'set-port-input-size! "size is too big" i))
(error 'set-port-input-size! "size is negative" i))
(error 'set-port-input-size! "not a valid size" i))
(error 'set-port-input-size! "not an input-port" p))))
;;;
(define set-port-output-index!
(lambda (p i)
(if (output-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i ($port-size p))
($set-port-index! p i)
(error 'set-port-output-index! "index is too big" i))
(error 'set-port-output-index! "index is negative" i))
(error 'set-port-output-index! "not a valid index" i))
(error 'set-port-output-index! "not an output-port" p))))
;;;
(define set-port-output-size!
(lambda (p i)
(if (output-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i ($bytevector-length ($port-buffer p)))
(begin
($set-port-index! p 0)
($set-port-size! p i))
(error 'set-port-output-size! "size is too big" i))
(error 'set-port-output-size! "size is negative" i))
(error 'set-port-output-size! "not a valid size" i))
(error 'set-port-output-size! "not an output-port" p))))
(define (port-mode p)
(if (port? p)
(let ([attr ($port-attributes p)])
(case (fxand attr 1)
[(0) 'ikarus-mode]
[else 'r6rs-mode]))
(error 'port-mode "not a port" p)))
(define (set-port-mode! p m)
(if (port? p)
(let ([attr ($port-attributes p)])
($set-port-attributes! p
(case m
[(ikarus-mode) (fxand attr (fxnot 1))]
[(r6rs-mode) (fxior attr 1)]
[else (error 'set-port-mode! "invalid mode" m)])))
(error 'port-mode "not a port" p)))
)

461
scheme/ikarus.io-primitives.ss
View File

@ -1,461 +0,0 @@
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(library (ikarus io-primitives)
(export read-char ; ok
peek-char ; ok
write-char
write-byte
put-u8
put-char
put-string
put-bytevector
get-char ; ok
get-u8 ; ok
lookahead-u8 ; ok
get-string-n ; ok
get-string-n! ; ok
get-bytevector-n ; ok
get-bytevector-n! ; ok
newline ; ok
port-name
input-port-name
output-port-name
close-input-port
reset-input-port!
close-port
flush-output-port
close-output-port
get-line ; ok
)
(import
(ikarus system $io)
(ikarus system $fx)
(ikarus system $ports)
(except (ikarus) read-char peek-char write-char write-byte
put-u8 put-char put-string put-bytevector
get-char get-u8 lookahead-u8
get-string-n get-string-n!
get-bytevector-n get-bytevector-n!
newline port-name input-port-name output-port-name
close-input-port reset-input-port! flush-output-port
close-output-port close-port get-line))
(define write-char
(case-lambda
[(c)
(if (char? c)
($write-char c (current-output-port))
(error 'write-char "not a character" c))]
[(c p)
(if (char? c)
(if (output-port? p)
($write-char c p)
(error 'write-char "not an output-port" p))
(error 'write-char "not a character" c))]))
(define put-char
(lambda (p c)
(if (char? c)
(if (output-port? p)
($write-char c p)
(error 'put-char "not an output-port" p))
(error 'put-char "not a character" c))))
(define write-byte
(case-lambda
[(b)
(if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
($write-byte b (current-output-port))
(error 'write-byte "not a byte" b))]
[(b p)
(if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
(if (output-port? p)
($write-byte b p)
(error 'write-byte "not an output-port" p))
(error 'write-byte "not a byte" b))]))
(define put-u8
(lambda (p b)
(if (and (fixnum? b) ($fx<= 0 b) ($fx<= b 255))
(if (output-port? p)
($write-byte b p)
(error 'put-u8 "not an output-port" p))
(error 'put-u8 "not a u8" b))))
;;;
(define newline
(case-lambda
[()
($write-char #\newline (current-output-port))
($flush-output-port (current-output-port))]
[(p)
(if (output-port? p)
(begin
($write-char #\newline p)
($flush-output-port p))
(error 'newline "not an output port" p))]))
;;;
(define port-name
(lambda (p)
(if (port? p)
(($port-handler p) 'port-name p)
(error 'port-name "not a port" p))))
(define input-port-name
(lambda (p)
(if (port? p)
(($port-handler p) 'port-name p)
(error 'input-port-name "not a port" p))))
(define output-port-name
(lambda (p)
(if (port? p)
(($port-handler p) 'port-name p)
(error 'output-port-name "not a port" p))))
(define get-char
(lambda (p)
(if (input-port? p)
($read-char p)
(error 'get-char "not an input-port" p))))
(define get-u8
(lambda (p)
(if (input-port? p)
($get-u8 p)
(error 'get-u8 "not an input-port" p))))
(define lookahead-u8
(lambda (p)
(if (input-port? p)
($lookahead-u8 p)
(error 'lookahead-u8 "not an input-port" p))))
(define read-char
(case-lambda
[() ($read-char (current-input-port))]
[(p)
(if (input-port? p)
($read-char p)
(error 'read-char "not an input-port" p))]))
;;;
(define peek-char
(case-lambda
[() ($peek-char (current-input-port))]
[(p)
(if (input-port? p)
($peek-char p)
(error 'peek-char "not an input-port" p))]))
;;;
(define reset-input-port!
(case-lambda
[() ($reset-input-port! (current-input-port))]
[(p)
(if (input-port? p)
($reset-input-port! p)
(error 'reset-input-port! "not an input-port" p))]))
;;;
(define close-input-port
(case-lambda
[() ($close-input-port (current-input-port))]
[(p)
(if (input-port? p)
($close-input-port p)
(error 'close-input-port! "not an input-port" p))]))
;;;
(define close-output-port
(case-lambda
[() ($close-output-port (current-output-port))]
[(p)
(if (output-port? p)
($close-output-port p)
(error 'close-output-port "not an output-port" p))]))
;;;
(define (close-port p)
(cond
[(input-port? p) ($close-input-port p)]
[(output-port? p) ($close-output-port p)]
[else (error 'close-port "not a port" p)]))
;;;
(define flush-output-port
(case-lambda
[() ($flush-output-port (current-output-port))]
[(p)
(if (output-port? p)
($flush-output-port p)
(error 'flush-output-port "not an output-port" p))]))
(define (get-line p)
(define (get-it p)
(let f ([p p] [n 0] [ac '()])
(let ([x ($read-char p)])
(cond
[(eqv? x #\newline)
(make-it n ac)]
[(eof-object? x)
(if (null? ac) x (make-it n ac))]
[else (f p (+ n 1) (cons x ac))]))))
(define (make-it n revls)
(let f ([s (make-string n)] [i (- n 1)] [ls revls])
(cond
[(pair? ls)
(string-set! s i (car ls))
(f s (- i 1) (cdr ls))]
[else s])))
(if (input-port? p)
(get-it p)
(error 'get-line "not an input port" p)))
(module (put-string)
(import (ikarus system $strings)
(ikarus system $fx))
(define ($put-string p s i j)
(unless ($fx= i j)
($write-char ($string-ref s i) p)
($put-string p s ($fx+ i 1) j)))
(define put-string
(case-lambda
[(p s)
(unless (output-port? p)
(error 'put-string "not an output port" p))
(unless (string? s)
(error 'put-string "not a string" s))
($put-string p s 0 (string-length s))]
[(p s i)
(unless (output-port? p)
(error 'put-string "not an output port" p))
(unless (string? s)
(error 'put-string "not a string" s))
(let ([len ($string-length s)])
(unless (fixnum? i)
(error 'put-string "starting index is not a fixnum" i))
(when (or ($fx< i 0) ($fx> i len))
(error 'put-string
(format "starting index is out of range 0..~a" len)
i))
($put-string p s i len))]
[(p s i c)
(unless (output-port? p)
(error 'put-string "not an output port" p))
(unless (string? s)
(error 'put-string "not a string" s))
(let ([len ($string-length s)])
(unless (fixnum? i)
(error 'put-string "starting index is not a fixnum" i))
(when (or ($fx< i 0) ($fx> i len))
(error 'put-string
(format "starting index is out of range 0..~a" len)
i))
(unless (fixnum? c)
(error 'put-string "count is not a fixnum" c))
(let ([j (+ i c)])
(when (or ($fx< c 0) (> j len))
(error 'put-string
(format "count is out of range 0..~a" (- len i))
c))
($put-string p s i j)))])))
(module (put-bytevector)
(import (ikarus system $bytevectors)
(ikarus system $fx))
(define ($put-bytevector p bv i j)
(unless ($fx= i j)
($write-byte ($bytevector-u8-ref bv i) p)
($put-bytevector p bv ($fx+ i 1) j)))
(define put-bytevector
(case-lambda
[(p s)
(unless (output-port? p)
(error 'put-bytevector "not an output port" p))
(unless (bytevector? s)
(error 'put-bytevector "not a bytevector" s))
($put-bytevector p s 0 (bytevector-length s))]
[(p s i)
(unless (output-port? p)
(error 'put-bytevector "not an output port" p))
(unless (bytevector? s)
(error 'put-bytevector "not a bytevector" s))
(let ([len ($bytevector-length s)])
(unless (fixnum? i)
(error 'put-bytevector "starting index is not a fixnum" i))
(when (or ($fx< i 0) ($fx> i len))
(error 'put-bytevector
(format "starting index is out of range 0..~a" len)
i))
($put-bytevector p s i len))]
[(p s i c)
(unless (output-port? p)
(error 'put-bytevector "not an output port" p))
(unless (bytevector? s)
(error 'put-bytevector "not a bytevector" s))
(let ([len ($bytevector-length s)])
(unless (fixnum? i)
(error 'put-bytevector "starting index is not a fixnum" i))
(when (or ($fx< i 0) ($fx> i len))
(error 'put-bytevector
(format "starting index is out of range 0..~a" len)
i))
(unless (fixnum? c)
(error 'put-bytevector "count is not a fixnum" c))
(let ([j (+ i c)])
(when (or ($fx< c 0) (> j len))
(error 'put-bytevector
(format "count is out of range 0..~a" (- len i))
c))
($put-bytevector p s i j)))])))
(define (get-string-n p n)
(import (ikarus system $fx) (ikarus system $strings))
(unless (input-port? p)
(error 'get-string-n "not an input port" p))
(unless (fixnum? n)
(error 'get-string-n "count is not a fixnum" n))
(cond
[($fx> n 0)
(let ([s ($make-string n)])
(let f ([p p] [n n] [s s] [i 0])
(let ([x ($read-char p)])
(cond
[(eof-object? x)
(if ($fx= i 0)
(eof-object)
(substring s 0 i))]
[else
($string-set! s i x)
(let ([i ($fxadd1 i)])
(if ($fx= i n)
s
(f p n s i)))]))))]
[($fx= n 0) ""]
[else (error 'get-string-n "count is negative" n)]))
(define (get-string-n! p s i c)
(import (ikarus system $fx) (ikarus system $strings))
(unless (input-port? p)
(error 'get-string-n! "not an input port" p))
(unless (string? s)
(error 'get-string-n! "not a string" s))
(let ([len ($string-length s)])
(unless (fixnum? i)
(error 'get-string-n! "starting index is not a fixnum" i))
(when (or ($fx< i 0) ($fx> i len))
(error 'get-string-n!
(format "starting index is out of range 0..~a" len)
i))
(unless (fixnum? c)
(error 'get-string-n! "count is not a fixnum" c))
(cond
[($fx> c 0)
(let ([j (+ i c)])
(when (> j len)
(error 'get-string-n!
(format "count is out of range 0..~a" (- len i))
c))
(let ([x ($read-char p)])
(cond
[(eof-object? x) x]
[else
($string-set! s i x)
(let f ([p p] [s s] [start i] [i 1] [c c])
(let ([x ($read-char p)])
(cond
[(eof-object? x) i]
[else
($string-set! s ($fx+ start i) x)
(let ([i ($fxadd1 i)])
(if ($fx= i c)
i
(f p s start i c)))])))])))]
[($fx= c 0) 0]
[else (error 'get-string-n! "count is negative" c)])))
(define (get-bytevector-n p n)
(import (ikarus system $fx) (ikarus system $bytevectors))
(define (subbytevector s n)
(let ([p ($make-bytevector n)])
(let f ([s s] [n n] [p p])
(let ([n ($fx- n 1)])
($bytevector-set! p n ($bytevector-u8-ref s n))
(if ($fx= n 0)
p
(f s n p))))))
(unless (input-port? p)
(error 'get-bytevector-n "not an input port" p))
(unless (fixnum? n)
(error 'get-bytevector-n "count is not a fixnum" n))
(cond
[($fx> n 0)
(let ([s ($make-bytevector n)])
(let f ([p p] [n n] [s s] [i 0])
(let ([x ($get-u8 p)])
(cond
[(eof-object? x)
(if ($fx= i 0)
(eof-object)
(subbytevector s i))]
[else
($bytevector-set! s i x)
(let ([i ($fxadd1 i)])
(if ($fx= i n)
s
(f p n s i)))]))))]
[($fx= n 0) '#vu8()]
[else (error 'get-bytevector-n "count is negative" n)]))
(define (get-bytevector-n! p s i c)
(import (ikarus system $fx) (ikarus system $bytevectors))
(unless (input-port? p)
(error 'get-bytevector-n! "not an input port" p))
(unless (bytevector? s)
(error 'get-bytevector-n! "not a bytevector" s))
(let ([len ($bytevector-length s)])
(unless (fixnum? i)
(error 'get-bytevector-n! "starting index is not a fixnum" i))
(when (or ($fx< i 0) ($fx> i len))
(error 'get-bytevector-n!
(format "starting index is out of range 0..~a" len)
i))
(unless (fixnum? c)
(error 'get-bytevector-n! "count is not a fixnum" c))
(cond
[($fx> c 0)
(let ([j (+ i c)])
(when (> j len)
(error 'get-bytevector-n!
(format "count is out of range 0..~a" (- len i))
c))
(let ([x ($get-u8 p)])
(cond
[(eof-object? x) x]
[else
($bytevector-set! s i x)
(let f ([p p] [s s] [start i] [i 1] [c c])
(let ([x ($get-u8 p)])
(cond
[(eof-object? x) i]
[else
($bytevector-set! s ($fx+ start i) x)
(let ([i ($fxadd1 i)])
(if ($fx= i c)
i
(f p s start i c)))])))])))]
[($fx= c 0) 0]
[else (error 'get-bytevector-n! "count is negative" c)])))
)

127
scheme/ikarus.io-primitives.unsafe.ss
View File

@ -1,127 +0,0 @@
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(library (ikarus io-primitives unsafe)
(export $write-char
$write-byte
$read-char
$get-u8
$lookahead-u8
$peek-char
$reset-input-port!
$flush-output-port
$close-input-port
$close-output-port
)
(import
(ikarus)
(ikarus system $ports)
(ikarus system $strings)
(ikarus system $chars)
(ikarus system $bytevectors)
(ikarus system $fx))
(define $write-char
(lambda (c p)
(let ([b ($char->fixnum c)])
(cond
[($fx<= b #x7F)
($write-byte b p)]
[($fx<= b #x7FF)
($write-byte
($fxlogor #b11000000 ($fxsra b 6)) p)
($write-byte
($fxlogor #b10000000 ($fxlogand b #b111111)) p)]
[($fx<= b #xFFFF)
($write-byte
($fxlogor #b11100000 ($fxsra b 12)) p)
($write-byte
($fxlogor #b10000000 ($fxlogand ($fxsra b 6) #b111111)) p)
($write-byte
($fxlogor #b10000000 ($fxlogand b #b111111)) p)]
[else
($write-byte
($fxlogor #b11110000 ($fxsra b 18)) p)
($write-byte
($fxlogor #b10000000 ($fxlogand ($fxsra b 12) #b111111)) p)
($write-byte
($fxlogor #b10000000 ($fxlogand ($fxsra b 6) #b111111)) p)
($write-byte
($fxlogor #b10000000 ($fxlogand b #b111111)) p)]))))
(define $write-byte
(lambda (b p)
(let ([idx (port-output-index p)])
(if ($fx< idx ($port-size p))
(begin
($bytevector-set! ($port-buffer p) idx b)
($set-port-index! p ($fxadd1 idx)))
(($port-handler p) 'write-byte b p)))))
(define $read-char
(lambda (p)
(let ([idx ($port-index p)])
(if ($fx< idx ($port-size p))
(let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
(cond
[($fx<= b 127)
($set-port-index! p ($fxadd1 idx))
($fixnum->char b)]
[else (($port-handler p) 'read-char p)]))
(($port-handler p) 'read-char p)))))
(define $get-u8
(lambda (p)
(let ([idx ($port-index p)])
(if ($fx< idx ($port-size p))
(let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
($set-port-index! p ($fxadd1 idx))
b)
(($port-handler p) 'get-u8 p)))))
(define $lookahead-u8
(lambda (p)
(let ([idx ($port-index p)])
(if ($fx< idx ($port-size p))
($bytevector-u8-ref ($port-buffer p) idx)
(($port-handler p) 'lookahead-u8 p)))))
(define $peek-char
(lambda (p)
(let ([idx ($port-index p)])
(if ($fx< idx ($port-size p))
(let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
(cond
[($fx<= b 127)
($fixnum->char b)]
[else (($port-handler p) 'peek-char p)]))
(($port-handler p) 'peek-char p)))))
(define $reset-input-port!
(lambda (p)
($set-port-size! p 0)))
(define $close-input-port
(lambda (p)
(($port-handler p) 'close-port p)))
(define $close-output-port
(lambda (p)
(($port-handler p) 'close-port p)))
(define $flush-output-port
(lambda (p)
(($port-handler p) 'flush-output-port p))))

282
scheme/ikarus.io.input-files.ss
View File

@ -1,282 +0,0 @@
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(library (ikarus io input-files)
(export open-input-file
current-input-port ; ok?
console-input-port
standard-input-port ; ok
with-input-from-file
call-with-input-file
)
(import
(ikarus system $ports)
(ikarus system $io)
(ikarus system $fx)
(ikarus system $strings)
(ikarus system $bytevectors)
(ikarus system $chars)
(rnrs bytevectors)
(except (ikarus)
open-input-file current-input-port console-input-port
with-input-from-file call-with-input-file
standard-input-port current-input-port))
(define-syntax message-case
(syntax-rules (else)
[(_ msg args
[(msg-name msg-arg* ...) b b* ...] ...
[else else1 else2 ...])
(let ([tmsg msg] [targs args])
(define-syntax match-and-bind
(syntax-rules ()
[(__ y () body)
(if (null? y)
body
(error 'message-case "unmatched" (cons tmsg targs)))]
[(__ y (a a* (... ...)) body)
(if (pair? y)
(let ([a (car y)] [d (cdr y)])
(match-and-bind d (a* (... ...)) body))
(error 'message-case "unmatched" (cons tmsg targs)))]))
(case tmsg
[(msg-name)
(match-and-bind targs (msg-arg* ...) (begin b b* ...))] ...
[else else1 else2 ...]))]))
(define guardian (make-guardian))
(define close-ports
(lambda ()
(cond
[(guardian) =>
(lambda (p)
(close-input-port p)
(close-ports))])))
(define refill-buffer!
(lambda (p bytes)
(error 'refill-buffer! "not implemented")))
(define read-multibyte-char
(lambda (p b0)
(let ([idx ($port-index p)]
[size ($port-size p)])
(cond
[($fx= ($fxlogand b0 #b11100000) #b11000000)
;;; 2-byte utf8 sequence
(unless ($fx< ($fx+ idx 1) size)
(refill-buffer! p 1))
(let ([b1 ($bytevector-u8-ref
($port-buffer p)
($fxadd1 idx))])
(unless ($fx= ($fxlogand b1 #b11000000) #b10000000)
(error 'read-char "invalid utf8 sequence" b0 b1))
($set-port-index! p ($fx+ idx 2))
($fixnum->char
($fx+ ($fxsll ($fxlogand b0 #b11111) 6)
($fxlogand b1 #b111111))))]
[else
(error 'read-multibyte
"BUG: bytesequence is not supported yet" b0)]))))
(define peek-multibyte-char
(lambda (p)
(error 'peek-multibyte-char "not implemented")))
(define make-input-file-handler
(lambda (fd port-name)
(let ((open? #t))
(lambda (msg . args)
(message-case msg args
[(read-char p)
(unless (input-port? p)
(error 'read-char "not an input port" p))
(let ([idx ($port-index p)])
(if ($fx< idx ($port-size p))
(let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
(cond
[($fx< b 128)
($set-port-index! p ($fxadd1 idx))
($fixnum->char b)]
[else (read-multibyte-char p b)]))
(if open?
(let ([bytes
(foreign-call "ikrt_read"
fd ($port-buffer p))])
(cond
[($fx> bytes 0)
($set-port-size! p bytes)
($read-char p)]
[($fx= bytes 0)
(eof-object)]
[else
(error 'read-char "Cannot read from file"
port-name)]))
(error 'read-char "port is closed" p))))]
[(get-u8 p)
(unless (input-port? p)
(error 'get-u8 "not an input port" p))
(let ([idx ($port-index p)])
(if ($fx< idx ($port-size p))
(let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
($set-port-index! p ($fxadd1 idx))
b)
(if open?
(let ([bytes
(foreign-call "ikrt_read"
fd ($port-buffer p))])
(cond
[($fx> bytes 0)
($set-port-size! p bytes)
($get-u8 p)]
[($fx= bytes 0)
(eof-object)]
[else
(error 'get-u8 "Cannot read from file" port-name)]))
(error 'get-u8 "port is closed" p))))]
[(peek-char p)
(unless (input-port? p)
(error 'peek-char "not an input port" p))
(let ([idx ($port-index p)])
(if ($fx< idx ($port-size p))
(let ([b ($bytevector-u8-ref ($port-buffer p) idx)])
(cond
[($fx< b 128) ($fixnum->char b)]
[else (peek-multibyte-char p)]))
(if open?
(let ([bytes
(foreign-call "ikrt_read" fd
(port-input-buffer p))])
(cond
[(not bytes)
(error 'peek-char
"Cannot read from file" port-name)]
[($fx= bytes 0)
(eof-object)]
[else
($set-port-size! p bytes)
($peek-char p)]))
(error 'peek-char "port is closed" p))))]
[(lookahead-u8 p)
(unless (input-port? p)
(error 'lookahead-u8 "not an input port" p))
(let ([idx ($port-index p)])
(if ($fx< idx ($port-size p))
($bytevector-u8-ref ($port-buffer p) idx)
(if open?
(let ([bytes
(foreign-call "ikrt_read" fd
(port-input-buffer p))])
(cond
[(not bytes)
(error 'lookahead-u8
"Cannot read from file" port-name)]
[($fx= bytes 0)
(eof-object)]
[else
($bytevector-u8-ref ($port-buffer p) 0)]))
(error 'lookahead-u8 "port is closed" p))))]
[(port-name p) port-name]
[(close-port p)
(unless (input-port? p)
(error 'close-input-port "not an input port" p))
(when open?
($set-port-size! p 0)
(set! open? #f)
(unless (foreign-call "ikrt_close_file" fd)
(error 'close-input-port "cannot close port" port-name)))]
[else
(error 'input-file-handler
"message not handled" (cons msg args))])))))
(define $open-input-file
(lambda (filename)
(close-ports)
(let ([fd/error (foreign-call "ikrt_open_input_file"
(string->utf8 filename))])
(if (fixnum? fd/error)
(let ([port (make-input-port
(make-input-file-handler fd/error filename)
($make-bytevector 4096))])
(set-port-input-size! port 0)
(guardian port)
port)
(error 'open-input-file "cannot open file"
filename fd/error)))))
(define open-input-file
(lambda (filename)
(if (string? filename)
($open-input-file filename)
(error 'open-input-file "not a string" filename))))
(define with-input-from-file
(lambda (name proc)
(unless (string? name)
(error 'with-input-from-file "not a string" name))
(unless (procedure? proc)
(error 'with-input-from-file "not a procedure" proc))
(let ([p ($open-input-file name)])
(call-with-values
(lambda ()
(parameterize ([current-input-port p])
(proc)))
(case-lambda
[(v) (close-input-port p) v]
[v*
(close-input-port p)
(apply values v*)])))))
(define call-with-input-file
(lambda (name proc)
(unless (string? name)
(error 'call-with-input-file "not a string" name))
(unless (procedure? proc)
(error 'call-with-input-file "not a procedure" proc))
(let ([p ($open-input-file name)])
(call-with-values (lambda () (proc p))
(case-lambda
[(v) (close-input-port p) v]
[v*
(close-input-port p)
(apply values v*)])))))
(define *standard-input-port* #f)
(define *current-input-port* #f)
(define console-input-port
(lambda () *standard-input-port*))
(define standard-input-port
(lambda () *standard-input-port*))
(define current-input-port
(case-lambda
[() *current-input-port*]
[(p)
(if (input-port? p)
(set! *current-input-port* p)
(error 'current-input-port "not an input-port" p))]))
(set! *standard-input-port*
(let ([p (make-input-port
(make-input-file-handler 0 '*stdin*)
($make-bytevector 4096))])
(set-port-input-size! p 0)
p))
(set! *current-input-port* *standard-input-port*)
)

106
scheme/ikarus.io.input-strings.ss
View File

@ -1,106 +0,0 @@
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(library (ikarus io input-strings)
(export open-string-input-port)
(import
(ikarus system $strings)
(ikarus system $bytevectors)
(ikarus system $fx)
(ikarus system $pairs)
(ikarus system $ports)
(ikarus system $io)
(except (ikarus) open-string-input-port ))
(define-syntax message-case
(syntax-rules (else)
[(_ msg args
[(msg-name msg-arg* ...) b b* ...] ...
[else else1 else2 ...])
(let ([tmsg msg] [targs args])
(define-syntax match-and-bind
(syntax-rules ()
[(__ y () body)
(if (null? y)
body
(error 'message-case "unmatched" (cons tmsg targs)))]
[(__ y (a a* (... ...)) body)
(if (pair? y)
(let ([a (car y)] [d (cdr y)])
(match-and-bind d (a* (... ...)) body))
(error 'message-case "unmatched" (cons tmsg targs)))]))
(case tmsg
[(msg-name)
(match-and-bind targs (msg-arg* ...) (begin b b* ...))] ...
[else else1 else2 ...]))]))
(define make-input-string-handler
(lambda (str)
(let ((open? #t) (idx 0) (n (string-length str)))
(lambda (msg . args)
(message-case msg args
[(read-char p)
(if ($fx< idx n)
(let ([c ($string-ref str idx)])
(set! idx ($fxadd1 idx))
c)
(if open?
(eof-object)
(error 'read-char "port is closed" p)))]
[(peek-char p)
(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)))))
)

200
scheme/ikarus.io.output-bytevectors.ss
View File

@ -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 <http://www.gnu.org/licenses/>.
(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)))])))
)

237
scheme/ikarus.io.output-files.ss
View File

@ -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 <http://www.gnu.org/licenses/>.
(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*)
)

192
scheme/ikarus.io.output-strings.ss
View File

@ -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 <http://www.gnu.org/licenses/>.
(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)))))
)

527
lab/io-spec.ss → scheme/ikarus.io.ss
View File

@ -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))]))))
)

19
scheme/ikarus.predicates.ss
View File

@ -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)))
)

45
scheme/ikarus.strings.ss
View File

@ -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<? 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>? 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)])

35
scheme/ikarus.unicode-data.ss
View File

@ -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)

4
scheme/ikarus.writer.ss
View File

@ -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)

2
scheme/last-revision
View File

@ -1 +1 @@
1202
1203

28
scheme/makefile.ss
View File

@ -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")

1
scheme/pass-specify-rep-primops.ss
View File

@ -1740,6 +1740,7 @@
/section)
#;
(section ;;; ports
(define-primop port? safe

43
src/ikarus-io.c
View File

@ -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();
}
}

6
src/ikarus-runtime.c
View File

@ -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;
};