Implement seconds->date in the io layer

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)))])
+  (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 50)) out-of-range))
-    (err/rt-test (seconds->date (expt 2 60)) 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)

racket/src/cs/io.sls

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

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

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

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! group_0 (unsafe-vector*-ref lr1122 0))
-               (set! command_0 (unsafe-vector*-ref lr1121 1))
+               (set! command_0 (unsafe-vector*-ref lr1122 1))
-               (set! exact/args_0 (unsafe-vector*-ref lr1121 2))
+               (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

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

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

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)

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

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