diff --git a/pkgs/racket-test-core/tests/racket/date.rktl b/pkgs/racket-test-core/tests/racket/date.rktl index a1bb43f7a6..46392fbbd9 100644 --- a/pkgs/racket-test-core/tests/racket/date.rktl +++ b/pkgs/racket-test-core/tests/racket/date.rktl @@ -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) diff --git a/racket/src/cs/io.sls b/racket/src/cs/io.sls index 59b90d054e..90d824868a 100644 --- a/racket/src/cs/io.sls +++ b/racket/src/cs/io.sls @@ -212,7 +212,44 @@ (ftype-ref rktio_identity_t (a_bits) p) (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 diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index 88be9eb660..d239c8f5d5 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -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 diff --git a/racket/src/cs/rumble/time.ss b/racket/src/cs/rumble/time.ss index cb7978a2b2..0d44123216 100644 --- a/racket/src/cs/rumble/time.ss +++ b/racket/src/cs/rumble/time.ss @@ -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 "?")) diff --git a/racket/src/cs/schemified/io.scm b/racket/src/cs/schemified/io.scm index c5bbd7e316..1f9c17ec9d 100644 --- a/racket/src/cs/schemified/io.scm +++ b/racket/src/cs/schemified/io.scm @@ -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 diff --git a/racket/src/io/demo.rkt b/racket/src/io/demo.rkt index 7c33decef8..638f56ac7f 100644 --- a/racket/src/io/demo.rkt +++ b/racket/src/io/demo.rkt @@ -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))))) diff --git a/racket/src/io/host/bootstrap-rktio.rkt b/racket/src/io/host/bootstrap-rktio.rkt index 3ff6758f4a..7673207bec 100644 --- a/racket/src/io/host/bootstrap-rktio.rkt +++ b/racket/src/io/host/bootstrap-rktio.rkt @@ -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 diff --git a/racket/src/io/host/rktio.rkt b/racket/src/io/host/rktio.rkt index 373563f110..0b06e51f75 100644 --- a/racket/src/io/host/rktio.rkt +++ b/racket/src/io/host/rktio.rkt @@ -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) diff --git a/racket/src/io/main.rkt b/racket/src/io/main.rkt index b600e8aaba..f6eff75fe5 100644 --- a/racket/src/io/main.rkt +++ b/racket/src/io/main.rkt @@ -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") diff --git a/racket/src/io/time/main.rkt b/racket/src/io/time/main.rkt new file mode 100644 index 0000000000..c4f15b4104 --- /dev/null +++ b/racket/src/io/time/main.rkt @@ -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")]))]))