summaryrefslogtreecommitdiffstats
path: root/psxtime.scm
diff options
context:
space:
mode:
Diffstat (limited to 'psxtime.scm')
-rw-r--r--psxtime.scm163
1 files changed, 73 insertions, 90 deletions
diff --git a/psxtime.scm b/psxtime.scm
index 753e81f..fed0707 100644
--- a/psxtime.scm
+++ b/psxtime.scm
@@ -19,106 +19,32 @@
;;; No, it doesn't do leap seconds.
+(require 'time-core)
(require-if 'compiling 'time-zone)
-
-(define time:days/month
- '#(#(31 28 31 30 31 30 31 31 30 31 30 31) ; Normal years.
- #(31 29 31 30 31 30 31 31 30 31 30 31)))
-(define (leap-year? year)
- (and (zero? (remainder year 4))
- (or (not (zero? (remainder year 100)))
- (zero? (remainder year 400))))) ; Leap years.
-
-;;; Returns the `struct tm' representation of T,
-;;; offset TM_GMTOFF seconds east of UCT.
-(define (time:split t tm_isdst tm_gmtoff tm_zone)
- (set! t (difftime t tm_gmtoff))
- (let* ((secs (modulo t 86400)) ; SECS/DAY
- (days (+ (quotient t 86400) ; SECS/DAY
- (if (and (negative? t) (positive? secs)) -1 0))))
- (let ((tm_hour (quotient secs 3600))
- (secs (remainder secs 3600))
- (tm_wday (modulo (+ 4 days) 7))) ; January 1, 1970 was a Thursday.
- (let loop ((tm_year 1970)
- (tm_yday days))
- (let ((diy (if (leap-year? tm_year) 366 365)))
- (cond
- ((negative? tm_yday) (loop (+ -1 tm_year) (+ tm_yday diy)))
- ((>= tm_yday diy) (loop (+ 1 tm_year) (- tm_yday diy)))
- (else
- (let* ((mv (vector-ref time:days/month (- diy 365))))
- (do ((tm_mon 0 (+ 1 tm_mon))
- (tm_mday tm_yday (- tm_mday (vector-ref mv tm_mon))))
- ((< tm_mday (vector-ref mv tm_mon))
- (vector
- (remainder secs 60) ; Seconds. [0-61] (2 leap seconds)
- (quotient secs 60) ; Minutes. [0-59]
- tm_hour ; Hours. [0-23]
- (+ tm_mday 1) ; Day. [1-31]
- tm_mon ; Month. [0-11]
- (- tm_year 1900) ; Year - 1900.
- tm_wday ; Day of week. [0-6]
- tm_yday ; Days in year. [0-365]
- tm_isdst ; DST. [-1/0/1]
- tm_gmtoff ; Seconds west of UTC.
- tm_zone ; Timezone abbreviation.
- )))))))))))
;@
-(define (gmtime t)
- (time:split t 0 0 "GMT"))
+(define (tz:std-offset zone)
+ (case (vector-ref zone 0)
+ ((tz:fixed) (vector-ref zone 3))
+ ((tz:rule) (vector-ref zone 4))
+ ((tz:file)
+ (let ((mode-table (vector-ref zone 2)))
+ (do ((type-idx 0 (+ 1 type-idx)))
+ ((or (>= type-idx (vector-length mode-table))
+ (not (vector-ref (vector-ref mode-table type-idx) 2)))
+ (if (>= type-idx (vector-length mode-table))
+ (vector-ref (vector-ref mode-table 0) 1)
+ (- (vector-ref (vector-ref mode-table type-idx) 1)))))))
+ (else (slib:error 'tz:std-offset "unknown timezone type" zone))))
;@
(define (localtime caltime . tz)
(require 'time-zone)
(set! tz (if (null? tz) (tzset) (car tz)))
(apply time:split caltime (tz:params caltime tz)))
-
-(define time:year-70
- (let* ((t (current-time)))
- (offset-time (offset-time t (- (difftime t 0))) (* -70 32140800))))
-
-(define (time:invert decoder target)
- (let* ((times '#(1 60 3600 86400 2678400 32140800))
- (trough ; rough time for target
- (do ((i 5 (+ i -1))
- (trough time:year-70
- (offset-time trough (* (vector-ref target i)
- (vector-ref times i)))))
- ((negative? i) trough))))
-;;; (print 'trough trough 'target target)
- (let loop ((guess trough)
- (j 0)
- (guess-tm (decoder trough)))
-;;; (print 'guess guess 'guess-tm guess-tm)
- (do ((i 5 (+ i -1))
- (rough time:year-70
- (offset-time rough (* (vector-ref guess-tm i)
- (vector-ref times i))))
- (sign (let ((d (- (vector-ref target 5)
- (vector-ref guess-tm 5))))
- (and (not (zero? d)) d))
- (or sign
- (let ((d (- (vector-ref target i)
- (vector-ref guess-tm i))))
- (and (not (zero? d)) d)))))
- ((negative? i)
- (let* ((distance (abs (- trough rough))))
- (cond ((and (zero? distance) sign)
-;;; (print "trying to jump")
- (set! distance (if (negative? sign) -86400 86400)))
- ((and sign (negative? sign)) (set! distance (- distance))))
- (set! guess (offset-time guess distance))
-;;; (print 'distance distance 'sign sign)
- (cond ((zero? distance) guess)
- ((> j 5) #f) ;to prevent inf loops.
- (else
- (loop guess
- (+ 1 j)
- (decoder guess))))))))))
;@
(define (mktime univtime . tz)
(require 'time-zone)
(set! tz (if (null? tz) (tzset) (car tz)))
- (+ (gmktime univtime) (tz:std-offset tz)))
+ (offset-time (gmktime univtime) (tz:std-offset tz)))
;@
(define (gmktime univtime)
(time:invert time:gmtime univtime))
@@ -150,8 +76,65 @@
(time:asctime (time:gmtime time)))
;;; GMT Local -- take optional 2nd TZ arg
-(define time:gmtime gmtime) (define time:localtime localtime)
+;;@
+(define gmtime time:gmtime)
+
+(define time:localtime localtime)
;;(define time:gmktime gmktime) (define time:mktime mktime)
;;(define time:gtime gtime) (define time:ctime ctime)
(define time:asctime asctime)
+
+;@
+(define daylight? #f)
+(define *timezone* 0)
+(define tzname '#("UTC" "???"))
+
+(define tz:default #f)
+
+;;;@ Interpret the TZ envariable.
+(define (tzset . opt-tz)
+ (define tz (if (null? opt-tz)
+ (getenv "TZ")
+ (car opt-tz)))
+ (if (or (not tz:default)
+ (and (string? tz) (not (string-ci=? tz (vector-ref tz:default 1)))))
+ (let ()
+ (require 'time-zone)
+ (set! tz:default (or (time-zone tz) '#(tz:fixed "UTC" "GMT" 0)))))
+ (case (vector-ref tz:default 0)
+ ((tz:fixed)
+ (set! tzname (vector (vector-ref tz:default 2) "???"))
+ (set! daylight? #f)
+ (set! *timezone* (vector-ref tz:default 3)))
+ ((tz:rule)
+ (set! tzname (vector (vector-ref tz:default 2)
+ (vector-ref tz:default 3)))
+ (set! daylight? #t)
+ (set! *timezone* (vector-ref tz:default 4)))
+ ((tz:file)
+ (let ((mode-table (vector-ref tz:default 2))
+ (transition-types (vector-ref tz:default 5)))
+ (set! daylight? #f)
+ (set! *timezone* (vector-ref (vector-ref mode-table 0) 1))
+ (set! tzname (make-vector 2 #f))
+ (do ((type-idx 0 (+ 1 type-idx)))
+ ((>= type-idx (vector-length mode-table)))
+ (let ((rec (vector-ref mode-table type-idx)))
+ (if (vector-ref rec 2)
+ (set! daylight? #t)
+ (set! *timezone* (- (vector-ref rec 1))))))
+
+ (do ((transition-idx (+ -1 (vector-length transition-types))
+ (+ -1 transition-idx)))
+ ((or (negative? transition-idx)
+ (and (vector-ref tzname 0) (vector-ref tzname 1))))
+ (let ((rec (vector-ref mode-table
+ (vector-ref transition-types transition-idx))))
+ (if (vector-ref rec 2)
+ (if (not (vector-ref tzname 1))
+ (vector-set! tzname 1 (vector-ref rec 0)))
+ (if (not (vector-ref tzname 0))
+ (vector-set! tzname 0 (vector-ref rec 0))))))))
+ (else (slib:error 'tzset "unknown timezone type" tz)))
+ tz:default)