Changeset 2548 in project


Ignore:
Timestamp:
12/03/06 14:25:37 (15 years ago)
Author:
Kon Lovett
Message:

1st pass at 'date-dst?' field.

Location:
srfi-19
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • srfi-19/srfi-19-common.scm

    r2109 r2548  
    1717        (not (not obj)) )
    1818
    19 ;; Not necessary, and overhead to boot.
    2019;; For storage savings since some aritmetic routines do not
    2120;; return fixnums when possible.
    2221
    23 #;(use mathh-int)
    24 
    25 #;(define (->fixnum x)
     22#|
     23;; Not necessary, and overhead to boot.
     24(use mathh-int)
     25(define (->fixnum x)
    2626        (cond
    2727                [(and (integer? x) (inexact? x) (<= most-negative-fixnum x most-positive-fixnum))
     
    2929                [else
    3030                        x]) )
     31|#
    3132
    32 #;(define-macro (->fixnum x)
    33         x)
    34 
    35 (define (->fixnum x)
     33(define-inline (->fixnum x)
    3634        (inexact->exact x) )
    3735
     
    4442
    4543(define-inline (tm:days-before-first-week date day-of-week-starting-week)
    46         (let* ([first-day (tm:make-date 0 0 0 0 1 1 (date-year date) #f #f #f #f)]
    47                                  [fdweek-day (date-week-day first-day)])
    48                 (modulo (- day-of-week-starting-week fdweek-day) 7) ) )
     44        (modulo
     45                (- day-of-week-starting-week
     46                        (date-week-day (tm:make-date 0 0 0 0 1 1 (date-year date) #f #f #f #f #f)))
     47                7) )
    4948
    5049;;
  • srfi-19/srfi-19-io.scm

    r2092 r2548  
    682682                                                                                        (tm:error 'scan-date "bad date template" (list->string format-rem))
    683683                                                                                        (actor val date))))
    684                                                                 (loop (cddr format-rem) (fx- len-rem 2)))]) )) ) ) )
     684                                                                (loop (cddr format-rem) (fx- len-rem 2)))]) ) ) ) ) )
    685685
    686686(define (scan-date src template-string)
    687687        (let ([port #f]
    688                                 [newdate (tm:make-date 0 0 0 0 #f #f #f (tm:tz-info-offset) (tm:tz-info-name) #f #f)])
    689                 (let ([date-compl? (lambda ()
    690                                                 (and
    691                                                         (date-nanosecond newdate)
    692                                                         (date-second newdate) (date-minute newdate) (date-hour newdate)
    693                                                         (date-day newdate) (date-month newdate) (date-year newdate)
    694                                                         (date-zone-offset newdate)))]
    695                                         [date-ok? (lambda ()
    696                                                 (tm:vali-date
    697                                                         'scan-date
    698                                                         (date-nanosecond newdate)
    699                                                         (date-second newdate) (date-minute newdate) (date-hour newdate)
    700                                                         (date-day newdate) (date-month newdate) (date-year newdate)
    701                                                         (date-zone-offset newdate)
    702                                                         (date-zone-name newdate)))])
     688                                [newdate (tm:make-date 0 0 0 0 #f #f #f (local-timezone-offset) (local-timezone-name) #f #f #f)])
     689                (let ([date-compl?
     690                                                (lambda ()
     691                                                        (and
     692                                                                (date-nanosecond newdate)
     693                                                                (date-second newdate) (date-minute newdate) (date-hour newdate)
     694                                                                (date-day newdate) (date-month newdate) (date-year newdate)
     695                                                                (date-zone-offset newdate)))]
     696                                        [date-ok?
     697                                                (lambda ()
     698                                                        (tm:vali-date
     699                                                                'scan-date
     700                                                                (date-nanosecond newdate)
     701                                                                (date-second newdate) (date-minute newdate) (date-hour newdate)
     702                                                                (date-day newdate) (date-month newdate) (date-year newdate)
     703                                                                (date-zone-offset newdate)
     704                                                                (date-zone-name newdate)))])
    703705                        (cond
    704706                                [(string? src) (set! port (open-input-string src))]
  • srfi-19/srfi-19.scm

    r2103 r2548  
    44;;ISSUES
    55;;
     6;; - The 'date-dst?' field is problimatic. It is only valid on certain platforms & only when
     7;; current. An historical or furture date will not have this field correct!
     8;;
     9;; So for now, not documented.
     10;;
    611;; - Gregorian calendar only. Plugable calendar systems, a'la Java, would
    712;; be nice.
    813;;
    914;; - "Module" initialization is scattered throughout the code, so converting
    10 ;; to a "real" module will involve some search. Use the 'always-bound'
    11 ;; declaration as a guide.
     15;; to a "real" module will involve some search.
    1216;;
    1317;; - SRFI-18 current-time & time? procedure identifier conflict
     
    6973                        ;; SRFI-19 extensions
    7074
     75                        srfi-19:current-time srfi-19:time?
    7176                        time->srfi-18-time srfi-18-time->time
    7277                        seconds->time/type seconds->date/type
     
    7479                        time->nanoseconds nanoseconds->time nanoseconds->seconds
    7580                        read-leap-second-table
    76                         srfi-19:current-time srfi-19:time?
    7781                        milliseconds->time time->date
     82                        local-timezone-info
     83                        local-timezone-name
     84                        local-timezone-offset
     85                        local-timezone-dst?
     86                        date-zone-name
     87                        date-dst?
     88
    7889                        #;time-hash #;date-hash
     90
    7991                        #;roll-date #;roll-date!
    80                         local-timezone-info
    8192
    8293                        ;; SRFI-19
     
    98109                        date-second date-minute date-hour
    99110                        date-day date-month date-year
    100                         date-zone-offset date-zone-name
     111                        date-zone-offset
    101112                        date-year-day date-week-day
    102113                        date-week-number
     
    121132
    122133                        ;; For srfi-19-io
    123                         tm:tz-info-name
    124                         tm:tz-info-offset
    125134                        tm:time-second
    126135                        tm:vali-date
     
    134143                        tm:date-year-set!
    135144                        tm:date-zone-offset-set!
    136                         #;tm:date-zone-name-set!
    137145                        tm:date-wday-set!
    138146                        tm:date-yday-set!)
     
    696704(define-constant DEFAULT-LOCAL-TZ-NAME "???")
    697705
    698 (define-inline (tm:has-local-tz-name?)
    699         (eq? 'gnu (build-platform)) )
    700 
    701706(define-inline (tm:local-tz-name)
    702         (if (tm:has-local-tz-name?)
    703                 (local-timezone-abbreviation)
    704                 DEFAULT-LOCAL-TZ-NAME) )
     707        #+windows       DEFAULT-LOCAL-TZ-NAME
     708        #+(not windows) (local-timezone-abbreviation) )
    705709
    706710;FIXME uses same timezone-name for std & dst
     
    736740;; Returns #f or a valid tz-name
    737741
    738 (define (tm:tz-info-name . r)
     742(define (local-timezone-name . r)
    739743        (let* ([tzi (:optional r (local-timezone-info))]
    740744                                 [tzn (or (and (car tzi)
     
    744748                (and tzn (string<> tzn DEFAULT-LOCAL-TZ-NAME) tzn) ) )
    745749
    746 ;;
    747 
    748 (define (tm:tz-info-offset . r)
     750(define (local-timezone-offset . r)
    749751        (let* ([tzi (:optional r (local-timezone-info))]
    750752                                 [off
     
    755757                (or off 0) ) )
    756758
     759(define (local-timezone-dst? . r)
     760        (let ([tzi (:optional r (local-timezone-info))])
     761                (car tzi) ) )
     762
    757763;;; Date Structures
    758764
    759765(define-record-type date
    760         (tm:make-date nanosecond second minute hour day month year zone-offset zone-name wday yday)
     766        (tm:make-date nanosecond second minute hour day month year zone-offset zone-name dstf wday yday)
    761767        date?
    762768        (nanosecond date-nanosecond tm:date-nanosecond-set!)
     
    770776        ;; non-srfi extn
    771777        (zone-name date-zone-name #;tm:date-zone-name-set!)
     778        (dstf date-dst? #;tm:date-dst-set!)
    772779        (wday date-wday tm:date-wday-set!)
    773780        (yday date-yday tm:date-yday-set!) )
     
    775782;;
    776783
    777 (define-inline (%make-date nanosecond second minute hour day month year zone-offset zone-name wday yday)
     784(define-inline (%make-date nanosecond second minute hour day month year zone-offset zone-name dstf wday yday)
    778785        (tm:make-date
    779786                (->fixnum nanosecond)
     
    786793                (->fixnum zone-offset)
    787794                zone-name
     795                dstf
    788796                wday yday) )
    789797
     
    835843(define-record-printer (date d out)
    836844        (fprintf out
    837                 "#,(date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)"
     845                "#,(date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)"
    838846                (date-nanosecond d)
    839847                (date-second d) (date-minute d) (date-hour d)
     
    841849                (date-zone-offset d)
    842850                (date-zone-name d)
     851                (date-dst? d)
    843852                (date-wday d) (date-yday d)) )
    844853
     
    854863
    855864(define (make-date nsec sec min hr dy mn yr tzo . r)
    856         (let ([tzn (:optional r #f)])
     865        (let ([tzn (:optional r #f)]
     866                                [dstf #f])
    857867                (when (pair? tzo)
    858                         (set! tzn (or tzn (tm:tz-info-name tzo)))
    859                         (set! tzo (tm:tz-info-offset tzo)))
     868                        (set! dstf (local-timezone-dst? tzo))
     869                        (set! tzn (or tzn (local-timezone-name tzo)))
     870                        (set! tzo (local-timezone-offset tzo)))
    860871                (tm:vali-date 'make-date nsec sec min hr dy mn yr tzo tzn)
    861                 (%make-date nsec sec min hr dy mn yr tzo tzn #f #f) ) )
     872                (%make-date nsec sec min hr dy mn yr tzo tzn dstf #f #f) ) )
    862873
    863874;; Uses lolevel
     
    871882
    872883(define (seconds->date/type s . r)
    873         (let ([isec (exact->inexact s)] [local? (:optional r #f)])
    874                 (let ([tf (if local? seconds->local-time seconds->utc-time)]
    875                                         [tzn (if local? (tm:tz-info-name) "UTC")]
    876                                         [tsec (truncate isec)])
    877                         (let ([tv (tf tsec)])
    878                                 (%make-date
    879                                         (inexact->exact (round (* (- isec tsec) NANO)))
    880                                         (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
    881                                         (vector-ref tv 3) (+ 1 (vector-ref tv 4)) (+ 1900 (vector-ref tv 5))
    882                                         (or (and (vector-ref tv 8) (+ (vector-ref tv 9) DST-OFFSET))
    883                                                         (vector-ref tv 9))
    884                                         tzn
    885                                         (vector-ref tv 6) (+ 1 (vector-ref tv 7))) ) ) ) )
     884        (let* ([local? (:optional r #f)]
     885                                 [isec (exact->inexact s)]
     886                                 [tsec (truncate isec)]
     887                                 [tv ((if local? seconds->local-time seconds->utc-time) tsec)])
     888                (%make-date
     889                        (inexact->exact (round (* (- isec tsec) NANO)))
     890                        (vector-ref tv 0)
     891                        (vector-ref tv 1)
     892                        (vector-ref tv 2)
     893                        (vector-ref tv 3)
     894                        (+ 1 (vector-ref tv 4))
     895                        (+ 1900 (vector-ref tv 5))
     896                        (or (and (vector-ref tv 8) (+ (vector-ref tv 9) DST-OFFSET)) (vector-ref tv 9))
     897                        (if local? (local-timezone-name) "UTC")
     898                        (and local? (local-timezone-dst?))
     899                        (vector-ref tv 6) (+ 1 (vector-ref tv 7))) ) )
    886900
    887901;; Gives the julian day which starts at noon.
     
    929943(define (tm:time->date time tz-info)
    930944  (let ([tzo (:optional tz-info (local-timezone-info))]
    931                                 [tzn #f])
     945                                [tzn #f]
     946                                [dstf #f])
    932947                        (when (pair? tzo)
    933                                 (set! tzn (tm:tz-info-name tzo))
    934                                 (set! tzo (tm:tz-info-offset tzo)))
     948                                (set! dstf (local-timezone-dst? tzo))
     949                                (set! tzn (local-timezone-name tzo))
     950                                (set! tzo (local-timezone-offset tzo)))
    935951                        (receive (secs day month year)
    936952                                (tm:decode-julian-day-number
     
    942958                                        (%make-date
    943959                                                (tm:time-nanosecond time)
    944                                                 seconds minutes hours
    945                                                 day month year
     960                                                seconds
     961                                                minutes
     962                                                hours
     963                                                day
     964                                                month
     965                                                year
    946966                                                tzo
    947                                                 tzn #f #f) ) ) ) )
     967                                                tzn
     968                                                dstf
     969                                                #f #f) ) ) ) )
    948970
    949971(define tm:one-second-time (tm:make-time time-duration 0 1))
Note: See TracChangeset for help on using the changeset viewer.