suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Implement seconds->date in the io layer

Browse Source
This commit is contained in:
shuhung 2020-12-30 04:41:33 -06:00 committed by GitHub
parent 9842dd6216
commit 4b4ed24c65
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
10 changed files with 201 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/racket-test-core/tests/racket/date.rktl
View File

@ -124,11 +124,13 @@
(test 789/1000 - (date*->seconds d) (date->seconds d)))
;; Check some overflow handling on Windows:
(when (eq? (system-type) 'windows)
(let ([out-of-range (lambda (exn) (regexp-match? #rx"out-of-range" (exn-message exn)))])
(let ([out-of-range (lambda (exn) (regexp-match? #rx"out-of-range" (exn-message exn)))])
(when (eq? (system-type) 'windows)
(err/rt-test (seconds->date (expt 2 40)) out-of-range)
(err/rt-test (seconds->date (expt 2 50)) out-of-range)
(err/rt-test (seconds->date (expt 2 60)) out-of-range)))
(err/rt-test (seconds->date (expt 2 50)) out-of-range))
(err/rt-test (seconds->date (expt 2 80)) out-of-range)
(err/rt-test (seconds->date (expt 2 60)) out-of-range))
;; Check inexact arithmetic
(test (seconds->date 0 #f)

38
racket/src/cs/io.sls
View File

@ -213,6 +213,43 @@
(ftype-ref rktio_identity_t (b_bits) p)
(ftype-ref rktio_identity_t (c_bits) p))))
(define (rktio_seconds_to_date* rktio si nsecs get-gmt)
(cond
[(not (in-date-range? si))
(vector RKTIO_ERROR_KIND_RACKET
RKTIO_ERROR_TIME_OUT_OF_RANGE)]
[else
(unsafe-start-atomic)
(begin0
(let ([p (rktio_seconds_to_date rktio si nsecs get-gmt)])
(cond
[(vector? p) p]
[else
(let* ([dt (make-ftype-pointer rktio_date_t (ptr->address p))]
[tzn (address->ptr (ftype-ref rktio_date_t (zone_name) dt))])
(begin0
(date*
(ftype-ref rktio_date_t (second) dt)
(ftype-ref rktio_date_t (minute) dt)
(ftype-ref rktio_date_t (hour) dt)
(ftype-ref rktio_date_t (day) dt)
(ftype-ref rktio_date_t (month) dt)
(ftype-ref rktio_date_t (year) dt)
(ftype-ref rktio_date_t (day_of_week) dt)
(ftype-ref rktio_date_t (day_of_year) dt)
(if (fx= 0 (ftype-ref rktio_date_t (is_dst) dt))
#f
#t)
(ftype-ref rktio_date_t (zone_offset) dt)
(ftype-ref rktio_date_t (nanosecond) dt)
(if (eqv? tzn NULL)
unknown-zone-name
(string->immutable-string (utf8->string (rktio_to_bytes tzn)))))
(unless (eqv? tzn NULL)
(rktio_free tzn))
(rktio_free p)))]))
(unsafe-end-atomic))]))
(define (rktio_convert_result_to_vector p)
(let ([p (make-ftype-pointer rktio_convert_result_t (ptr->address p))])
(vector
@ -356,6 +393,7 @@
'rktio_recv_length_ref rktio_recv_length_ref
'rktio_recv_address_ref rktio_recv_address_ref
'rktio_identity_to_vector rktio_identity_to_vector
'rktio_seconds_to_date* rktio_seconds_to_date*
'rktio_convert_result_to_vector rktio_convert_result_to_vector
'rktio_to_bytes rktio_to_bytes
'rktio_to_bytes_list rktio_to_bytes_list

2
racket/src/cs/rumble.sls
View File

@ -133,6 +133,7 @@
struct:date* date*? date* make-date*
date*-nanosecond date*-time-zone-name
in-date-range? unknown-zone-name ;; not exported to Racket
struct:arity-at-least arity-at-least arity-at-least?
arity-at-least-value
@ -470,7 +471,6 @@
current-milliseconds
current-gc-milliseconds
current-seconds
seconds->date
collect-garbage
current-memory-use

33
racket/src/cs/rumble/time.ss
View File

@ -105,40 +105,9 @@
(let ((t (current-time 'time-utc)))
(time-second t)))
(define/who seconds->date
(case-lambda
[(s) (seconds->date s #t)]
[(s local?)
(check who real? s)
(let* ([s (inexact->exact s)]
[si (floor s)])
(unless (in-date-range? si)
(raise-arguments-error who "integer is out-of-range"
"integer" si))
(let* ([tm (make-time 'time-utc
(floor (* (- s si) 1000000000))
si)]
[d (if local?
(time-utc->date tm)
(time-utc->date tm 0))])
(make-date*/direct (chez:date-second d)
(chez:date-minute d)
(chez:date-hour d)
(chez:date-day d)
(chez:date-month d)
(chez:date-year d)
(chez:date-week-day d)
(chez:date-year-day d)
(chez:date-dst? d)
(date-zone-offset d)
(date-nanosecond d)
(or (let ([n (date-zone-name d)])
(and n (string->immutable-string n)))
utc-string))))]))
(define (in-date-range? si)
(if (> (fixnum-width) 32)
(<= -9223372036854775808 si 9223372036854775807)
(<= -2147483648 si 2147483647)))
(define utc-string (string->immutable-string "UTC"))
(define unknown-zone-name (string->immutable-string "?"))

56
racket/src/cs/schemified/io.scm
View File

@ -228,6 +228,7 @@
(1/relative-path? relative-path?)
(1/rename-file-or-directory rename-file-or-directory)
(1/resolve-path resolve-path)
(1/seconds->date seconds->date)
(1/security-guard-check-file security-guard-check-file)
(1/security-guard-check-file-link
security-guard-check-file-link)
@ -3030,6 +3031,7 @@
(define RKTIO_ERROR_INFO_TRY_AGAIN 22)
(define RKTIO_ERROR_TRY_AGAIN 23)
(define RKTIO_ERROR_TRY_AGAIN_WITH_IPV_2541 24)
(define RKTIO_ERROR_TIME_OUT_OF_RANGE 25)
(define RKTIO_ERROR_CONVERT_NOT_ENOUGH_SPACE 28)
(define RKTIO_ERROR_CONVERT_BAD_SEQUENCE 29)
(define RKTIO_ERROR_CONVERT_PREMATURE_END 30)
@ -3428,6 +3430,8 @@
(begin-unsafe (hash-ref rktio-table 'rktio_recv_address_ref)))
(define rktio_identity_to_vector
(begin-unsafe (hash-ref rktio-table 'rktio_identity_to_vector)))
(define rktio_seconds_to_date*
(begin-unsafe (hash-ref rktio-table 'rktio_seconds_to_date*)))
(define rktio_convert_result_to_vector
(begin-unsafe (hash-ref rktio-table 'rktio_convert_result_to_vector)))
(define rktio_to_bytes (begin-unsafe (hash-ref rktio-table 'rktio_to_bytes)))
@ -33741,11 +33745,11 @@
'subprocess
"(or/c (and/c output-port? file-stream-port?) #f 'stdout)"
stderr_0))
(let ((lr1121 unsafe-undefined)
(let ((lr1122 unsafe-undefined)
(group_0 unsafe-undefined)
(command_0 unsafe-undefined)
(exact/args_0 unsafe-undefined))
(set! lr1121
(set! lr1122
(call-with-values
(lambda ()
(if (path-string? group/command_0)
@ -33800,9 +33804,9 @@
((group_1 command_1 exact/args_1)
(vector group_1 command_1 exact/args_1))
(args (raise-binding-result-arity-error 3 args)))))
(set! group_0 (unsafe-vector*-ref lr1121 0))
(set! command_0 (unsafe-vector*-ref lr1121 1))
(set! exact/args_0 (unsafe-vector*-ref lr1121 2))
(set! group_0 (unsafe-vector*-ref lr1122 0))
(set! command_0 (unsafe-vector*-ref lr1122 1))
(set! exact/args_0 (unsafe-vector*-ref lr1122 2))
(call-with-values
(lambda ()
(if (if (pair? exact/args_0)
@ -38081,6 +38085,48 @@
p_0))
p_0))
'current-load-extension))
(define rktio_seconds_to_date-error-kind (vector-immutable 3 25))
(define 1/seconds->date
(|#%name|
seconds->date
(case-lambda
((s_0) (begin (1/seconds->date s_0 #t)))
((s_0 local?_0)
(begin
(if (real? s_0)
(void)
(raise-argument-error 'seconds->date "real?" s_0))
(let ((s_1 (inexact->exact s_0)))
(let ((si_0 (floor s_1)))
(let ((get-gmt_0 (if local?_0 0 1)))
(let ((nsecs_0 (floor (* (- s_1 si_0) 1000000000))))
(let ((dt_0
(|#%app|
rktio_seconds_to_date*
(unsafe-place-local-ref cell.1)
si_0
nsecs_0
get-gmt_0)))
(if (date*? dt_0)
dt_0
(if (equal? dt_0 rktio_seconds_to_date-error-kind)
(raise-arguments-error
'seconds->date
"integer is out-of-range"
"integer"
si_0)
(let ((base-msg_0 "conversion error"))
(begin-unsafe
(raise
(let ((app_0
(format-rktio-message
'seconds->date
dt_0
base-msg_0)))
(|#%app|
exn:fail
app_0
(current-continuation-marks))))))))))))))))))
(define 1/unsafe-poller
(|#%name|
unsafe-poller

21
racket/src/io/demo.rkt
View File

@ -919,3 +919,24 @@
(test 3 (bytes-utf-8-index #"apple" 3))
(test 4 (bytes-utf-8-index (string->bytes/utf-8 "apλple") 3))
(test 1969 (date-year (seconds->date (- (* 24 60 60)))))
(let* ([s (current-seconds)]
[d1 (seconds->date s)]
[d2 (seconds->date (+ s 1/100000000))])
(test 0 (date*-nanosecond d1))
(test 10 (date*-nanosecond d2))
(test (date*-time-zone-name d1) (date*-time-zone-name d2))
(test (struct-copy date d1) (struct-copy date d2)))
(test (seconds->date 0 #f)
(seconds->date 0.1e-16 #f))
(test (date* 59 59 23 31 12 1969 3 364 #f 0 999999999 "UTC")
(seconds->date -0.1e-16 #f))
(let ([out-of-range (lambda (exn) (regexp-match? #rx"out-of-range" (exn-message exn)))])
(test #t (with-handlers ([exn:fail? out-of-range])
(seconds->date (expt 2 60))))
(test #t (with-handlers ([exn:fail? out-of-range])
(seconds->date (expt 2 80)))))

42
racket/src/io/host/bootstrap-rktio.rkt
View File

@ -1,6 +1,8 @@
#lang racket/base
(require racket/include
racket/fixnum
(only-in '#%linklet primitive-table)
(only-in '#%kernel [date* kernel:date*])
ffi/unsafe
ffi/unsafe/atomic
(for-syntax racket/base)
@ -113,6 +115,45 @@
(Rrktio_identity_t-b_bits p)
(Rrktio_identity_t-c_bits p))))
(define (in-date-range? si)
(if (fixnum? (expt 2 33))
(<= -9223372036854775808 si 9223372036854775807)
(<= -2147483648 si 2147483647)))
(define unknown-zone-name (string->immutable-string "?"))
(define (rktio_seconds_to_date* rktio si nsecs get-gmt)
(cond
[(not (in-date-range? si))
(vector RKTIO_ERROR_KIND_RACKET
RKTIO_ERROR_TIME_OUT_OF_RANGE)]
[else
(let ([p (rktio_seconds_to_date rktio si nsecs get-gmt)])
(cond
[(vector? p) p]
[else
(define dt (cast p _pointer _Rrktio_date_t-pointer))
(define tzn (Rrktio_date_t-zone_name dt))
(begin0
(kernel:date*
(Rrktio_date_t-second dt)
(Rrktio_date_t-minute dt)
(Rrktio_date_t-hour dt)
(Rrktio_date_t-day dt)
(Rrktio_date_t-month dt)
(Rrktio_date_t-year dt)
(Rrktio_date_t-day_of_week dt)
(Rrktio_date_t-day_of_year dt)
(if (fx= 0 (Rrktio_date_t-is_dst dt)) #f #t)
(Rrktio_date_t-zone_offset dt)
(Rrktio_date_t-nanosecond dt)
(if tzn
(string->immutable-string (bytes->string/utf-8 (rktio_to_bytes tzn)))
unknown-zone-name))
(unless tzn
(rktio_free tzn))
(rktio_free p))]))]))
(define (rktio_convert_result_to_vector p)
(let ([p (cast p _pointer _Rrktio_convert_result_t-pointer)])
(vector
@ -216,6 +257,7 @@
'rktio_recv_length_ref rktio_recv_length_ref
'rktio_recv_address_ref rktio_recv_address_ref
'rktio_identity_to_vector rktio_identity_to_vector
'rktio_seconds_to_date* rktio_seconds_to_date*
'rktio_convert_result_to_vector rktio_convert_result_to_vector
'rktio_to_bytes rktio_to_bytes
'rktio_to_bytes_list rktio_to_bytes_list

1
racket/src/io/host/rktio.rkt
View File

@ -49,6 +49,7 @@
(define-function () #f rktio_recv_length_ref)
(define-function () #f rktio_recv_address_ref)
(define-function () #f rktio_identity_to_vector)
(define-function () #f rktio_seconds_to_date*)
(define-function () #f rktio_convert_result_to_vector)
(define-function () #f rktio_to_bytes)
(define-function () #f rktio_to_bytes_list)

2
racket/src/io/main.rkt
View File

@ -19,6 +19,7 @@
"host/processor-count.rkt"
"network/main.rkt"
"foreign/main.rkt"
"time/main.rkt"
"unsafe/main.rkt"
"machine/main.rkt"
"run/main.rkt"
@ -59,6 +60,7 @@
(all-from-out "host/processor-count.rkt")
(all-from-out "network/main.rkt")
(all-from-out "foreign/main.rkt")
(all-from-out "time/main.rkt")
(all-from-out "unsafe/main.rkt")
(all-from-out "machine/main.rkt")
(all-from-out "run/main.rkt")

37
racket/src/io/time/main.rkt Normal file
View File

@ -0,0 +1,37 @@
#lang racket/base
(provide seconds->date)
(require racket/fixnum
(only-in '#%kernel [date*? kernel:date*?])
"../common/check.rkt"
"../host/rktio.rkt"
"../host/error.rkt"
"../string/main.rkt"
"../error/main.rkt")
(define rktio_seconds_to_date-error-kind
(vector-immutable RKTIO_ERROR_KIND_RACKET
RKTIO_ERROR_TIME_OUT_OF_RANGE ))
(define/who seconds->date
(case-lambda
[(s) (seconds->date s #t)]
[(s local?)
(check who real? s)
(let* ([s (inexact->exact s)]
[si (floor s)]
[get-gmt (if local? 0 1)]
[nsecs (floor (* (- s si) 1000000000))]
;; The allocation, deallocation and the conversion of the
;; rktio_date_t* result is hidden in rktio_seconds_to_date*,
;; therefore no atomicity is needed here.
[dt (rktio_seconds_to_date* rktio si nsecs get-gmt)])
(cond
[(kernel:date*? dt)
dt]
[(equal? dt rktio_seconds_to_date-error-kind)
(raise-arguments-error who "integer is out-of-range"
"integer" si)]
[else
(raise-rktio-error who dt "conversion error")]))]))