home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / datime.scm < prev    next >
Text File  |  2000-10-19  |  16KB  |  464 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: datime.scm,v 14.33 2000/10/19 21:34:19 cph Exp $
  4.  
  5. Copyright (c) 1988-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Date and Time Routines
  23. ;;; package: (runtime date/time)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Decoded Time
  28.  
  29. ;;; Based on Common Lisp definition.  Needs time zone stuff, and
  30. ;;; handling of abbreviated year specifications.
  31.  
  32. (define decoded-time-structure-tag "decoded-time")
  33.  
  34. (define-structure (decoded-time
  35.            (type vector)
  36.            (named decoded-time-structure-tag)
  37.            (conc-name decoded-time/)
  38.            (constructor %make-decoded-time)
  39.            (constructor allocate-decoded-time ())
  40.            (copier))
  41.   (second #f read-only #t)
  42.   (minute #f read-only #t)
  43.   (hour #f read-only #t)
  44.   (day #f read-only #t)
  45.   (month #f read-only #t)
  46.   (year #f read-only #t)
  47.   (day-of-week #f)
  48.   (daylight-savings-time #f read-only #t)
  49.   (zone #f))
  50.  
  51. (define (make-decoded-time second minute hour day month year #!optional zone)
  52.   (check-decoded-time-args second minute hour day month year
  53.                'MAKE-DECODED-TIME)
  54.   (let ((zone (if (default-object? zone) #f zone)))
  55.     (if (and zone (not (time-zone? zone)))
  56.     (error:wrong-type-argument zone "time zone" 'MAKE-DECODED-TIME))
  57.     (if zone
  58.     (%make-decoded-time second minute hour day month year
  59.                 (compute-day-of-week day month year)
  60.                 0
  61.                 zone)
  62.     (let ((dt
  63.            (%make-decoded-time second minute hour day month year 0 -1 #f)))
  64.       ;; These calls fill in the other fields of the structure.
  65.       ;; ENCODE-TIME can easily signal an error, for example on
  66.       ;; unix machines when the time is prior to 1970.
  67.       (let ((t (ignore-errors
  68.             (lambda () ((ucode-primitive encode-time 1) dt)))))
  69.         (if (condition? t)
  70.         (set-decoded-time/day-of-week!
  71.          dt
  72.          (compute-day-of-week day month year))
  73.         ((ucode-primitive decode-time 2) dt t)))
  74.       (if (decoded-time/zone dt)
  75.           (set-decoded-time/zone! dt (/ (decoded-time/zone dt) 3600)))
  76.       dt))))
  77.  
  78. (define (check-decoded-time-args second minute hour day month year procedure)
  79.   (let ((check-type
  80.      (lambda (object)
  81.        (if (not (exact-nonnegative-integer? object))
  82.            (error:wrong-type-argument object
  83.                       "exact non-negative integer"
  84.                       procedure)))))
  85.     (let ((check-range
  86.        (lambda (object min max)
  87.          (check-type object)
  88.          (if (not (<= min object max))
  89.          (error:bad-range-argument object procedure)))))
  90.       (check-type year)
  91.       (check-range month 1 12)
  92.       (check-range day 1 (month/max-days month))
  93.       (check-range hour 0 23)
  94.       (check-range minute 0 59)
  95.       (check-range second 0 59))))
  96.  
  97. (define (compute-day-of-week day month year)
  98.   ;; This implements Zeller's Congruence.
  99.   (modulo (+ day
  100.          (let ((y (remainder year 100)))
  101.            (+ y
  102.           (floor (/ y 4))))
  103.          (let ((c (quotient year 100)))
  104.            (- (floor (/ c 4))
  105.           (* 2 c)))
  106.          (let ((m (modulo (- month 2) 12)))
  107.            (- (floor (/ (- (* 13 m) 1) 5))
  108.           (* (floor (/ m 11))
  109.              (if (and (= 0 (remainder year 4))
  110.                   (or (not (= 0 (remainder year 100)))
  111.                   (= 0 (remainder year 400))))
  112.              2
  113.              1))))
  114.          ;; This -1 adjusts so that 0 corresponds to Monday.
  115.          ;; Normally, 0 corresponds to Sunday.
  116.          -1)
  117.       7))
  118.  
  119. (define (universal-time->local-decoded-time time)
  120.   (let ((result (allocate-decoded-time)))
  121.     ((ucode-primitive decode-time 2) result (- time epoch))
  122.     (if (decoded-time/zone result)
  123.     (set-decoded-time/zone! result (/ (decoded-time/zone result) 3600)))
  124.     result))
  125.  
  126. (define (universal-time->global-decoded-time time)
  127.   (let ((result (allocate-decoded-time)))
  128.     ((ucode-primitive decode-utc 2) result (- time epoch))
  129.     (if (decoded-time/zone result)
  130.     (set-decoded-time/zone! result (/ (decoded-time/zone result) 3600)))
  131.     result))
  132.  
  133. (define (decoded-time->universal-time dt)
  134.   (+ ((ucode-primitive encode-time 1)
  135.       (if (decoded-time/zone dt)
  136.       (let ((dt* (copy-decoded-time dt)))
  137.         (set-decoded-time/zone! dt* (* (decoded-time/zone dt*) 3600))
  138.         dt*)
  139.       dt))
  140.      epoch))
  141.  
  142. (define (get-universal-time)
  143.   (+ epoch ((ucode-primitive encoded-time 0))))
  144.  
  145. (define epoch 2208988800)
  146.  
  147. (define (local-decoded-time)
  148.   (universal-time->local-decoded-time (get-universal-time)))
  149.  
  150. (define (global-decoded-time)
  151.   (universal-time->global-decoded-time (get-universal-time)))
  152.  
  153. (define (time-zone? object)
  154.   (and (number? object)
  155.        (exact? object)
  156.        (<= -24 object 24)
  157.        (integer? (* 3600 object))))
  158.  
  159. (define (decoded-time/daylight-savings-time? dt)
  160.   (> (decoded-time/daylight-savings-time dt) 0))
  161.  
  162. (define (decoded-time/date-string time)
  163.   (string-append (let ((day (decoded-time/day-of-week time)))
  164.            (if day
  165.                (string-append (day-of-week/long-string day) " ")
  166.                ""))
  167.          (month/long-string (decoded-time/month time))
  168.          " "
  169.          (number->string (decoded-time/day time))
  170.          ", "
  171.          (number->string (decoded-time/year time))))
  172.  
  173. (define (decoded-time/time-string time)
  174.   (let ((second (decoded-time/second time))
  175.     (minute (decoded-time/minute time))
  176.     (hour (decoded-time/hour time)))
  177.     (string-append (number->string
  178.             (cond ((zero? hour) 12)
  179.               ((< hour 13) hour)
  180.               (else (- hour 12))))
  181.            (if (< minute 10) ":0" ":")
  182.            (number->string minute)
  183.            (if (< second 10) ":0" ":")
  184.            (number->string second)
  185.            " "
  186.            (if (< hour 12) "AM" "PM"))))
  187.  
  188. (define (universal-time->local-time-string time)
  189.   (decoded-time->string (universal-time->local-decoded-time time)))
  190.  
  191. (define (universal-time->global-time-string time)
  192.   (decoded-time->string (universal-time->global-decoded-time time)))
  193.  
  194. (define (file-time->local-time-string time)
  195.   (decoded-time->string (file-time->local-decoded-time time)))
  196.  
  197. (define (file-time->global-time-string time)
  198.   (decoded-time->string (file-time->global-decoded-time time)))
  199.  
  200. (define (decoded-time->string dt)
  201.   ;; The returned string is in the format specified by RFC 822,
  202.   ;; "Standard for the Format of ARPA Internet Text Messages",
  203.   ;; provided that time-zone information is available from the C
  204.   ;; library.
  205.   (let ((d2 (lambda (n) (string-pad-left (number->string n) 2 #\0))))
  206.     (string-append (let ((day (decoded-time/day-of-week dt)))
  207.              (if day
  208.              (string-append (day-of-week/short-string day) ", ")
  209.              ""))
  210.            (number->string (decoded-time/day dt))
  211.            " "
  212.            (month/short-string (decoded-time/month dt))
  213.            " "
  214.            (number->string (decoded-time/year dt))
  215.            " "
  216.            (d2 (decoded-time/hour dt))
  217.            ":"
  218.            (d2 (decoded-time/minute dt))
  219.            ":"
  220.            (d2 (decoded-time/second dt))
  221.            (let ((zone (decoded-time/zone dt)))
  222.              (if zone
  223.              (string-append
  224.               " "
  225.               (time-zone->string
  226.                (if (decoded-time/daylight-savings-time? dt)
  227.                    (- zone 1)
  228.                    zone)))
  229.              "")))))
  230.  
  231. (define (string->decoded-time string)
  232.   ;; STRING must be in RFC-822 format.
  233.   (let ((lose
  234.      (lambda ()
  235.        (error "Ill-formed RFC-822 time string:" string))))
  236.     (let ((tokens
  237.        (let ((tokens (burst-string string char-set:whitespace #t)))
  238.          (case (length tokens)
  239.            ((4)
  240.         ;; Workaround for very old mail messages with dates in
  241.         ;; the following format: "24 September 1984 18:42-EDT".
  242.         (let ((tokens* (burst-string (list-ref tokens 3) #\- #f)))
  243.           (if (fix:= 2 (length tokens*))
  244.               (list (car tokens)
  245.                 (cadr tokens)
  246.                 (caddr tokens)
  247.                 (car tokens*)
  248.                 (cadr tokens*))
  249.               (lose))))
  250.            ((5) tokens)
  251.            ((6)
  252.         (if (and (fix:= 4 (string-length (car tokens)))
  253.              (char=? #\, (string-ref (car tokens) 3))
  254.              (string-ci->index days-of-week/short-strings
  255.                        (substring (car tokens) 0 3)))
  256.             (cdr tokens)
  257.             (lose)))
  258.            (else (lose))))))
  259.       (let ((time (burst-string (list-ref tokens 3) #\: #f)))
  260.     (if (not (memv (length time) '(2 3)))
  261.         (error "Ill-formed RFC-822 time string:" string))
  262.     (make-decoded-time (if (pair? (cddr time))
  263.                    (string->number (caddr time))
  264.                    0)
  265.                (string->number (cadr time))
  266.                (string->number (car time))
  267.                (string->number (list-ref tokens 0))
  268.                (string->month (list-ref tokens 1))
  269.                (string->year (list-ref tokens 2))
  270.                (string->time-zone (list-ref tokens 4)))))))
  271.  
  272. (define (string->universal-time string)
  273.   (decoded-time->universal-time (string->decoded-time string)))
  274.  
  275. (define (string->file-time string)
  276.   (decoded-time->file-time (string->decoded-time string)))
  277.  
  278. (define (time-zone->string tz)
  279.   (if (not (time-zone? tz))
  280.       (error:wrong-type-argument tz "time zone" 'TIME-ZONE->STRING))
  281.   (let ((minutes (round (* 60 (- tz)))))
  282.     (let ((qr (integer-divide (abs minutes) 60))
  283.       (d2 (lambda (n) (string-pad-left (number->string n) 2 #\0))))
  284.       (string-append (if (< minutes 0) "-" "+")
  285.              (d2 (integer-divide-quotient qr))
  286.              (d2 (integer-divide-remainder qr))))))
  287.  
  288. (define (string->time-zone string)
  289.   (let ((entry
  290.      (list-search-positive named-time-zones
  291.        (lambda (zone)
  292.          (string-ci=? string (car zone))))))
  293.     (if entry
  294.     (cadr entry)
  295.     (let ((n (string->number string)))
  296.       (if (not (and (exact-integer? n)
  297.             (<= -2400 n 2400)))
  298.           (error "Malformed time zone:" string))
  299.       (let ((qr (integer-divide (abs n) 100)))
  300.         (let ((hours (integer-divide-quotient qr))
  301.           (minutes (integer-divide-remainder qr)))
  302.           (if (not (<= 0 minutes 59))
  303.           (error "Malformed time zone:" string))
  304.           (let ((hours (+ hours (/ minutes 60))))
  305.         (if (< n 0)
  306.             hours
  307.             (- hours)))))))))
  308.  
  309. (define named-time-zones
  310.   '(("UT" 0)
  311.     ("GMT" 0)
  312.     ("EST" 5) ("EDT" 4) ("CST" 6) ("CDT" 5)
  313.     ("MST" 7) ("MDT" 6) ("PST" 8) ("PDT" 7)
  314.     ("A" 1) ("B" 2) ("C" 3) ("D" 4) ("E" 5) ("F" 6)
  315.     ("G" 7) ("H" 8) ("I" 9) ("K" 10) ("L" 11) ("M" 12)
  316.     ("N" -1) ("O" -2) ("P" -3) ("Q" -4) ("R" -5) ("S" -6)
  317.     ("T" -7) ("U" -8) ("V" -9) ("W" -10) ("X" -11) ("Y" -12)
  318.     ("Z" 0)))
  319.  
  320. ;;;; ISO C ctime() strings
  321.  
  322. (define (decoded-time->ctime-string dt)
  323.   (string-append
  324.    (day-of-week/short-string (decoded-time/day-of-week dt))
  325.    " "
  326.    (month/short-string (decoded-time/month dt))
  327.    " "
  328.    (string-pad-left (number->string (decoded-time/day dt)) 2)
  329.    " "
  330.    (string-pad-left (number->string (decoded-time/hour dt)) 2 #\0)
  331.    ":"
  332.    (string-pad-left (number->string (decoded-time/minute dt)) 2 #\0)
  333.    ":"
  334.    (string-pad-left (number->string (decoded-time/second dt)) 2 #\0)
  335.    " "
  336.    (number->string (decoded-time/year dt))))
  337.  
  338. (define (ctime-string->decoded-time string #!optional zone)
  339.   (let ((zone (if (default-object? zone) #f zone))
  340.     (lose (lambda () (error "Ill-formed ctime() string:" string))))
  341.     (if (and zone (not (time-zone? zone)))
  342.     (error:wrong-type-argument zone "time zone"
  343.                    'CTIME-STRING->DECODED-TIME))
  344.     (let ((tokens (burst-string string #\space #t)))
  345.       (if (not (fix:= 5 (length tokens)))
  346.       (lose))
  347.       (let ((time (burst-string (list-ref tokens 3) #\: #f)))
  348.     (case (length time)
  349.       ((3)
  350.        (make-decoded-time (string->number (caddr time))
  351.                   (string->number (cadr time))
  352.                   (string->number (car time))
  353.                   (string->number (list-ref tokens 2))
  354.                   (string->month (list-ref tokens 1))
  355.                   (string->year (list-ref tokens 4))
  356.                   zone))
  357.       ((2)
  358.        (make-decoded-time 0
  359.                   (string->number (cadr time))
  360.                   (string->number (car time))
  361.                   (string->number (list-ref tokens 2))
  362.                   (string->month (list-ref tokens 1))
  363.                   (string->year (list-ref tokens 4))
  364.                   zone))
  365.       (else
  366.        (lose)))))))
  367.  
  368. (define (universal-time->local-ctime-string time)
  369.   (decoded-time->ctime-string (universal-time->local-decoded-time time)))
  370.  
  371. (define (universal-time->global-ctime-string time)
  372.   (decoded-time->ctime-string (universal-time->global-decoded-time time)))
  373.  
  374. (define (ctime-string->universal-time string #!optional zone)
  375.   (decoded-time->universal-time
  376.    (ctime-string->decoded-time string (if (default-object? zone) #f zone))))
  377.  
  378. (define (file-time->local-ctime-string time)
  379.   (decoded-time->ctime-string (file-time->local-decoded-time time)))
  380.  
  381. (define (file-time->global-ctime-string time)
  382.   (decoded-time->ctime-string (file-time->global-decoded-time time)))
  383.  
  384. (define (ctime-string->file-time string #!optional zone)
  385.   (decoded-time->file-time
  386.    (ctime-string->decoded-time string (if (default-object? zone) #f zone))))
  387.  
  388. (define (month/max-days month)
  389.   (guarantee-month month 'MONTH/MAX-DAYS)
  390.   (vector-ref '#(31 29 31 30 31 30 31 31 30 31 30 31) (- month 1)))
  391.  
  392. (define (month/short-string month)
  393.   (guarantee-month month 'MONTH/SHORT-STRING)
  394.   (vector-ref month/short-strings (- month 1)))
  395.  
  396. (define (month/long-string month)
  397.   (guarantee-month month 'MONTH/LONG-STRING)
  398.   (vector-ref month/long-strings (- month 1)))
  399.  
  400. (define (guarantee-month month name)
  401.   (if (not (exact-integer? month))
  402.       (error:wrong-type-argument month "month integer" name))
  403.   (if (not (<= 1 month 12))
  404.       (error:bad-range-argument month name)))
  405.  
  406. (define (string->month string)
  407.   (fix:+ 1
  408.      (or (string-ci->index month/short-strings string)
  409.          (string-ci->index month/long-strings string)
  410.          (error "Unknown month designation:" string))))
  411.  
  412. (define month/short-strings
  413.   '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
  414.  
  415. (define month/long-strings
  416.   '#("January" "February" "March" "April" "May" "June" "July" "August"
  417.            "September" "October" "November" "December"))
  418.  
  419. (define (day-of-week/short-string day)
  420.   (guarantee-day-of-week day 'DAY-OF-WEEK/SHORT-STRING)
  421.   (vector-ref days-of-week/short-strings day))
  422.  
  423. (define (day-of-week/long-string day)
  424.   (guarantee-day-of-week day 'DAY-OF-WEEK/LONG-STRING)
  425.   (vector-ref days-of-week/long-strings day))
  426.  
  427. (define (guarantee-day-of-week day name)
  428.   (if (not (exact-integer? day))
  429.       (error:wrong-type-argument day "day-of-week integer" name))
  430.   (if (not (<= 0 day 6))
  431.       (error:bad-range-argument day name)))
  432.  
  433. (define (string->day-of-week string)
  434.   (or (string-ci->index days-of-week/short-strings string)
  435.       (string-ci->index days-of-week/long-strings string)
  436.       (error "Unknown day-of-week designation:" string)))
  437.  
  438. (define days-of-week/short-strings
  439.   '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
  440.  
  441. (define days-of-week/long-strings
  442.   '#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
  443.  
  444. (define (string-ci->index string-vector string)
  445.   (let ((end (vector-length string-vector)))
  446.     (let loop ((index 0))
  447.       (cond ((fix:= index end) #f)
  448.         ((string-ci=? string (vector-ref string-vector index)) index)
  449.         (else (loop (fix:+ index 1)))))))
  450.  
  451. (define (string->year string)
  452.   (let ((n (string->number string)))
  453.     (if (not (exact-nonnegative-integer? n))
  454.     (error:bad-range-argument string 'STRING->YEAR))
  455.     (cond ((< n 70) (+ 2000 n))
  456.       ((< n 100) (+ 1900 n))
  457.       (else n))))
  458.  
  459. ;; Upwards compatibility
  460. (define decode-universal-time universal-time->local-decoded-time)
  461. (define encode-universal-time decoded-time->universal-time)
  462. (define get-decoded-time local-decoded-time)
  463. (define universal-time->string universal-time->local-time-string)
  464. (define file-time->string file-time->local-time-string)