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) [(and (format-condition? v)
(string-prefix? "~?. Some debugging context lost" (condition-message v))) (string-prefix? "~?. Some debugging context lost" (condition-message v)))
exn:fail] exn:fail]
[(and (who-condition? v)
(eq? 'time-utc->date (condition-who v)))
exn:fail]
[else [else
exn:fail:contract])) exn:fail:contract]))
@ -53,7 +56,8 @@
flonum->fixnum fl->fx flonum->fixnum fl->fx
fxarithmetic-shift-right fxrshift fxarithmetic-shift-right fxrshift
fxarithmetic-shift-left fxlshift fxarithmetic-shift-left fxlshift
real->flonum ->fl) real->flonum ->fl
time-utc->date seconds->date)
(set! rewrites-added? #t))) (set! rewrites-added? #t)))
(getprop n 'error-rename n))) (getprop n 'error-rename n)))
@ -107,6 +111,8 @@
(let ([ctc (desc->contract (substring str (string-length is-not-a-str) (string-length str)))]) (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") (format-error-values (string-append "contract violation\n expected: " ctc "\n given: ~s")
irritants))] irritants))]
[(eq? who 'time-utc->date)
(values "integer is out-of-range" null)]
[else [else
(format-error-values str irritants)])) (format-error-values str irritants)]))

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

@ -111,25 +111,34 @@
[(s local?) [(s local?)
(check who real? s) (check who real? s)
(let* ([s (inexact->exact s)] (let* ([s (inexact->exact s)]
[tm (make-time 'time-utc [si (floor s)])
(floor (* (- s (floor s)) 1000000000)) (unless (in-date-range? si)
(floor s))] (raise-arguments-error who "integer is out-of-range"
[d (if local? "integer" si))
(time-utc->date tm) (let* ([tm (make-time 'time-utc
(time-utc->date tm 0))]) (floor (* (- s si) 1000000000))
(make-date*/direct (chez:date-second d) si)]
(chez:date-minute d) [d (if local?
(chez:date-hour d) (time-utc->date tm)
(chez:date-day d) (time-utc->date tm 0))])
(chez:date-month d) (make-date*/direct (chez:date-second d)
(chez:date-year d) (chez:date-minute d)
(chez:date-week-day d) (chez:date-hour d)
(chez:date-year-day d) (chez:date-day d)
(chez:date-dst? d) (chez:date-month d)
(date-zone-offset d) (chez:date-year d)
(date-nanosecond d) (chez:date-week-day d)
(or (let ([n (date-zone-name d)]) (chez:date-year-day d)
(and n (string->immutable-string n))) (chez:date-dst? d)
utc-string)))])) (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 utc-string (string->immutable-string "UTC"))