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

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)

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

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

Binary file not shown.

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)

View File

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

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)

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)

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)

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)

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

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

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

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

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)