Implement new procedure MAKE-DECODED-TIME. Rename several internal

procedures to use Common Lisp names, and export them to the global
environment.

diff --git a/v7/src/runtime/datime.scm b/v7/src/runtime/datime.scm
index 1f7e129d8a3fde73e1889ee0b72aecc580d173ba..d39afeb81db80b61fd2eaec4bd3ec797ebbc048c 100644 (file)
--- a/v7/src/runtime/datime.scm
+++ b/v7/src/runtime/datime.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/datime.scm,v 14.4 1993/01/12 19:52:14 gjr Exp $
+$Id: datime.scm,v 14.5 1995/04/15 06:09:46 cph Exp $
 
-Copyright (c) 1988-1993 Massachusetts Institute of Technology
+Copyright (c) 1988-95 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -48,7 +48,9 @@ MIT in each case. |#
                   (type vector)
                   (named decoded-time-structure-tag)
                   (conc-name decoded-time/)
-                  (constructor make-decoded-time ()))
+                  (constructor %make-decoded-time
+                               (second minute hour day month year))
+                  (constructor allocate-decoded-time ()))
   (second false read-only true)
   (minute false read-only true)
   (hour false read-only true)
@@ -57,46 +59,84 @@ MIT in each case. |#
   (year false read-only true)
   (day-of-week false read-only true))
 
-(define (decode-time time)
-  (let ((result (make-decoded-time)))
+(define (make-decoded-time second minute hour day month year)
+  (let ((limit
+        (lambda (low number high)
+          (cond ((< number low) low)
+                ((> number high) high)
+                (else number)))))
+    (let ((month (limit 1 month 12)))
+      (make-decoded-time
+       (limit 0 second 59)
+       (limit 0 minute 59)
+       (limit 0 hour 23)
+       (limit 1 day (vector-ref days-per-month (- month 1)))
+       month
+       (if (< year 0) 0 year)))))
+
+(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)))
+
+(define (month/short-string month)
+  (guarantee-month month 'MONTH/SHORT-STRING)
+  (vector-ref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun"
+                      "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
+             (- month 1)))
+
+(define (month/long-string month)
+  (guarantee-month month 'MONTH/LONG-STRING)
+  (vector-ref '#("January" "February" "March" "April" "May" "June"
+                          "July" "August" "September" "October"
+                          "November" "December")
+             (- month 1)))
+
+(define (guarantee-month month name)
+  (if (not (exact-integer? month))
+      (error:wrong-type-argument month "month integer" name))
+  (if (not (<= 1 month 12))
+      (error:bad-range-argument month name)))
+\f
+(define (decode-universal-time time)
+  (let ((result (allocate-decoded-time)))
     ((ucode-primitive decode-time 2) result time)
     result))
 
-(define (encode-time dt)
+(define (encode-universal-time dt)
   ((ucode-primitive encode-time 1) dt))
 
-(define (get-time)
+(define (get-universal-time)
   ((ucode-primitive encoded-time 0)))
 
 (define (get-decoded-time)
-  (decode-time (get-time)))
+  (decode-universal-time (get-universal-time)))
 
 (define (decoded-time/date-string time)
   (string-append
-   (vector-ref '#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday"
-                          "Saturday" "Sunday")
-              (decoded-time/day-of-week time))
-   " "
-   (vector-ref '#("January" "February" "March" "April" "May" "June"
-                           "July" "August" "September" "October"
-                           "November" "December")
-              (-1+ (decoded-time/month time)))
+   (if (decoded-time/day-of-week time)
+       (string-append
+       (vector-ref '#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday"
+                               "Saturday" "Sunday")
+                   (decoded-time/day-of-week time))
+       " ")
+       "")
+   (month/long-string (decoded-time/month time))
    " "
-   (write-to-string (decoded-time/day time))
+   (number->string (decoded-time/day time))
    ", "
-   (write-to-string (decoded-time/year time))))
+   (number->string (decoded-time/year time))))
 
 (define (decoded-time/time-string time)
   (let ((second (decoded-time/second time))
        (minute (decoded-time/minute time))
        (hour (decoded-time/hour time)))
-    (string-append (write-to-string
+    (string-append (number->string
                    (cond ((zero? hour) 12)
                          ((< hour 13) hour)
                          (else (- hour 12))))
                   (if (< minute 10) ":0" ":")
-                  (write-to-string minute)
+                  (number->string minute)
                   (if (< second 10) ":0" ":")
-                  (write-to-string second)
+                  (number->string second)
                   " "
                   (if (< hour 12) "AM" "PM"))))
\ No newline at end of file

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 71021bb2eda8ade3aa4ce43f2f3884588ca0140e..568a3b353f9c80d3ee0f6613fcbfaac2bb029e3d 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.251 1995/04/13 22:24:17 cph Exp $
+$Id: runtime.pkg,v 14.252 1995/04/15 06:10:04 cph Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -371,6 +371,7 @@ MIT in each case. |#
   (files "datime")
   (parent ())
   (export ()
+         decode-universal-time
          decoded-time/date-string
          decoded-time/day
          decoded-time/day-of-week
@@ -380,7 +381,13 @@ MIT in each case. |#
          decoded-time/second
          decoded-time/time-string
          decoded-time/year
-         get-decoded-time))
+         encode-universal-time
+         get-decoded-time
+         get-universal-time
+         make-decoded-time
+         month/long-string
+         month/max-days
+         month/short-string))
 
 (define-package (runtime debugger)
   (files "debug")

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index 71021bb2eda8ade3aa4ce43f2f3884588ca0140e..568a3b353f9c80d3ee0f6613fcbfaac2bb029e3d 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.251 1995/04/13 22:24:17 cph Exp $
+$Id: runtime.pkg,v 14.252 1995/04/15 06:10:04 cph Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -371,6 +371,7 @@ MIT in each case. |#
   (files "datime")
   (parent ())
   (export ()
+         decode-universal-time
          decoded-time/date-string
          decoded-time/day
          decoded-time/day-of-week
@@ -380,7 +381,13 @@ MIT in each case. |#
          decoded-time/second
          decoded-time/time-string
          decoded-time/year
-         get-decoded-time))
+         encode-universal-time
+         get-decoded-time
+         get-universal-time
+         make-decoded-time
+         month/long-string
+         month/max-days
+         month/short-string))
 
 (define-package (runtime debugger)
   (files "debug")