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

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

object and returns the offset from gmt in seconds.
This commit is contained in:
Abdulaziz Ghuloum 2007-12-09 07:20:49 -05:00
parent efd233ad0e
commit 1d5c069273
10 changed files with 303 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

141
lab/io-spec.ss
View File

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

149
lab/io-test.ss
View File

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

9
scheme/ikarus.time-and-date.ss
View File

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

2
scheme/last-revision
View File

@ -1 +1 @@
1199
1200

1
scheme/makefile.ss
View File

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

6
scheme/psyntax.expander.ss
View File

@ -1076,11 +1076,7 @@
[others
(syntax-violation #f "malformed bindings"
stx others)])])))))))
(define trace-lambda-macro
(lambda (stx)
(syntax-match stx ()

6
src/Makefile.am
View File

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

10
src/Makefile.in
View File

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

70
src/ikarus-io.c Normal file
View File

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

14
src/ikarus-runtime.c
View File

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