;;; srfi-19.scm --- SRFI-19 procedures for Guile
;;;
;;; Copyright (C) 2001 Free Software Foundation, Inc.
-;;;
+;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 2, or
;;; (at your option) any later version.
-;;;
+;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
-;;;
+;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this software; see the file COPYING. If not, write to
;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
(define priv:locale-number-separator ".")
(define priv:locale-abbr-weekday-vector
- (vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
+ (vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
(define priv:locale-long-weekday-vector
(vector
"Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
-;; note empty string in 0th place.
+;; note empty string in 0th place.
(define priv:locale-abbr-month-vector
(vector ""
"Jan"
"Sep"
"Oct"
"Nov"
- "Dec"))
+ "Dec"))
(define priv:locale-long-month-vector
(vector ""
"September"
"October"
"November"
- "December"))
+ "December"))
(define priv:locale-pm "PM")
(define priv:locale-am "AM")
;; and update as necessary.
;; this procedures reads the file in the abover
;; format and creates the leap second table
-;; it also calls the almost standard, but not R5 procedures read-line
+;; it also calls the almost standard, but not R5 procedures read-line
;; & open-input-string
;; ie (set! priv:leap-second-table (priv:read-tai-utc-date "tai-utc.dat"))
(if (not (eq? line eof))
(begin
(let* ((data (read (open-input-string
- (string-append "(" line ")"))))
+ (string-append "(" line ")"))))
(year (car data))
(jd (cadddr (cdr data)))
(secs (cadddr (cdddr data))))
(define (add-duration t duration)
(let ((result (copy-time t)))
- (add-duration! result)))
+ (add-duration! result duration)))
(define (subtract-duration! t duration)
(if (not (eq? (time-type duration) time-duration))
(set-time-type! time-out time-utc)
(set-time-nanosecond! time-out (time-nanosecond time-in))
(set-time-second! time-out (- (time-second time-in)
- (priv:leap-second-delta
+ (priv:leap-second-delta
(time-second time-in))))
time-out)
(set-time-type! time-out time-tai)
(set-time-nanosecond! time-out (time-nanosecond time-in))
(set-time-second! time-out (+ (time-second time-in)
- (priv:leap-second-delta
+ (priv:leap-second-delta
(time-second time-in))))
time-out)
(quotient y 400)
-32045)))
-;; gives the seconds/date/month/year
+;; gives the seconds/date/month/year
(define (priv:decode-julian-day-number jdn)
(let* ((days (inexact->exact (truncate jdn)))
(a (+ days 32044))
(if (not (eq? (time-type time) time-utc))
(priv:time-error 'time->date 'incompatible-time-types time))
(let* ((offset (if (null? tz-offset)
- (priv:local-tz-offset time)
+ (priv:local-tz-offset time)
(car tz-offset)))
(leap-second? (priv:leap-second? (+ offset (time-second time))))
(jdn (priv:time->julian-day-number (if leap-second?
priv:tai-epoch-in-jd))
;; jdays is an integer plus 1/2,
(jdays-1/2 (inexact->exact (- jdays 1/2))))
- (make-time
+ (make-time
time-utc
(date-nanosecond date)
(+ (* jdays-1/2 24 60 60)
(define (leap-year? date)
(priv:leap-year? (date-year date)))
-(define priv:month-assoc '((1 . 31) (2 . 59) (3 . 90) (4 . 120)
+(define priv:month-assoc '((1 . 31) (2 . 59) (3 . 90) (4 . 120)
(5 . 151) (6 . 181) (7 . 212) (8 . 243)
(9 . 273) (10 . 304) (11 . 334) (12 . 365)))
(define (date-year-day date)
(priv:year-day (date-day date) (date-month date) (date-year date)))
-;; from calendar faq
+;; from calendar faq
(define (priv:week-day day month year)
(let* ((a (quotient (- 14 month) 12))
(y (- year a))
(priv:days-before-first-week date day-of-week-starting-week))
7))
-(define (current-date . tz-offset)
+(define (current-date . tz-offset)
(let ((time (current-time time-utc)))
(time-utc->date
time
(define (time-tai->julian-day time)
(if (not (eq? (time-type time) time-tai))
(priv:time-error 'time->date 'incompatible-time-types time))
- (+ (/ (+ (- (time-second time)
+ (+ (/ (+ (- (time-second time)
(priv:leap-second-delta (time-second time)))
(/ (time-nanosecond time) priv:nano))
priv:sid)
(define (time-monotonic->julian-day time)
(if (not (eq? (time-type time) time-monotonic))
(priv:time-error 'time->date 'incompatible-time-types time))
- (+ (/ (+ (- (time-second time)
+ (+ (/ (+ (- (time-second time)
(priv:leap-second-delta (time-second time)))
(/ (time-nanosecond time) priv:nano))
priv:sid)
(let ((secs (* priv:sid (- jdn priv:tai-epoch-in-jd))))
(receive (seconds parts)
(priv:split-real secs)
- (make-time time-utc
+ (make-time time-utc
(* parts priv:nano)
seconds))))
(define (priv:last-n-digits i n)
(abs (remainder i (expt 10 n))))
-(define (priv:locale-abbr-weekday n)
+(define (priv:locale-abbr-weekday n)
(vector-ref priv:locale-abbr-weekday-vector n))
(define (priv:locale-long-weekday n)
;; the second is a procedure that takes the date, a padding character
;; (which might be #f), and the output port.
;;
-(define priv:directives
+(define priv:directives
(list
(cons #\~ (lambda (date pad-with port)
(display #\~ port)))
(display (priv:padding (date-second date)
pad-with 2)
port))
- (receive (i f)
- (priv:split-real (/
+ (receive (i f)
+ (priv:split-real (/
(date-nanosecond date)
priv:nano 1.0))
(let* ((ns (number->string f))
(display (priv:padding (date-week-number date 1)
#\0 2) port))))
(cons #\y (lambda (date pad-with port)
- (display (priv:padding (priv:last-n-digits
+ (display (priv:padding (priv:last-n-digits
(date-year date) 2)
pad-with
2)
(display current-char port)
(priv:date-printer date (+ index 1) format-string str-len port))
(if (= (+ index 1) str-len) ; bad format string.
- (priv:time-error 'priv:date-printer 'bad-date-format-string
+ (priv:time-error 'priv:date-printer 'bad-date-format-string
format-string)
(let ((pad-char? (string-ref format-string (+ index 1))))
(cond
((char=? pad-char? #\-)
(if (= (+ index 2) str-len) ; bad format string.
(priv:time-error 'priv:date-printer
- 'bad-date-format-string
+ 'bad-date-format-string
format-string)
- (let ((formatter (priv:get-formatter
+ (let ((formatter (priv:get-formatter
(string-ref format-string
(+ index 2)))))
(if (not formatter)
(priv:time-error 'priv:date-printer
- 'bad-date-format-string
+ 'bad-date-format-string
format-string)
(begin
(formatter date #f port)
format-string
str-len
port))))))
-
+
((char=? pad-char? #\_)
(if (= (+ index 2) str-len) ; bad format string.
(priv:time-error 'priv:date-printer
- 'bad-date-format-string
+ 'bad-date-format-string
format-string)
- (let ((formatter (priv:get-formatter
+ (let ((formatter (priv:get-formatter
(string-ref format-string
(+ index 2)))))
(if (not formatter)
(priv:time-error 'priv:date-printer
- 'bad-date-format-string
+ 'bad-date-format-string
format-string)
(begin
(formatter date #\Space port)
str-len
port))))))
(else
- (let ((formatter (priv:get-formatter
+ (let ((formatter (priv:get-formatter
(string-ref format-string
(+ index 1)))))
(if (not formatter)
(priv:time-error 'priv:date-printer
- 'bad-date-format-string
+ 'bad-date-format-string
format-string)
(begin
(formatter date #\0 port)
(let ((ch (peek-char port)))
(cond
((>= nchars n) accum)
- ((eof-object? ch)
- (priv:time-error 'string->date 'bad-date-template-string
+ ((eof-object? ch)
+ (priv:time-error 'string->date 'bad-date-template-string
"Premature ending to integer read."))
((char-numeric? ch)
(set! padding-ok #f)
(read-char port) ; consume padding
(accum-int port accum (+ nchars 1)))
(else ; padding where it shouldn't be
- (priv:time-error 'string->date 'bad-date-template-string
+ (priv:time-error 'string->date 'bad-date-template-string
"Non-numeric characters in integer read.")))))
(accum-int port 0 0)))
(lambda (port)
(priv:integer-reader-exact n port)))
-(define (priv:zone-reader port)
- (let ((offset 0)
+(define (priv:zone-reader port)
+ (let ((offset 0)
(positive? #f))
(let ((ch (read-char port)))
(if (eof-object? ch)
(if (char-alphabetic? ch)
(read-char-string (cons (read-char port) result))
(list->string (reverse! result)))))
-
- (let* ((str (read-char-string '()))
+
+ (let* ((str (read-char-string '()))
(index (indexer str)))
(if index index (priv:time-error 'string->date
'bad-date-template-string
;; A List of formatted read directives.
;; Each entry is a list.
-;; 1. the character directive;
+;; 1. the character directive;
;; a procedure, which takes a character as input & returns
;; 2. #t as soon as a character on the input port is acceptable
;; for input,
;; object (here, always the date) and (probably) side-effects it.
;; In some cases (e.g., ~A) the action is to do nothing
-(define priv:read-directives
+(define priv:read-directives
(let ((ireader4 (priv:make-integer-reader 4))
(ireader2 (priv:make-integer-reader 2))
(ireaderf (priv:make-integer-reader #f))
priv:locale-long-month->index))
(char-fail (lambda (ch) #t))
(do-nothing (lambda (val object) (values))))
-
+
(list
(list #\~ char-fail (priv:make-char-id-reader #\~) do-nothing)
(list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing)
object val)))
(list #\S char-numeric? ireader2 (lambda (val object)
(set-date-second! object val)))
- (list #\y char-fail eireader2
+ (list #\y char-fail eireader2
(lambda (val object)
(set-date-year! object (priv:natural-year val))))
(list #\Y char-numeric? ireader4 (lambda (val object)
(if (not (skipper ch))
(begin (read-char port) (skip-until port skipper))))))
(if (>= index str-len)
- (begin
+ (begin
(values))
(let ((current-char (string-ref format-string index)))
(if (not (char=? current-char #\~))
(actor val date)))
(priv:string->date date
(+ index 2)
- format-string
+ format-string
str-len
port
template-string))))))))))
;; get it right (think of the double/missing hour in the
;; night when we are switching between normal time and DST).
(set-date-zone-offset! newdate
- (priv:local-tz-offset
+ (priv:local-tz-offset
(make-time time-utc 0 0)))
(set-date-zone-offset! newdate
- (priv:local-tz-offset
+ (priv:local-tz-offset
(date->time-utc newdate)))))
(if (priv:date-ok? newdate)
newdate
'string->date
'bad-date-format-string
(list "Incomplete date read. " newdate template-string)))))
+
+;;; srfi-19.scm ends here