From 1a2b21b8a099fa7c9a6804d59008916a32e7fad1 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 1 Oct 2003 18:07:41 +0000
Subject: [PATCH] Implement ISO 8601 date/time strings.
---
v7/src/runtime/datime.scm | 196 ++++++++++++++++++++++++++++++++++++-
v7/src/runtime/runtime.pkg | 10 +-
2 files changed, 204 insertions(+), 2 deletions(-)
diff --git a/v7/src/runtime/datime.scm b/v7/src/runtime/datime.scm
index 71b5a759f..2ac029ab1 100644
--- a/v7/src/runtime/datime.scm
+++ b/v7/src/runtime/datime.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: datime.scm,v 14.36 2003/09/30 17:17:05 cph Exp $
+$Id: datime.scm,v 14.37 2003/10/01 18:07:38 cph Exp $
Copyright 1986,1987,1988,1989,1990,1993 Massachusetts Institute of Technology
Copyright 1995,1996,1997,1999,2000,2003 Massachusetts Institute of Technology
@@ -391,6 +391,200 @@ USA.
(decoded-time->file-time
(ctime-string->decoded-time string (if (default-object? zone) #f zone))))
+;;;; ISO 8601 date/time strings
+
+;;; This implements a subset of the ISO 8601 specification. It
+;;; accepts only complete date+time representations. It does not
+;;; support either truncation or expansion. On output, it uses a
+;;; single format.
+
+(define (iso8601-string->decoded-time string)
+ (let ((v (parse-8601-date/time (string->parser-buffer string))))
+ (if (not v)
+ (error:bad-range-argument string 'ISO8601-STRING->DECODED-TIME))
+ (vector-ref v 0)))
+
+(define (decoded-time->iso8601-string dt)
+ (let ((d2 (lambda (n) (string-pad-left (number->string n) 2 #\0))))
+ (string-append (number->string (decoded-time/year dt))
+ "-"
+ (d2 (decoded-time/month dt))
+ "-"
+ (d2 (decoded-time/day dt))
+ "T"
+ (d2 (decoded-time/hour dt))
+ ":"
+ (d2 (decoded-time/minute dt))
+ ":"
+ (d2 (decoded-time/second dt))
+ (let ((zone (decoded-time/zone dt)))
+ (if zone
+ (time-zone->string
+ (if (decoded-time/daylight-savings-time? dt)
+ (- zone 1)
+ zone))
+ "")))))
+
+(define (universal-time->local-iso8601-string time)
+ (decoded-time->iso8601-string (universal-time->local-decoded-time time)))
+
+(define (universal-time->global-iso8601-string time)
+ (decoded-time->iso8601-string (universal-time->global-decoded-time time)))
+
+(define (iso8601-string->universal-time string #!optional zone)
+ (decoded-time->universal-time
+ (iso8601-string->decoded-time string (if (default-object? zone) #f zone))))
+
+(define (file-time->local-iso8601-string time)
+ (decoded-time->iso8601-string (file-time->local-decoded-time time)))
+
+(define (file-time->global-iso8601-string time)
+ (decoded-time->iso8601-string (file-time->global-decoded-time time)))
+
+(define (iso8601-string->file-time string #!optional zone)
+ (decoded-time->file-time
+ (iso8601-string->decoded-time string (if (default-object? zone) #f zone))))
+
+(define parse-8601-date/time
+ (*parser
+ (encapsulate
+ (lambda (v)
+ (let ((date (vector-ref v 0))
+ (time (vector-ref v 1))
+ (zone (vector-ref v 2)))
+ (make-decoded-time (vector-ref time 2)
+ (vector-ref time 1)
+ (vector-ref time 0)
+ (vector-ref date 2)
+ (vector-ref date 1)
+ (vector-ref date 0)
+ (and zone
+ (+ (* (- (vector-ref zone 0))
+ (vector-ref zone 1))
+ (/ (vector-ref zone 2) 60))))))
+ (complete
+ (seq parse-8601-date
+ "T" parse-8601-time
+ (alt parse-8601-zone (values #f)))))))
+
+(define parse-8601-date
+ (*parser
+ (alt (encapsulate (lambda (v) v)
+ (seq parse-8601-year
+ (alt (seq "-" parse-8601-month "-" parse-8601-day)
+ (seq parse-8601-month parse-8601-day))))
+ (transform week-date->month-date
+ (seq parse-8601-year
+ (alt (seq "-W" parse-8601-week "-" parse-8601-week-day)
+ (seq "W" parse-8601-week parse-8601-week-day))))
+ (transform ordinal-date->month-date
+ (seq parse-8601-year
+ (alt (seq "-" parse-8601-ordinal-day)
+ parse-8601-ordinal-day))))))
+
+(define (week-date->month-date v)
+ (let ((year (vector-ref v 0))
+ (week (vector-ref v 1))
+ (day (vector-ref v 2)))
+ (let ((dt
+ (let ((dt (make-decoded-time 0 0 0 1 1 year 0)))
+ (universal-time->global-decoded-time
+ (+ (decoded-time->universal-time dt)
+ (* (+ (* 7 (- week 1))
+ (- day (+ (decoded-time/day-of-week dt) 1)))
+ 86400))))))
+ (and (fix:= (decoded-time/year dt) year)
+ (vector (vector (decoded-time/year dt)
+ (decoded-time/month dt)
+ (decoded-time/day dt)))))))
+
+(define (ordinal-date->month-date v)
+ (let ((year (vector-ref v 0))
+ (day (vector-ref v 1)))
+ (let ((dt
+ (let ((dt (make-decoded-time 0 0 0 1 1 year 0)))
+ (universal-time->global-decoded-time
+ (+ (decoded-time->universal-time dt)
+ (* (- day 1)
+ 86400))))))
+ (and (fix:= (decoded-time/year dt) year)
+ (vector (vector (decoded-time/year dt)
+ (decoded-time/month dt)
+ (decoded-time/day dt)))))))
+
+(define parse-8601-time
+ (*parser
+ (transform (lambda (v)
+ (if (fix:= (vector-ref v 0) 24)
+ (and (fix:= (vector-ref v 1) 0)
+ (fix:= (vector-ref v 2) 0)
+ (vector (vector 0 0 0)))
+ (vector v)))
+ (seq parse-8601-hour
+ (alt (seq ":" parse-8601-minute ":" parse-8601-second)
+ (seq parse-8601-minute parse-8601-second))))))
+
+(define parse-8601-zone
+ (*parser
+ (encapsulate (lambda (v) v)
+ (alt (transform (lambda (v) v (vector 1 0 0))
+ (match "Z"))
+ (seq parse-8601-sign
+ parse-8601-zone-hour
+ (alt (seq (? ":") parse-8601-minute)
+ (values 0)))))))
+
+(define (8601-number-parser n-digits low high)
+ (let ((parse-digits
+ (case n-digits
+ ((1)
+ (*parser
+ (map string->number
+ (match (char-set char-set:numeric)))))
+ ((2)
+ (*parser
+ (map string->number
+ (match (seq (char-set char-set:numeric)
+ (char-set char-set:numeric))))))
+ ((3)
+ (*parser
+ (map string->number
+ (match (seq (char-set char-set:numeric)
+ (char-set char-set:numeric)
+ (char-set char-set:numeric))))))
+ ((4)
+ (*parser
+ (map string->number
+ (match (seq (char-set char-set:numeric)
+ (char-set char-set:numeric)
+ (char-set char-set:numeric)
+ (char-set char-set:numeric))))))
+ (else
+ (error:bad-range-argument n-digits '8601-NUMBER-PARSER)))))
+ (lambda (b)
+ (let ((v (parse-digits b)))
+ (and v
+ (<= low (vector-ref v 0) high)
+ v)))))
+
+(define parse-8601-year (8601-number-parser 4 1582 9999))
+(define parse-8601-month (8601-number-parser 2 1 12))
+(define parse-8601-week (8601-number-parser 2 1 53))
+(define parse-8601-day (8601-number-parser 2 1 31))
+(define parse-8601-week-day (8601-number-parser 1 1 7))
+(define parse-8601-ordinal-day (8601-number-parser 3 1 366))
+(define parse-8601-hour (8601-number-parser 2 0 24))
+(define parse-8601-zone-hour (8601-number-parser 2 0 12))
+(define parse-8601-minute (8601-number-parser 2 0 59))
+(define parse-8601-second (8601-number-parser 2 0 59))
+
+(define parse-8601-sign
+ (*parser
+ (alt (map (lambda (v) v 1) (match "+"))
+ (map (lambda (v) v -1) (match "-")))))
+
+;;;; Utilities
+
(define (month/max-days month)
(guarantee-month month 'MONTH/MAX-DAYS)
(vector-ref '#(31 29 31 30 31 30 31 31 30 31 30 31) (- month 1)))
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index aaff4a2ef..cd7f6ba3d 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.462 2003/09/30 17:17:22 cph Exp $
+$Id: runtime.pkg,v 14.463 2003/10/01 18:07:41 cph Exp $
Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -1158,6 +1158,7 @@ USA.
day-of-week/short-string
decode-universal-time
decoded-time->ctime-string
+ decoded-time->iso8601-string
decoded-time->string
decoded-time->universal-time
decoded-time/date-string
@@ -1175,13 +1176,18 @@ USA.
encode-universal-time
epoch
file-time->global-ctime-string
+ file-time->global-iso8601-string
file-time->global-time-string
file-time->local-ctime-string
+ file-time->local-iso8601-string
file-time->local-time-string
file-time->string
get-decoded-time
get-universal-time
global-decoded-time
+ iso8601-string->decoded-time
+ iso8601-string->file-time
+ iso8601-string->universal-time
local-decoded-time
make-decoded-time
month/long-string
@@ -1197,9 +1203,11 @@ USA.
time-zone?
universal-time->global-ctime-string
universal-time->global-decoded-time
+ universal-time->global-iso8601-string
universal-time->global-time-string
universal-time->local-ctime-string
universal-time->local-decoded-time
+ universal-time->local-iso8601-string
universal-time->local-time-string
universal-time->string))
--
2.25.1