From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 1 Oct 2003 18:07:41 +0000 (+0000)
Subject: Implement ISO 8601 date/time strings.
X-Git-Tag: 20090517-FFI~1776
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1a2b21b8a099fa7c9a6804d59008916a32e7fad1;p=mit-scheme.git

Implement ISO 8601 date/time strings.
---

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))