Changeset 38336 in project


Ignore:
Timestamp:
03/24/20 20:46:59 (7 days ago)
Author:
Kon Lovett
Message:

use remainder not modulo (dividend always +, sign of divisor significant), use quotient&remainder, add tz format test

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

Legend:

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

    r38291 r38336  
    126126;;
    127127
     128;FIXME dup code
     129;From srfi-19-time
     130(define (make-duration
     131          #!key (days 0)
     132                (hours 0) (minutes 0) (seconds 0)
     133                (milliseconds 0) (microseconds 0) (nanoseconds 0))
     134  (let-values (
     135    ((ns sec)
     136      (tm:duration-elements->time-values
     137        days hours minutes seconds
     138        milliseconds microseconds nanoseconds)) )
     139    (tm:make-time 'duration ns sec) ) )
     140
     141;;
     142
    128143(define (checked-tm:time->date loc tim tzi)
    129144  (or
     
    273288
    274289(define (date-compare dat1 dat2)
    275   (let ((dif (checked-date-compare 'date-compare dat1 dat2)))
     290  (let (
     291    (dif (checked-date-compare 'date-compare dat1 dat2)) )
    276292    (cond
    277293      ((> 0 dif)  -1)
     
    314330(define (date-adjust dat amt key . args)
    315331  (let-optionals args ((tt (default-date-clock-type)))
    316     (let-values (((key adjuster) (date-adjuster-ref 'date-adjust key)))
     332    (let-values (
     333      ((key adjuster) (date-adjuster-ref 'date-adjust key)) )
    317334      (adjuster
    318335        (check-date 'date-adjust dat)
     
    374391    (tm:copy-date dat)
    375392    (let (
    376       (ndat (copy-date dat))
    377       (yrs (quotient amt 12))
    378       (mns (remainder amt 12)) )
    379       (cond
    380         ((positive? mns)
    381           (when (< 12 (+ (tm:date-month dat) mns))
    382             (tm:date-month-set! ndat 1)
    383             (set! mns (- mns (- 12 (tm:date-month dat))))
    384             (set! yrs (+ 1 yrs)) ) )
    385         (else ;(negative? amt)
    386           (when (> 1 (+ (tm:date-month dat) mns))
    387             (tm:date-month-set! ndat 12)
    388             (set! mns (+ mns (tm:date-month dat)))
    389             (set! yrs (- yrs 1)) ) ) )
    390       (tm:date-month-set! ndat (+ mns (tm:date-month ndat)))
    391       (tm:date-year-set! ndat (+ yrs (tm:date-year ndat)))
    392       (when (< (tm:days-in-month (tm:date-year ndat) (tm:date-month ndat)) (tm:date-day ndat))
    393         (tm:date-day-set! ndat (tm:days-in-month (tm:date-year ndat) (tm:date-month ndat))) )
    394       ndat ) ) )
     393      (ndat (copy-date dat)) )
     394      (let-values (
     395        ((yrs mns) (quotient&remainder amt 12)) )
     396        (cond
     397          ((positive? mns)
     398            (when (< 12 (+ (tm:date-month dat) mns))
     399              (tm:date-month-set! ndat 1)
     400              (set! mns (- mns (- 12 (tm:date-month dat))))
     401              (set! yrs (+ 1 yrs)) ) )
     402          (else ;(negative? amt)
     403            (when (> 1 (+ (tm:date-month dat) mns))
     404              (tm:date-month-set! ndat 12)
     405              (set! mns (+ mns (tm:date-month dat)))
     406              (set! yrs (- yrs 1)) ) ) )
     407        (tm:date-month-set! ndat (+ mns (tm:date-month ndat)))
     408        (tm:date-year-set! ndat (+ yrs (tm:date-year ndat)))
     409        (when (< (tm:days-in-month (tm:date-year ndat) (tm:date-month ndat)) (tm:date-day ndat))
     410          (tm:date-day-set! ndat (tm:days-in-month (tm:date-year ndat) (tm:date-month ndat))) )
     411        ndat  ) ) ) )
    395412
    396413(define (date-adjuster-weeks dat amt key tt)
     
    398415
    399416(define (date-adjuster-duration dat amt key tt)
    400   (let ((tim (checked-tm:date->time 'date-adjust-duration dat tt))
    401         (dur (make-duration (string->keyword (symbol->string key)) amt)) )
     417  (let (
     418    (tim (checked-tm:date->time 'date-adjust-duration dat tt))
     419    (dur (make-duration (string->keyword (symbol->string key)) amt)) )
    402420    (checked-tm:time->date 'date-adjust-duration
    403421      (tm:add-duration tim dur (tm:as-some-time tim))
    404422      (tm:date-timezone-info dat)) ) )
    405 
    406 ;FIXME dup code
    407 ;From srfi-19-time
    408 (define (make-duration
    409           #!key (days 0)
    410                 (hours 0) (minutes 0) (seconds 0)
    411                 (milliseconds 0) (microseconds 0) (nanoseconds 0))
    412   (let-values (
    413     ((ns sec)
    414       (tm:duration-elements->time-values
    415         days hours minutes seconds
    416         milliseconds microseconds nanoseconds)) )
    417     (tm:make-time 'duration ns sec) ) )
    418423
    419424;; Date Adjust Support
     
    567572
    568573(define (julian-day->time-tai jdn)
    569   (let ((tim (tm:julian-day->time-utc (check-julian-day 'julian-day->time-tai jdn))))
     574  (let (
     575    (tim (tm:julian-day->time-utc (check-julian-day 'julian-day->time-tai jdn))) )
    570576    (tm:time-utc->time-tai tim tim) ) )
    571577
    572578(define (julian-day->time-monotonic jdn)
    573   (let ((tim (julian-day->time-utc (check-julian-day 'julian-day->time-monotonic jdn))))
     579  (let (
     580    (tim (julian-day->time-utc (check-julian-day 'julian-day->time-monotonic jdn))) )
    574581    (tm:time-utc->time-monotonic tim tim) ) )
    575582
  • release/5/srfi-19/trunk/srfi-19-io.scm

    r38290 r38336  
    170170  (if (zero? offset)
    171171    (display "Z" port)
    172     (let ((isneg (negative? offset)))
    173       (display (if isneg #\- #\+) port)
    174       (let ((offset (if isneg (- offset) offset)))
    175         (display (padding (quotient offset SEC/HR) #\0 2) port)
    176         (display (padding (quotient (modulo offset SEC/HR) SEC/MIN) #\0 2) port) ) ) ) )
     172    (let* (
     173      (isneg (negative? offset))
     174      (offset (if isneg (- offset) offset)) )
     175      (let-values (
     176        ((hr hr-sec) (quotient&remainder offset SEC/HR)) )
     177        (display (if isneg #\- #\+) port)
     178        (display (padding hr #\0 2) port)
     179        (display (padding (quotient hr-sec SEC/MIN) #\0 2) port) ) ) ) )
    177180
    178181;; A table of output formatting directives.
  • release/5/srfi-19/trunk/srfi-19-time.scm

    r38291 r38336  
    189189  (let-optionals args ((tt 'duration))
    190190    (let-values (
    191       ((ns sec) (tm:nanoseconds->time-values ns)) )
     191      ((sec ns) (tm:nanoseconds->time-values ns)) )
    192192      (check-time-elements 'nanoseconds->time tt ns sec)
    193193      (tm:make-time tt ns sec) ) ) )
  • release/5/srfi-19/trunk/srfi-19-tm.scm

    r38290 r38336  
    4040;;
    4141;; - Forces module component of global time/date struct identifiers
     42;;
     43;; - Use of modulo vs remainder - differing sign problem
    4244
    4345;; Bugs
     
    245247;;; Date TZ information extract
    246248
    247 ;#: ;dependency
    248249(define-record-type-variant *date-timezone-info-tag* (unchecked inline unsafe)
    249   (%make-date-timezone-info n o d)
    250   %date-timezone-info?
    251   (n %date-timezone-info-name)
    252   (o %date-timezone-info-offset)
    253   (d %date-timezone-info-dst?) )
    254 ;|#
    255 #; ;no dependency
    256 (define-record-type *date-timezone-info-tag*
    257250  (%make-date-timezone-info n o d)
    258251  %date-timezone-info?
     
    457450;; ...    - argument checking then tm:...
    458451
    459 ;#| ;dependency
    460452(define-record-type-variant *time-tag* (unchecked inline unsafe)
    461453  (%make-time tt ns sec)
     
    464456  (ns   %time-nanosecond  %time-nanosecond-set!)
    465457  (sec  %time-second      %time-second-set!) )
    466 ;|#
    467 #; ;no (define-record-type srfi-19-time
    468 (define-record-type *time-tag*
    469   (%make-time tt ns sec)
    470   %time?
    471   (tt   %time-type        %time-type-set!)
    472   (ns   %time-nanosecond  %time-nanosecond-set!)
    473   (sec  %time-second      %time-second-set!) )
    474458
    475459;; Time to Date
     
    481465;; <time-unit-value> -> <ns sec>
    482466
    483 (define-inline (normalize-timeval t t/t+1)
    484   (values (remainder t t/t+1) (quotient t t/t+1)) )
    485 
    486 (define (normalize-nanoseconds ns)
     467(define-inline (normalize-timeval t per)
     468  (quotient&remainder t per) )
     469
     470(define-inline (normalize-nanoseconds ns)
    487471  (normalize-timeval ns NS/S) )
    488472
     
    492476(define (normalize-time ns sec min hr)
    493477  (let*-values (
    494     ((ns ns-sec)    (normalize-nanoseconds ns))
    495     ((sec sec-min)  (normalize-timeval (+ sec ns-sec) SEC/MIN))
    496     ((min min-hr)   (normalize-timeval (+ min sec-min) MIN/HR))
    497     ((hr hr-dy)     (normalize-timeval (+ hr min-hr) HR/DY)) )
     478    ((ns-sec ns)    (normalize-nanoseconds ns))
     479    ((sec-min sec)  (normalize-timeval (+ sec ns-sec) SEC/MIN))
     480    ((min-hr min)   (normalize-timeval (+ min sec-min) MIN/HR))
     481    ((hr-dy hr)     (normalize-timeval (+ hr min-hr) HR/DY)) )
    498482    (values ns sec min hr (+ dy hr-dy)) ) )
    499483
     
    540524(define (tm:make-time tt ns sec)
    541525  (let-values (
    542     ((ns ns-sec) (normalize-nanoseconds ns)) )
     526    ((ns-sec ns) (normalize-nanoseconds ns)) )
    543527    (%make-time tt (number->integer ns) (number->integer (+ sec ns-sec))) ) )
    544528
     
    552536
    553537(define (tm:nanoseconds->time-values nanos)
    554   (values (remainder nanos NS/S) (quotient nanos NS/S)) )
     538  (quotient&remainder nanos NS/S) )
    555539
    556540;; Seconds Conversion
     
    583567    (secs (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds)) )
    584568    (let-values (
    585       ((ns-ns ns-secs)
    586         (normalize-nanoseconds (+ nanos (* (- secs (floor secs)) NS/S)))) )
     569      ((ns-secs ns-ns) (normalize-nanoseconds (+ nanos (* (- secs (floor secs)) NS/S)))) )
    587570      (values ns-ns (+ (floor secs) ns-secs)) ) ) )
    588571
     
    594577
    595578(define (tm:milliseconds->time-values ms)
    596   (let (
    597     (ns (* (number->integer (remainder ms MS/S)) NS/MS))
    598     (sec (quotient ms MS/S)) )
    599     (values ns sec) ) )
     579  (let-values (
     580    ((sec ms-sec) (quotient&remainder ms MS/S)) )
     581    (let (
     582      (ns (* (number->integer ms-sec) NS/MS)) )
     583      (values ns sec) ) ) )
    600584
    601585(define-syntax tm:milliseconds->time
     
    713697(define (tm:add-duration tim1 dur timout)
    714698        (let-values (
    715           ((ns sec) (tm:nanoseconds->time-values (+ (%time-nanosecond tim1) (%time-nanosecond dur)))) )
     699          ((sec ns) (tm:nanoseconds->time-values (+ (%time-nanosecond tim1) (%time-nanosecond dur)))) )
    716700    (let (
    717701      (secs (+ (%time-second tim1) (%time-second dur) sec)) )
     
    728712(define (tm:subtract-duration tim1 dur timout)
    729713  (let-values (
    730     ((ns sec) (tm:nanoseconds->time-values (- (%time-nanosecond tim1) (%time-nanosecond dur)))) )
     714    ((sec ns) (tm:nanoseconds->time-values (- (%time-nanosecond tim1) (%time-nanosecond dur)))) )
    731715    #;(assert (zero? sec)) ;Since ns >= 0 the `sec' should be zero!
    732716    (let (
     
    743727(define (tm:divide-duration dur1 num durout)
    744728  (let-values (
    745     ((ns sec) (tm:nanoseconds->time-values (/ (tm:time->nanoseconds dur1) num))) )
     729    ((sec ns) (tm:nanoseconds->time-values (/ (tm:time->nanoseconds dur1) num))) )
    746730    (tm:time-nanosecond-set! durout ns)
    747731    (tm:time-second-set! durout sec)
     
    750734(define (tm:multiply-duration dur1 num durout)
    751735        (let-values (
    752           ((ns sec) (tm:nanoseconds->time-values (* (tm:time->nanoseconds dur1) num))) )
     736          ((sec ns) (tm:nanoseconds->time-values (* (tm:time->nanoseconds dur1) num))) )
    753737    (tm:time-nanosecond-set! durout ns)
    754738    (tm:time-second-set! durout sec)
     
    757741(define (tm:time-difference tim1 tim2 timout)
    758742  (let-values (
    759     ((ns sec) (tm:nanoseconds->time-values (- (tm:time->nanoseconds tim1) (tm:time->nanoseconds tim2)))) )
     743    ((sec ns) (tm:nanoseconds->time-values (- (tm:time->nanoseconds tim1) (tm:time->nanoseconds tim2)))) )
    760744    (tm:time-second-set! timout sec)
    761745    (tm:time-nanosecond-set! timout ns)
     
    858842;;; Date Object (Public Mutable)
    859843
    860 ;#| ;dependency
    861844(define-record-type-variant *date-tag* (unchecked inline unsafe)
    862   (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    863   %date?
    864   (ns     %date-nanosecond  %date-nanosecond-set!)
    865   (sec    %date-second      %date-second-set!)
    866   (min    %date-minute      %date-minute-set!)
    867   (hr     %date-hour        %date-hour-set!)
    868   (dy     %date-day         %date-day-set!)
    869   (mn     %date-month       %date-month-set!)
    870   (yr     %date-year        %date-year-set!)
    871   (tzo    %date-zone-offset %date-zone-offset-set!)
    872   ;; non-srfi extn
    873   (tzn    %date-zone-name   %date-zone-name-set!)
    874   (dstf   %date-dst?        %date-dst-set!)
    875   (wdy    %date-wday        %date-wday-set!)
    876   (ydy    %date-yday        %date-yday-set!)
    877   (jdy    %date-jday        %date-jday-set!) )
    878 ;|#
    879 #; ;no dependency
    880 (define-record-type *date-tag*
    881845  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    882846  %date?
     
    11051069  (let-values (
    11061070    ((tzo tzn dstf) (optional-tzinfo tzi)) )
    1107     (let-values (
     1071    (let*-values (
    11081072      ((secs dy mn yr)
    1109         (tm:decode-julian-day-number
    1110           (tm:seconds->julian-day-number (%time-second tim) tzo))) )
    1111       (let* (
    1112         (hr (quotient secs SEC/HR))
    1113         (rem (modulo secs SEC/HR))
    1114         (min (quotient rem SEC/MIN))
    1115         (sec (modulo rem SEC/MIN)) )
    1116         (tm:make-date
    1117           (%time-nanosecond tim)
    1118           sec min hr
    1119           dy mn yr
    1120           tzo tzn dstf
    1121           #f #f #f) ) ) ) )
     1073        (tm:decode-julian-day-number (tm:seconds->julian-day-number (%time-second tim) tzo)))
     1074      ((hr rem)
     1075        (quotient&remainder secs SEC/HR))
     1076      ((min sec)
     1077        (quotient&remainder rem SEC/MIN)) )
     1078      (tm:make-date
     1079        (%time-nanosecond tim)
     1080        sec min hr
     1081        dy mn yr
     1082        tzo tzn dstf
     1083        #f #f #f) ) ) )
    11221084
    11231085(define (tm:time-tai->date tim tzi)
     
    13861348
    13871349(define (tm:julian-day->time-utc jdn)
    1388   (let-values (((ns sec) (tm:julian-day->time-values jdn)))
     1350  (let-values (((sec ns) (tm:julian-day->time-values jdn)))
    13891351    (tm:make-time 'time-utc ns sec) ) )
    13901352
  • release/5/srfi-19/trunk/tests/srfi-19-test.scm

    r38295 r38336  
    447447  (current-date))
    448448
     449(test-assert "-TZ Format"
     450  (equal?
     451    "2020-03-16T18:28:16-0700"
     452    (date->string
     453      (make-date 0 16 28 18 16 3 2020 -25200)
     454      "~Y-~m-~dT~H:~M:~S~z")))
     455
     456(test-assert "+TZ Format"
     457  (equal?
     458    "2020-03-16T18:28:16+0700"
     459    (date->string
     460      (make-date 0 16 28 18 16 3 2020 25200)
     461      "~Y-~m-~dT~H:~M:~S~z")))
     462
    449463;; Literals
    450464
Note: See TracChangeset for help on using the changeset viewer.