diff options
Diffstat (limited to 'tzfile.scm')
| -rw-r--r-- | tzfile.scm | 134 |
1 files changed, 67 insertions, 67 deletions
@@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -23,7 +23,7 @@ (let ((hibyte (read-byte port))) (do ((idx 3 (+ -1 idx)) (val (if (> hibyte 127) (+ #x-100 hibyte) hibyte) - (+ (ash val 8) (read-byte port)))) + (+ (* val 256) (read-byte port)))) ((zero? idx) val)))) (define (tzfile:read-longs len port) (define ra (make-vector len 0)) @@ -34,68 +34,68 @@ (define (tzfile:read-bool port) (let ((c (read-char port))) (if (eof-object? c) c (if (zero? (char->integer c)) #f #t)))) - +;@ (define (tzfile:read path) (define null (integer->char 0)) - (call-with-input-file path - (lambda (port) - (do ((idx 0 (+ 1 idx))) ;reserved. - ((>= idx 20)) - (read-char port)) - (let* ((ttisgmtcnt (tzfile:read-long port)) - (ttisstdcnt (tzfile:read-long port)) - (leapcnt (tzfile:read-long port)) - (timecnt (tzfile:read-long port)) - (typecnt (tzfile:read-long port)) - (charcnt (tzfile:read-long port)) - (transition-times (tzfile:read-longs timecnt port)) - (transition-types - (do ((ra (make-vector timecnt 0)) - (idx 0 (+ 1 idx))) - ((>= idx timecnt) ra) - (vector-set! ra idx (read-byte port)))) - ;;(printf " typecnt = %d\n" typecnt) - (mode-table (do ((tt (make-vector typecnt #f)) - (idx 0 (+ 1 idx))) - ((>= idx typecnt) tt) - (let* ((gmt-offset (tzfile:read-long port)) - (isdst (tzfile:read-bool port)) - (abbrev-index (read-byte port))) - (vector-set! tt idx - (vector abbrev-index gmt-offset - isdst #f #f))))) - ;;(printf " %d bytes of abbreviations:\n" charcnt) - (abbrevs (do ((ra (make-bytes charcnt 0)) - (idx 0 (+ 1 idx))) - ((>= idx charcnt) ra) - (string-set! ra idx (read-char port)))) - (leap-seconds (tzfile:read-longs (* 2 leapcnt) port))) - (cond ((not (or (eqv? 0 ttisstdcnt) (eqv? typecnt ttisstdcnt))) - (slib:warn 'tzfile:read "format error" ttisstdcnt typecnt))) - (cond ((not (or (eqv? 0 ttisgmtcnt) (eqv? typecnt ttisgmtcnt))) - (slib:warn 'tzfile:read "format error" ttisgmtcnt typecnt))) - ;;(printf " reading %d transition attributes\n" ttisstdcnt) - (do ((idx 0 (+ 1 idx))) - ((>= idx ttisstdcnt)) - (vector-set! (vector-ref mode-table idx) 3 (tzfile:read-bool port))) - ;;(printf " reading %d transition attributes\n" ttisgmtcnt) - (do ((idx 0 (+ 1 idx))) - ((>= idx ttisgmtcnt)) - (vector-set! (vector-ref mode-table idx) 4 (tzfile:read-bool port))) - (cond ((not (eof-object? (peek-char port))) - (slib:warn 'tzfile:read "bytes left at end"))) - (do ((idx 0 (+ 1 idx))) - ((>= idx ttisstdcnt)) - (let ((rec (vector-ref mode-table idx))) - (vector-set! - rec 0 (let loop ((pos (vector-ref rec 0))) - (cond ((>= pos (string-length abbrevs)) - (slib:warn 'tzfile:read "format error" abbrevs) #f) - ((char=? null (string-ref abbrevs pos)) - (substring abbrevs (vector-ref rec 0) pos)) - (else (loop (+ 1 pos)))))))) - (list path mode-table leap-seconds transition-times transition-types) - )))) + (call-with-open-ports + (open-file path 'rb) + (lambda (port) + (do ((idx 0 (+ 1 idx))) ;reserved. + ((>= idx 20)) + (read-char port)) + (let* ((ttisgmtcnt (tzfile:read-long port)) + (ttisstdcnt (tzfile:read-long port)) + (leapcnt (tzfile:read-long port)) + (timecnt (tzfile:read-long port)) + (typecnt (tzfile:read-long port)) + (charcnt (tzfile:read-long port)) + (transition-times (tzfile:read-longs timecnt port)) + (transition-types + (do ((ra (make-vector timecnt 0)) + (idx 0 (+ 1 idx))) + ((>= idx timecnt) ra) + (vector-set! ra idx (read-byte port)))) + ;;(printf " typecnt = %d\\n" typecnt) + (mode-table (do ((tt (make-vector typecnt #f)) + (idx 0 (+ 1 idx))) + ((>= idx typecnt) tt) + (let* ((gmt-offset (tzfile:read-long port)) + (isdst (tzfile:read-bool port)) + (abbrev-index (read-byte port))) + (vector-set! tt idx + (vector abbrev-index gmt-offset + isdst #f #f))))) + ;;(printf " %d bytes of abbreviations:\\n" charcnt) + (abbrevs (do ((ra (make-bytes charcnt 0)) + (idx 0 (+ 1 idx))) + ((>= idx charcnt) ra) + (string-set! ra idx (read-char port)))) + (leap-seconds (tzfile:read-longs (* 2 leapcnt) port))) + (cond ((not (or (eqv? 0 ttisstdcnt) (eqv? typecnt ttisstdcnt))) + (slib:warn 'tzfile:read "format error" ttisstdcnt typecnt))) + (cond ((not (or (eqv? 0 ttisgmtcnt) (eqv? typecnt ttisgmtcnt))) + (slib:warn 'tzfile:read "format error" ttisgmtcnt typecnt))) + ;;(printf " reading %d transition attributes\\n" ttisstdcnt) + (do ((idx 0 (+ 1 idx))) + ((>= idx ttisstdcnt)) + (vector-set! (vector-ref mode-table idx) 3 (tzfile:read-bool port))) + ;;(printf " reading %d transition attributes\\n" ttisgmtcnt) + (do ((idx 0 (+ 1 idx))) + ((>= idx ttisgmtcnt)) + (vector-set! (vector-ref mode-table idx) 4 (tzfile:read-bool port))) + (cond ((not (eof-object? (peek-char port))) + (slib:warn 'tzfile:read "bytes left at end"))) + (do ((idx 0 (+ 1 idx))) + ((>= idx ttisstdcnt)) + (let ((rec (vector-ref mode-table idx))) + (vector-set! + rec 0 (let loop ((pos (vector-ref rec 0))) + (cond ((>= pos (string-length abbrevs)) + (slib:warn 'tzfile:read "format error" abbrevs) #f) + ((char=? null (string-ref abbrevs pos)) + (substring abbrevs (vector-ref rec 0) pos)) + (else (loop (+ 1 pos)))))))) + (list path mode-table leap-seconds transition-times transition-types))))) (define (tzfile:transition-index time zone) (and zone @@ -103,8 +103,8 @@ (lambda (path mode-table leap-seconds transition-times transition-types) (let ((ntrns (vector-length transition-times))) (if (zero? ntrns) -1 - (let loop ((lidx (ash (+ 1 ntrns) -1)) - (jmp (ash (+ 1 ntrns) -2))) + (let loop ((lidx (quotient (+ 1 ntrns) 2)) + (jmp (quotient (+ 1 ntrns) 4))) (let* ((idx (max 0 (min lidx (+ -1 ntrns)))) (idx-time (vector-ref transition-times idx))) (cond ((<= jmp 0) @@ -113,8 +113,8 @@ ((and (zero? idx) (< time idx-time)) -1) ((and (not (= idx lidx)) (not (< time idx-time))) idx) (else - (loop ((if (< time idx-time) - +) idx jmp) - (if (= 1 jmp) 0 (ash (+ 1 jmp) -1)))))))))) + (loop ((if (< time idx-time) - +) idx jmp) + (if (= 1 jmp) 0 (quotient (+ 1 jmp) 2)))))))))) (cdr (vector->list zone))))) (define (tzfile:get-std-spec mode-table) @@ -124,7 +124,7 @@ (if (>= type-idx (vector-length mode-table)) (vector-ref mode-table 0) (vector-ref mode-table type-idx))))) - +;@ (define (tzfile:get-zone-spec time zone) (apply (lambda (path mode-table leap-seconds transition-times transition-types) |