diff --git a/lab/io-spec.ss b/lab/io-spec.ss index 995a06c..2440af9 100644 --- a/lab/io-spec.ss +++ b/lab/io-spec.ss @@ -453,44 +453,55 @@ (cond [(fx= bytes 0) (do-error p who)] - [else (get-char-utf8-mode p who)]))])] + [else (lookahead-char-utf8-mode p who)]))])] [else (do-error p who)]))]))) - (define (advance-utf8-bom p who) - (let ([i ($port-index p)] - [j ($port-size p)] - [buf ($port-buffer p)]) - (cond - [(fx< (fx+ i 3) j) - (when (and (fx=? (bytevector-u8-ref buf i) #xEF) - (fx=? (bytevector-u8-ref buf i) #xBB) - (fx=? (bytevector-u8-ref buf i) #xBF)) - ($set-port-index! p (fx+ i 3)))] - [else - (let ([c (fx- j i)]) - (bytevector-copy! buf i buf 0 c) - (let ([read! ($port-read! p)]) - (let ([c1 (read! buf c (fx- (bytevector-length buf) c))]) - ($set-port-index! p c) - ($set-port-size! p (fx+ c c1)) - (unless (fx= c1 0) - (advance-utf8-bom p who)))))]))) + (define (advance-bom p who bom-seq) + ;;; return eof if port is eof, + ;;; #t if a bom is present, updating the port index to + ;;; point just past the bom. + ;;; #f otherwise. + (cond + [(fx< ($port-index p) ($port-size p)) + (let f ([i 0] [ls bom-seq]) + (cond + [(null? ls) + ($set-port-index! p (fx+ ($port-index p) i)) + #t] + [else + (let ([idx (fx+ i ($port-index p))]) + (cond + [(fx< idx ($port-size p)) + (if (fx=? (car ls) + (bytevector-u8-ref ($port-buffer p) idx)) + (f (fx+ i 1) (cdr ls)) + #f)] + [else + (let ([bytes (refill-bv-buffer p who)]) + (if (fx= bytes 0) + #f + (f i ls)))]))]))] + [else + (let ([bytes (refill-bv-buffer p who)]) + (if (fx= bytes 0) + (eof-object) + (advance-bom p who bom-seq)))])) (define (speedup-input-port p who) + ;;; returns #t if port is eof, #f otherwise (unless (input-port? p) (error who "not an input port" p)) (let ([tr ($port-transcoder p)]) (unless tr (error who "not a textual port" p)) (case (transcoder-codec tr) - [(utf-8-codec) + [(utf-8-codec) ;;; - (advance-utf8-bom p who) ($set-port-attrs! p - (fxior fast-get-tag fast-get-utf8-tag))] + (fxior fast-get-tag fast-get-utf8-tag)) + (eof-object? (advance-bom p who '(#xEF #xBB #xBF)))] [else (error 'slow-get-char "codec not handled")]))) - (define-rrr slow-lookahead-char) (define (lookahead-char-char-mode p who) (let ([str ($port-buffer p)] @@ -538,8 +549,9 @@ [else (get-char-latin-mode p who 0)]))] [else - (speedup-input-port p who) - (lookahead-char p)]))) + (if (speedup-input-port p who) + (eof-object) + (lookahead-char p))]))) ;;; (define (get-char-char-mode p who) (let ([str ($port-buffer p)] @@ -591,8 +603,9 @@ [else (get-char-latin-mode p who 1)]))] [else - (speedup-input-port p who) - (get-char p)])))) + (if (speedup-input-port p who) + (eof-object) + (get-char p))])))) ;;; ---------------------------------------------------------- (define (assert-binary-input-port p who) @@ -667,9 +680,77 @@ (eof-object? (lookahead-u8 p)))] [else (error 'port-eof? "not an input port" p)]))) + (define io-errors-vec + '#("unknown error" + "bad file name" + "operation interrupted" + "not a directory" + "file name too long" + "missing entities" + "insufficient access privileges" + "circular path" + "file is a directory" + "file system is read-only" + "maximum open files reached" + "maximum open files reached" + "ENXIO" + "operation not supported" + "not enough space on device" + "quota exceeded" + "io error" + "device is busy" + "access fault" + "file already exists" + "invalid file name")) + + (define (io-error who id err) + (let ([msg + (let ([err (- err)]) + (cond + [(fx< err (vector-length io-errors-vec)) + "unknown error"] + [else (vector-ref io-errors-vec err)]))]) + (raise + (condition + (make-who-condition who) + (make-message-condition msg) + (make-i/o-filename-error id))))) + + (define read-size 4096) + (define file-buffer-size (+ read-size 128)) + + (define (fh->input-port fd id size transcoder close?) + ($make-port 0 0 (make-bytevector size) 0 + transcoder + #f ;;; closed? + (input-transcoder-attrs transcoder) + id + (lambda (bv idx cnt) + (let ([bytes + (foreign-call "ikrt_read_fd" fd bv idx + (fxmin read-size cnt))]) + (when (fx< bytes 0) (io-error 'read id bytes)) + bytes)) + #f ;;; write! + #f ;;; get-position + #f ;;; set-position! + (and close? + (lambda () + (cond + [(foreign-call "ikrt_close_fd" fd) => + (lambda (err) + (io-error 'close id err))]))))) + (define-rrr open-file-input-port) - (define-rrr standard-input-port) - (define-rrr current-input-port) + + (define (standard-input-port) + (fh->input-port 0 '*stdin* 256 #f #f)) + + (define *the-input-port* + (transcoded-port (standard-input-port) (native-transcoder))) + + (define (current-input-port) *the-input-port*) + (define (call-with-port p proc) (if ($port? p) diff --git a/lab/io-test.ss b/lab/io-test.ss index c9b298e..83369f9 100755 --- a/lab/io-test.ss +++ b/lab/io-test.ss @@ -299,74 +299,97 @@ [else (error #f "mismatch" x (string-ref str i) i)])))) -(test "utf8 range 2" - (test-port-string-output - (open-bytevector-input-port (make-utf8-bytevector-range2) - (make-transcoder (utf-8-codec) 'none 'raise)) - (make-utf8-string-range2))) +(define (run-exhaustive-tests) + (test "utf8 range 2" + (test-port-string-output + (open-bytevector-input-port (make-utf8-bytevector-range2) + (make-transcoder (utf-8-codec) 'none 'raise)) + (make-utf8-string-range2))) + + (test "utf8 range 3" + (test-port-string-output + (open-bytevector-input-port (make-utf8-bytevector-range3) + (make-transcoder (utf-8-codec) 'none 'raise)) + (make-utf8-string-range3))) + + (test "utf8 range 4" + (test-port-string-output + (open-bytevector-input-port (make-utf8-bytevector-range4) + (make-transcoder (utf-8-codec) 'none 'raise)) + (make-utf8-string-range4))) + + (test "utf8 peek range 2" + (test-port-string-peeking-output + (open-bytevector-input-port (make-utf8-bytevector-range2) + (make-transcoder (utf-8-codec) 'none 'raise)) + (make-utf8-string-range2))) + + (test "utf8 peek range 3" + (test-port-string-peeking-output + (open-bytevector-input-port (make-utf8-bytevector-range3) + (make-transcoder (utf-8-codec) 'none 'raise)) + (make-utf8-string-range3))) + + (test "utf8 peek range 4" + (test-port-string-peeking-output + (open-bytevector-input-port (make-utf8-bytevector-range4) + (make-transcoder (utf-8-codec) 'none 'raise)) + (make-utf8-string-range4))) + + (test "utf8 range 2 string" + (test-port-string-output + (open-string-input-port (make-utf8-string-range2)) + (make-utf8-string-range2))) + + (test "utf8 range 3 string" + (test-port-string-output + (open-string-input-port (make-utf8-string-range3)) + (make-utf8-string-range3))) + + (test "utf8 range 4 string" + (test-port-string-output + (open-string-input-port (make-utf8-string-range4)) + (make-utf8-string-range4))) + + (test "utf8 peek range 2 string" + (test-port-string-peeking-output + (open-string-input-port (make-utf8-string-range2)) + (make-utf8-string-range2))) + + (test "utf8 peek range 3 string" + (test-port-string-peeking-output + (open-string-input-port (make-utf8-string-range3)) + (make-utf8-string-range3))) + + (test "utf8 peek range 4 string" + (test-port-string-peeking-output + (open-string-input-port (make-utf8-string-range4)) + (make-utf8-string-range4)))) -(test "utf8 range 3" - (test-port-string-output - (open-bytevector-input-port (make-utf8-bytevector-range3) - (make-transcoder (utf-8-codec) 'none 'raise)) - (make-utf8-string-range3))) -(test "utf8 range 4" - (test-port-string-output - (open-bytevector-input-port (make-utf8-bytevector-range4) - (make-transcoder (utf-8-codec) 'none 'raise)) - (make-utf8-string-range4))) - -(test "utf8 peek range 2" - (test-port-string-peeking-output - (open-bytevector-input-port (make-utf8-bytevector-range2) - (make-transcoder (utf-8-codec) 'none 'raise)) - (make-utf8-string-range2))) - -(test "utf8 peek range 3" - (test-port-string-peeking-output - (open-bytevector-input-port (make-utf8-bytevector-range3) - (make-transcoder (utf-8-codec) 'none 'raise)) - (make-utf8-string-range3))) - -(test "utf8 peek range 4" - (test-port-string-peeking-output - (open-bytevector-input-port (make-utf8-bytevector-range4) - (make-transcoder (utf-8-codec) 'none 'raise)) - (make-utf8-string-range4))) - -(test "utf8 range 2 string" - (test-port-string-output - (open-string-input-port (make-utf8-string-range2)) - (make-utf8-string-range2))) - -(test "utf8 range 3 string" - (test-port-string-output - (open-string-input-port (make-utf8-string-range3)) - (make-utf8-string-range3))) - -(test "utf8 range 4 string" - (test-port-string-output - (open-string-input-port (make-utf8-string-range4)) - (make-utf8-string-range4))) - -(test "utf8 peek range 2 string" - (test-port-string-peeking-output - (open-string-input-port (make-utf8-string-range2)) - (make-utf8-string-range2))) - -(test "utf8 peek range 3 string" - (test-port-string-peeking-output - (open-string-input-port (make-utf8-string-range3)) - (make-utf8-string-range3))) - -(test "utf8 peek range 4 string" - (test-port-string-peeking-output - (open-string-input-port (make-utf8-string-range4)) - (make-utf8-string-range4))) +(display "now write something on the keyboard ...\n") +(printf "you typed ~s\n" + (list->string + (let ([p (standard-input-port)]) + (let f () + (let ([x (get-u8 p)]) + (if (eof-object? x) + '() + (cons (integer->char x) (f)))))))) +(display "let's do it again ...\n") +(printf "you typed ~s\n" + (list->string + (let ([p (transcoded-port (standard-input-port) + (make-transcoder (utf-8-codec)))]) + (let f () + (let ([x (get-char p)]) + (if (eof-object? x) + '() + (cons x (f)))))))) +(run-exhaustive-tests) diff --git a/scheme/ikarus.time-and-date.ss b/scheme/ikarus.time-and-date.ss index 9bdb026..ed822a5 100644 --- a/scheme/ikarus.time-and-date.ss +++ b/scheme/ikarus.time-and-date.ss @@ -15,10 +15,11 @@ (library (ikarus system time-and-date) - (export current-time time? time-second time-nanosecond) + (export current-time time? time-second time-nanosecond + time-gmt-offset) (import (except (ikarus) time current-time time? time-second - time-nanosecond)) + time-nanosecond time-gmt-offset)) (define-struct time (msecs secs usecs)) ;;; mega/seconds/micros @@ -37,5 +38,9 @@ (* (time-usecs x) 1000) (error 'time-nanosecond "not a time" x))) + (define (time-gmt-offset x) + (if (time? x) + (foreign-call "ikrt_gmt_offset" x) + (error 'time-gmt-offset "not a time" x))) ) diff --git a/scheme/last-revision b/scheme/last-revision index ad9544a..59a3ec5 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1199 +1200 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 493a0ef..2012de8 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -377,6 +377,7 @@ [current-time i] [time? i] [time-second i] + [time-gmt-offset i] [time-nanosecond i] [command-line-arguments i] [set-rtd-printer! i] diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index 0ee4de0..f90ab48 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -1076,11 +1076,7 @@ [others (syntax-violation #f "malformed bindings" stx others)])]))))))) - - - - - + (define trace-lambda-macro (lambda (stx) (syntax-match stx () diff --git a/src/Makefile.am b/src/Makefile.am index 7f9d633..6a22301 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -1,7 +1,11 @@ bin_PROGRAMS = ikarus scheme-script -ikarus_SOURCES = ikarus-collect.c ikarus-exec.c ikarus-fasl.c ikarus-flonums.c ikarus-main.c ikarus-numerics.c ikarus-print.c ikarus-runtime.c ikarus-symbol-table.c ikarus-verify-integrity.c ikarus-weak-pairs.c ikarus-winmmap.c ikarus-data.h ikarus-winmmap.h ikarus-enter.s cpu_has_sse2.s +ikarus_SOURCES = ikarus-collect.c ikarus-exec.c ikarus-fasl.c \ + ikarus-flonums.c ikarus-main.c ikarus-numerics.c ikarus-print.c \ + ikarus-runtime.c ikarus-symbol-table.c ikarus-verify-integrity.c \ + ikarus-weak-pairs.c ikarus-winmmap.c ikarus-data.h \ + ikarus-winmmap.h ikarus-enter.s cpu_has_sse2.s ikarus-io.c scheme_script_SOURCES = scheme-script.c diff --git a/src/Makefile.in b/src/Makefile.in index 6ba57f4..e40332c 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -53,7 +53,7 @@ am_ikarus_OBJECTS = ikarus-collect.$(OBJEXT) ikarus-exec.$(OBJEXT) \ ikarus-symbol-table.$(OBJEXT) \ ikarus-verify-integrity.$(OBJEXT) ikarus-weak-pairs.$(OBJEXT) \ ikarus-winmmap.$(OBJEXT) ikarus-enter.$(OBJEXT) \ - cpu_has_sse2.$(OBJEXT) + cpu_has_sse2.$(OBJEXT) ikarus-io.$(OBJEXT) nodist_ikarus_OBJECTS = ikarus_OBJECTS = $(am_ikarus_OBJECTS) $(nodist_ikarus_OBJECTS) ikarus_LDADD = $(LDADD) @@ -174,7 +174,12 @@ target_os = @target_os@ target_vendor = @target_vendor@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ -ikarus_SOURCES = ikarus-collect.c ikarus-exec.c ikarus-fasl.c ikarus-flonums.c ikarus-main.c ikarus-numerics.c ikarus-print.c ikarus-runtime.c ikarus-symbol-table.c ikarus-verify-integrity.c ikarus-weak-pairs.c ikarus-winmmap.c ikarus-data.h ikarus-winmmap.h ikarus-enter.s cpu_has_sse2.s +ikarus_SOURCES = ikarus-collect.c ikarus-exec.c ikarus-fasl.c \ + ikarus-flonums.c ikarus-main.c ikarus-numerics.c ikarus-print.c \ + ikarus-runtime.c ikarus-symbol-table.c ikarus-verify-integrity.c \ + ikarus-weak-pairs.c ikarus-winmmap.c ikarus-data.h \ + ikarus-winmmap.h ikarus-enter.s cpu_has_sse2.s ikarus-io.c + scheme_script_SOURCES = scheme-script.c nodist_ikarus_SOURCES = bootfileloc.h BUILT_SOURCES = bootfileloc.h @@ -253,6 +258,7 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-exec.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-fasl.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-flonums.Po@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-io.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-main.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-numerics.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-print.Po@am__quote@ diff --git a/src/ikarus-io.c b/src/ikarus-io.c new file mode 100644 index 0000000..bd0c0ee --- /dev/null +++ b/src/ikarus-io.c @@ -0,0 +1,70 @@ +#include +#include +#include +#include +#include +#include + +#include "ikarus-data.h" + +ikp +ikrt_io_error(){ + switch(errno){ + case EBADF : return fix(-2); + case EINTR : return fix(-3); + case ENOTDIR : return fix(-4); + case ENAMETOOLONG : return fix(-5); + case ENOENT : return fix(-6); + case EACCES : return fix(-7); + case ELOOP : return fix(-8); + case EISDIR : return fix(-9); + case EROFS : return fix(-10); + case EMFILE : return fix(-11); + case ENFILE : return fix(-12); + case ENXIO : return fix(-13); + case EOPNOTSUPP : return fix(-14); + case ENOSPC : return fix(-15); + case EDQUOT : return fix(-16); + case EIO : return fix(-17); + case ETXTBSY : return fix(-18); + case EFAULT : return fix(-19); + case EEXIST : return fix(-20); + case EINVAL : return fix(-21); + } + return fix(-1); +} + + +ikp +ikrt_close_fd(ikp fd, ikpcb* pcb){ + int err = close(unfix(fd)); + if(err == -1){ + return ikrt_io_error(); + } else { + return false_object;; + } +} + +ikp +ikrt_open_input_fd(ikp fn, ikpcb* pcb){ + int fh = open((char*)(fn+off_bytevector_data, O_RDONLY), 0); + 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 = + read(unfix(fd), + (char*)(bv+off_bytevector_data+unfix(off)), + unfix(cnt)); + if(bytes >= 0){ + return fix(bytes); + } else { + return ikrt_io_error(); + } +} + diff --git a/src/ikarus-runtime.c b/src/ikarus-runtime.c index 5668b7f..3906c87 100644 --- a/src/ikarus-runtime.c +++ b/src/ikarus-runtime.c @@ -854,7 +854,6 @@ ikrt_bvftime(ikp outbv, ikp fmtbv){ - ikp ikrt_close_file(ikp fd, ikpcb* pcb){ int err = close(unfix(fd)); @@ -865,6 +864,8 @@ ikrt_close_file(ikp fd, ikpcb* pcb){ } } + + ikp ikrt_read(ikp fd, ikp buff, ikpcb* pcb){ if(tagof(buff) != bytevector_tag){ fprintf(stderr, "%p is not a bytevector", buff); @@ -1018,6 +1019,17 @@ ikrt_current_time(ikp t){ return t; } +ikp +ikrt_gmt_offset(ikp t){ + time_t clock = + unfix(ref(t, off_record_data + 0*wordsize)) * 1000000 + + unfix(ref(t, off_record_data + 1*wordsize)); + struct tm* m = localtime(&clock); + ikp r = fix(m->tm_gmtoff); + return r; +} + + ikp