Fixes bug 175057: Added time-gmt-offset procedure that takes a time

object and returns the offset from gmt in seconds.

lab/io-spec.ss

@@ -453,30 +453,42 @@
                      (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)
+    (define (advance-bom p who bom-seq)
-      (let ([i ($port-index p)]
+      ;;; return eof if port is eof, 
-            [j ($port-size p)]
+      ;;; #t if a bom is present, updating the port index to 
-            [buf ($port-buffer p)])
+      ;;;    point just past the bom.
+      ;;; #f otherwise. 
       (cond
-          [(fx< (fx+ i 3) j) 
+        [(fx< ($port-index p) ($port-size p))
-           (when (and (fx=? (bytevector-u8-ref buf i) #xEF)
+         (let f ([i 0] [ls bom-seq])
-                      (fx=? (bytevector-u8-ref buf i) #xBB) 
+           (cond
-                      (fx=? (bytevector-u8-ref buf i) #xBF))
+             [(null? ls)
-             ($set-port-index! p (fx+ i 3)))]
+              ($set-port-index! p (fx+ ($port-index p) i))
+              #t]
              [else
-           (let ([c (fx- j i)])
+              (let ([idx (fx+ i ($port-index p))])
-             (bytevector-copy! buf i buf 0 c)
+                (cond
-             (let ([read! ($port-read! p)])
+                  [(fx< idx ($port-size p))
-               (let ([c1 (read! buf c (fx- (bytevector-length buf) c))])
+                   (if (fx=? (car ls)
-                 ($set-port-index! p c)
+                         (bytevector-u8-ref ($port-buffer p) idx))
-                 ($set-port-size! p (fx+ c c1))
+                       (f (fx+ i 1) (cdr ls))
-                 (unless (fx= c1 0) 
+                       #f)]
-                   (advance-utf8-bom p who)))))])))
+                  [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)])
@@ -485,12 +497,11 @@
         (case (transcoder-codec tr)
           [(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)
+           (if (speedup-input-port p who)
-           (lookahead-char p)])))
+               (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)
+           (if (speedup-input-port p who)
-           (get-char p)]))))
+               (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) 

lab/io-test.ss

@@ -299,6 +299,7 @@
         [else 
          (error #f "mismatch" x (string-ref str i) i)]))))
 
+(define (run-exhaustive-tests)
   (test "utf8 range 2"
     (test-port-string-output
       (open-bytevector-input-port (make-utf8-bytevector-range2)
@@ -363,10 +364,32 @@
   (test "utf8 peek range 4 string"
     (test-port-string-peeking-output
       (open-string-input-port (make-utf8-string-range4))
-    (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)

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

scheme/last-revision

@@ -1 +1 @@
-1199
+1200

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]

scheme/psyntax.expander.ss

@@ -1077,10 +1077,6 @@
                    (syntax-violation #f "malformed bindings"
                       stx others)])])))))))
   
-
-
-                     
-
   (define trace-lambda-macro
     (lambda (stx)
       (syntax-match stx ()

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
           

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@

src/ikarus-io.c

@@ -0,0 +1,70 @@
+#include <stdio.h>
+#include <fcntl.h>
+#include <errno.h>
+#include <sys/types.h>
+#include <sys/uio.h>
+#include <unistd.h>
+
+#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();
+  }
+}
+

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