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

cs: range check on seconds->date

Browse Source
This commit is contained in:
Matthew Flatt 2019-11-23 19:27:34 -05:00
parent c611f126fd
commit e0851e6753
2 changed files with 36 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
racket/src/cs/rumble/error-rewrite.ss
View File

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

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

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