Changeset 38121 in project


Ignore:
Timestamp:
01/16/20 01:28:27 (3 months ago)
Author:
Kon Lovett
Message:

fix seconds->utc-time C4 arg type assumption (reported by tokyo_jesus on #chicken irc), generalize number->genint, ...->genint already floors

Location:
release/5/srfi-19/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/5/srfi-19/trunk/srfi-19-support.scm

    r38112 r38121  
    270270    ((_ ?x)
    271271      (let ((x ?x))
    272         (if (fixnum? x)
     272        (if (exact? x)
    273273          x
    274274          (inexact->exact (floor x)) ) ) ) ) )
     
    698698
    699699(define (tm:seconds->time-values sec)
    700   (let* ((tsec (number->genint (floor sec)))
     700  (let* ((tsec (number->genint sec))
    701701         (ns (number->genint (exact->inexact (round (* (- sec tsec) NS/S))))) )
    702702    (values ns tsec) ) )
     
    14451445
    14461446(define (tm:seconds->date/type sec tzc)
    1447   (let* ((fsec (exact->inexact sec))
    1448            (isec (floor fsec))
    1449            (tzo (timezone-locale-offset tzc))
    1450            (tv (seconds->utc-time (+ isec tzo))))
    1451       (tm:make-date
    1452         (round (* (- fsec isec) NS/S))
    1453         (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
    1454         (vector-ref tv 3) (fx+ 1 (vector-ref tv 4)) (fx+ 1900 (vector-ref tv 5))
    1455         tzo (timezone-locale-name tzc) (timezone-locale-dst? tzc)
    1456         (vector-ref tv 6) (fx+ 1 (vector-ref tv 7)) #f) ) )
     1447  (let* (
     1448    (fsec (exact->inexact sec))
     1449    (isec (number->genint fsec))
     1450    (tzo (timezone-locale-offset tzc))
     1451    (tv (seconds->utc-time (+ isec tzo))) )
     1452    (tm:make-date
     1453      (round (* (- fsec isec) NS/S))
     1454      (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
     1455      (vector-ref tv 3) (fx+ 1 (vector-ref tv 4)) (fx+ 1900 (vector-ref tv 5))
     1456      tzo (timezone-locale-name tzc) (timezone-locale-dst? tzc)
     1457      (vector-ref tv 6) (fx+ 1 (vector-ref tv 7)) #f) ) )
    14571458
    14581459(define-syntax tm:current-date
     
    14901491#; ;original
    14911492(define (tm:decode-julian-day-number jdn)
    1492   (let* ((days (floor jdn))
    1493          (a (+ days 32044))
    1494          (b (quotient (+ (* 4 a) 3) 146097))
    1495          (c (- a (quotient (* 146097 b) 4)))
    1496          (d (quotient (+ (* 4 c) 3) 1461))
    1497          (e (- c (quotient (* 1461 d) 4)))
    1498          (m (quotient (+ (* 5 e) 2) 153))
    1499          (y (+ (* 100 b) d -4800 (quotient m 10))))
     1493  (let* (
     1494    (days (floor jdn))
     1495    (a (+ days 32044))
     1496    (b (quotient (+ (* 4 a) 3) 146097))
     1497    (c (- a (quotient (* 146097 b) 4)))
     1498    (d (quotient (+ (* 4 c) 3) 1461))
     1499    (e (- c (quotient (* 1461 d) 4)))
     1500    (m (quotient (+ (* 5 e) 2) 153))
     1501    (y (+ (* 100 b) d -4800 (quotient m 10))))
    15001502    (values ;seconds date month year
    15011503     (* (- jdn days) tm:sid)
     
    15041506     (if (>= 0 y) (- y 1) y)) ) )
    15051507(define (tm:decode-julian-day-number jdn)
    1506   (let* ((dys (number->genint (floor jdn)))
    1507          (a (fx+ dys 32044))
    1508          (b (fx/ (fx+ (fx* 4 a) 3) 146097))
    1509          (c (fx- a (fx/ (fx* 146097 b) 4)))
    1510          (d (fx/ (fx+ (fx* 4 c) 3) 1461))
    1511          (e (fx- c (fx/ (fx* 1461 d) 4)))
    1512          (m (fx/ (fx+ (fx* 5 e) 2) 153))
    1513          (y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) JDYR)))) )
     1508  (let* (
     1509    (dys (number->genint jdn))
     1510    (a (fx+ dys 32044))
     1511    (b (fx/ (fx+ (fx* 4 a) 3) 146097))
     1512    (c (fx- a (fx/ (fx* 146097 b) 4)))
     1513    (d (fx/ (fx+ (fx* 4 c) 3) 1461))
     1514    (e (fx- c (fx/ (fx* 1461 d) 4)))
     1515    (m (fx/ (fx+ (fx* 5 e) 2) 153))
     1516    (y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) JDYR)))) )
    15141517    (values ;seconds date month year
    1515       (number->genint (floor (* (- jdn dys) SEC/DY)))
     1518      (number->genint (* (- jdn dys) SEC/DY))
    15161519      (fx+ (fx- e (fx/ (fx+ (fx* 153 m) 2) 5)) 1)
    15171520      (fx- (fx+ m 3) (fx* (fx/ m 10) MN/YR))
     
    15391542    (tzn #f)
    15401543    (dstf #f) )
    1541   (cond
    1542     ((%date-timezone-info? tzi)
    1543       (set! dstf (%date-timezone-info-dst? tzi))
    1544       (set! tzn (%date-timezone-info-name tzi))
    1545       (set! tzo (%date-timezone-info-offset tzi)) )
    1546     ((timezone-components? tzi)
    1547       (set! dstf (timezone-locale-dst? tzi))
    1548       (set! tzn (timezone-locale-name tzi))
    1549       (set! tzo (timezone-locale-offset tzi)) ) )
    1550   (let-values (
    1551     ((secs dy mn yr)
    1552       (tm:decode-julian-day-number
    1553         (tm:seconds->julian-day-number (%time-second tim) tzo))) )
    1554     (let* (
    1555       (hr (fx/ secs SEC/HR))
    1556       (rem (fxmod secs SEC/HR))
    1557       (min (fx/ rem SEC/MIN))
    1558       (sec (fxmod rem SEC/MIN)) )
    1559       (tm:make-date
    1560         (%time-nanosecond tim)
    1561         sec min hr
    1562         dy mn yr
    1563         tzo tzn dstf
    1564         #f #f #f) ) ) ) )
     1544    (cond
     1545      ((%date-timezone-info? tzi)
     1546        (set! dstf (%date-timezone-info-dst? tzi))
     1547        (set! tzn (%date-timezone-info-name tzi))
     1548        (set! tzo (%date-timezone-info-offset tzi)) )
     1549      ((timezone-components? tzi)
     1550        (set! dstf (timezone-locale-dst? tzi))
     1551        (set! tzn (timezone-locale-name tzi))
     1552        (set! tzo (timezone-locale-offset tzi)) ) )
     1553    (let-values (
     1554      ((secs dy mn yr)
     1555        (tm:decode-julian-day-number
     1556          (tm:seconds->julian-day-number (%time-second tim) tzo))) )
     1557      (let* (
     1558        (hr (fx/ secs SEC/HR))
     1559        (rem (fxmod secs SEC/HR))
     1560        (min (fx/ rem SEC/MIN))
     1561        (sec (fxmod rem SEC/MIN)) )
     1562        (tm:make-date
     1563          (%time-nanosecond tim)
     1564          sec min hr
     1565          dy mn yr
     1566          tzo tzn dstf
     1567          #f #f #f) ) ) ) )
    15651568
    15661569(define (tm:time-tai->date tim tzi)
    1567   (let ((tm-utc (tm:time-tai->time-utc tim (tm:any-time))))
     1570  (let (
     1571    (tm-utc (tm:time-tai->time-utc tim (tm:any-time))) )
    15681572    (if (not (tm:tai-before-leap-second? tim))
    15691573      (tm:time-utc->date tm-utc tzi)
    1570       ;else time is *right* before the leap, we need to pretend to subtract a second ...
    1571       (let ((dat (tm:time-utc->date (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzi)))
     1574      ;else time is *right* before the leap,
     1575      ;we need to pretend to subtract a second ...
     1576      (let (
     1577        (dat
     1578          (tm:time-utc->date
     1579            (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzi)) )
    15721580        (%date-second-set! dat SEC/MIN) ;Note full minute!
    15731581        dat ) ) ) )
  • release/5/srfi-19/trunk/srfi-19.egg

    r38112 r38121  
    22
    33((synopsis "Time Data Types and Procedures")
    4  (version "4.1.0")
     4 (version "4.1.1")
    55 (category data)
    66 (author "Will Fitzgerald (for Chicken by [[/users/kon-lovett]])")
  • release/5/srfi-19/trunk/tests/srfi-19-test.scm

    r38082 r38121  
    453453    (= 0 (date->seconds (seconds->date 0))) ) )
    454454
     455;reported by tokyo_jesus on #chicken irc
     456(define-s19-test! "(seconds->date 250.0) failed due to flonum seconds->utc-time argument"
     457  (lambda ()
     458    (seconds->date 250.0) ))
     459
    455460; Duration
    456461; Time Aritmetic (+ - * /)
Note: See TracChangeset for help on using the changeset viewer.