From e0851e67538b3dbcdd7263c1d499e50f2dfbf24f Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 23 Nov 2019 19:27:34 -0500
Subject: [PATCH] cs: range check on `seconds->date`

---
 racket/src/cs/rumble/error-rewrite.ss |  8 ++++-
 racket/src/cs/rumble/time.ss          | 49 ++++++++++++++++-----------
 2 files changed, 36 insertions(+), 21 deletions(-)

diff --git a/racket/src/cs/rumble/error-rewrite.ss b/racket/src/cs/rumble/error-rewrite.ss
index ff3d40c9ba..f14fbb11e4 100644
--- a/racket/src/cs/rumble/error-rewrite.ss
+++ b/racket/src/cs/rumble/error-rewrite.ss
@@ -30,6 +30,9 @@
    [(and (format-condition? v)
          (string-prefix? "~?.  Some debugging context lost" (condition-message v)))
     exn:fail]
+   [(and (who-condition? v)
+         (eq? 'time-utc->date (condition-who v)))
+    exn:fail]
    [else
     exn:fail:contract]))
 
@@ -53,7 +56,8 @@
                 flonum->fixnum fl->fx
                 fxarithmetic-shift-right fxrshift
                 fxarithmetic-shift-left fxlshift
-                real->flonum ->fl)
+                real->flonum ->fl
+                time-utc->date seconds->date)
         (set! rewrites-added? #t)))
     (getprop n 'error-rename n)))
 
@@ -107,6 +111,8 @@
     (let ([ctc (desc->contract (substring str (string-length is-not-a-str) (string-length str)))])
       (format-error-values (string-append "contract violation\n  expected: " ctc "\n  given: ~s")
                            irritants))]
+   [(eq? who 'time-utc->date)
+    (values "integer is out-of-range" null)]
    [else
     (format-error-values str irritants)]))
 
diff --git a/racket/src/cs/rumble/time.ss b/racket/src/cs/rumble/time.ss
index 5197710880..cb7978a2b2 100644
--- a/racket/src/cs/rumble/time.ss
+++ b/racket/src/cs/rumble/time.ss
@@ -111,25 +111,34 @@
    [(s local?)
     (check who real? s)
     (let* ([s (inexact->exact s)]
-           [tm (make-time 'time-utc
-                          (floor (* (- s (floor s)) 1000000000))
-                          (floor s))]
-           [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)))]))
+           [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"))