;;; -*- Mode: Common-Lisp; Package: TIME; Base: 10.; Patch-File: T -*- ;;; Reason: PARSE-UNIVERSAL-TIME was not handling the case of *abs-time* greater than current time and futurep is NIL. This should return a time based on the previous day. If the previous month contains less days you get thrown into the error handler. [10827] ;;; RESTRICTED RIGHTS LEGEND ;;; ;;; Use, duplication, or disclosure by the Government is subject to ;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;; Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909, M/S 2151 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1989 Texas Instruments Incorporated. ;;; All rights reserved. ;;; Written 12/01/89 12:02:19 by BERGER, ;;; while running on ARIES from band LODX ;;; With SYSTEM 6.26, VIRTUAL-MEMORY 6.3, EH 6.5, MAKE-SYSTEM 6.2, MICRONET 6.0, LOCAL-FILE 6.1, ;;; BASIC-PATHNAME 6.2, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.7, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.2, DISK-LABEL 6.0, BASIC-FILE 6.6, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; COMPILER 6.14, TV 6.19, DATALINK 6.0, CHAOSNET 6.5, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2, ;;; SYSLOG 6.2, STREAMER-TAPE 6.5, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, Inconsistent ZWEI 6.9, ;;; DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.1, NETWORK-SERVICE 6.2, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.2, ;;; IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.4, MAIL-READER 6.6, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.4, PROFILE 6.2, Inconsistent VISIDOC 6.7, TI-CLOS 6.26, CLEH 6.5, ;;; IP 3.56, Experimental CLX 6.7, CLUE 6.35, X11M 6.18, Experimental BUG 11.17, ;;; microcode 429, Band Name: REL 6.0 + SLE 11/28 #!C ; From file TIME-PARSE.LISP#> KERNEL; SYS: #10R TIME#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TIME")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; TIME-PARSE.#" (DEFUN PARSE-UNIVERSAL-TIME (STRING &OPTIONAL (START 0) END (FUTUREP T) BASE-TIME MUST-HAVE-TIME DATE-MUST-HAVE-YEAR TIME-MUST-HAVE-SECOND (DAY-MUST-BE-VALID T)) "Return a universal-time parsed from STRING, or the part from START to END. FUTUREP controls the interpretation if there is just a day-of-the-week: T means use the next such day, NIL means use the previous. BASE-TIME is used if the string is a relative time. It is what the relative time is relative to. Default is now. MUST-HAVE-TIME if T means error if the string is empty. DATE-MUST-HAVE-YEAR if T means error if no year number. TIME-MUST-HAVE-SECOND if T means error if time doesn't include a number of seconds. DAY-MUST-BE-VALID if NIL means allow things like February 29 (which equals March 1 or March 2)." (DECLARE (VALUES UNIVERSAL-TIME RELATIVE-P)) (BLOCK () (BLOCK KLUDGE (IF (AND MUST-HAVE-TIME (EQUAL STRING "")) (FERROR 'PARSE-ERROR "The supplied time string is empty.")) (IF (NULL END) (SETQ END (LENGTH STRING))) (LET ((TEM (PARSE-TWENEX-TIME STRING START END))) (IF TEM (RETURN (VALUES TEM ())))) (LET (*ABS-YEAR* *ABS-MONTH* *ABS-DATE* *ABS-HOUR* *ABS-MINUTE* *ABS-SECOND* *ABS-DAY-OF-THE-WEEK* *ABS-TIME-ZONE* (*REL-YEAR* 0) (*REL-MONTH* 0) (*REL-DATE* 0) (*REL-HOUR* 0) (*REL-MINUTE* 0) (*REL-SECOND* 0) *REL-DAY-OF-THE-WEEK*; *REL-TIME-ZONE* *BASE-YEAR* *BASE-MONTH* *BASE-DATE* *BASE-HOUR* *BASE-MINUTE* *BASE-SECOND* *RELATIVE-P*);; Compute the "base" time: the time to which the string is relative. (COND ((NULL BASE-TIME);; Time is relative to right now. (MULTIPLE-VALUE-SETQ (*BASE-SECOND* *BASE-MINUTE* *BASE-HOUR* *BASE-DATE* *BASE-MONTH* *BASE-YEAR*) (GET-TIME));; If the time is not known, assume a default base time so that we ;; can still parse fully-specified date/times (e.g. in the file system) (IF (NULL *BASE-SECOND*) (SETQ *BASE-SECOND* 0 *BASE-MINUTE* 0 *BASE-HOUR* 0 *BASE-DATE* 1 *BASE-MONTH* 1 *BASE-YEAR* 0))) (T;; Time is relative to a specified time. (MULTIPLE-VALUE-SETQ (*BASE-SECOND* *BASE-MINUTE* *BASE-HOUR* *BASE-DATE* *BASE-MONTH* *BASE-YEAR*) (DECODE-UNIVERSAL-TIME BASE-TIME))));; Do the parse, calling the action routines, which work by setting the ;; ABS and REL special variables bound above. (PARSE-1 (DELQ-ALL (LEXICALLY-ANALYZE STRING START END) *NOISE-WORDS*) 'MAIN) (IF (AND DATE-MUST-HAVE-YEAR (NULL *ABS-YEAR*)) (BARF "no year supplied")) (IF (AND TIME-MUST-HAVE-SECOND (NULL *ABS-SECOND*)) (BARF "no seconds supplied"));; Now apply lots of defaults. ;; There are many terms, from the lowest order (seconds) to the highest ;; order (years). A legal date must specify some contiguous subsequence ;; of these. The low unspecified ones get zeroed; the high unspecified ;; ones are either the next in the future or the previous in the past. ;; Time zones and days of the week are handled specially. ;; First, the following code allows a day of the week to be used to ;; specify a year, month, and date, when it is supposed to. (IF (AND (NULL *ABS-YEAR*) (NULL *ABS-MONTH*) (NULL *ABS-DATE*) (NOT (NULL *ABS-DAY-OF-THE-WEEK*)));; Day of week specified the year, month, and date. (LET ((UT (ENCODE-UNIVERSAL-TIME 0 0 0 *BASE-DATE* *BASE-MONTH* *BASE-YEAR*))) (MULTIPLE-VALUE-BIND (NIL NIL NIL NIL NIL NIL BASE-DAY-OF-THE-WEEK) (DECODE-UNIVERSAL-TIME UT) (LET ((DELTA-DAYS (- *ABS-DAY-OF-THE-WEEK* BASE-DAY-OF-THE-WEEK))) (IF FUTUREP (DO () ((> DELTA-DAYS 0)) (SETQ DELTA-DAYS (+ DELTA-DAYS 7))) (DO () ((< DELTA-DAYS 0)) (SETQ DELTA-DAYS (- DELTA-DAYS 7)))) (MULTIPLE-VALUE-SETQ (NIL NIL NIL *ABS-DATE* *ABS-MONTH* *ABS-YEAR*) (COMPUTE-RELATIVE 0 0 0 (+ *BASE-DATE* DELTA-DAYS) *BASE-MONTH* *BASE-YEAR*))))));; If everything was specified (as in a date read from a file server) ;; then skip worrying about defaulting. (OR (AND *ABS-YEAR* *ABS-MONTH* *ABS-DATE* *ABS-HOUR* *ABS-MINUTE* *ABS-SECOND*);; Non-specified low-order terms get set to zero (or the moral equivalent ;; of zero), up to the first speicified term. (DO ((TERMS '(*ABS-SECOND* *ABS-MINUTE* *ABS-HOUR* *ABS-DATE* *ABS-MONTH* *ABS-YEAR*) (CDR TERMS)) (BASE-TERMS '(*BASE-SECOND* *BASE-MINUTE* *BASE-HOUR* *BASE-DATE* *BASE-MONTH* *BASE-YEAR*) (CDR BASE-TERMS)) (LOWEST '(0 0 0 1 1 -100000000) (CDR LOWEST)) (HIGHEST '(59 59 23 NIL 12 100000000) (CDR HIGHEST)) (STATE 'DEFAULT-LOW-TERMS) (COMPARISON 'EQUAL) (OPERATION NIL)) ((NULL TERMS) (IF (EQ STATE 'DEFAULT-LOW-TERMS) (BARF "No time was specified."))) RESTART (LET ((TERM-VALUE (SYMBOL-VALUE (CAR TERMS))) (BASE-TERM-VALUE (SYMBOL-VALUE (CAR BASE-TERMS)))) (CASE STATE (DEFAULT-LOW-TERMS;; Non-specified low-order terms get set to default values, which ;; are zero or one depending on whether the quantity is zero-based ;; or one-based. (COND ((NULL TERM-VALUE);; Term is non-specified, default it. (SET (CAR TERMS) (CAR LOWEST))) (T;; Term is specified: go to the next state and try again. (SETQ STATE 'SKIP-OVER-SPECIFIED) (GO RESTART)))) (SKIP-OVER-SPECIFIED;; Now we are moving over the contiguous subsequence of values ;; specified by the user. (COND ((NOT (NULL TERM-VALUE));; This value was specified by the user. (COND ((> TERM-VALUE BASE-TERM-VALUE);; Specified time is later than the base time. (SETQ COMPARISON 'LATER)) ((< TERM-VALUE BASE-TERM-VALUE);; Specified time is earlier than the base time. (SETQ COMPARISON 'EARLIER));; If these terms are equal, use the old value of ;; COMPARISON based on the lower order terms. )) (T;; Term is not specified; go to the next state and try again. ;; This SETQ is documented at the next state. (SETQ OPERATION (CASE COMPARISON (EQUAL;; The specified and base times are equal, do nothing. 'EQUAL) (LATER;; Specified time is later than base time. (IF FUTUREP 'EQUAL 'SUB1)) (EARLIER;; Specified time is earlier than base time. (IF FUTUREP 'ADD1 'EQUAL)))) (SETQ STATE 'DEFAULT-HIGH-TERMS) (GO RESTART)))) (DEFAULT-HIGH-TERMS;; Non-specified high-order terms come from the base time. The ;; tricky thing is that we may have to add or subtract one, depending ;; on FUTUREP and COMPARISON, which requires propagating carry or ;; borrow. This information is encoded in OPERATION, which is SETQed ;; above (so that we don't do it each time around the loop!). (IF (NOT (NULL TERM-VALUE));; Foo, the rest of the high-order terms have to be unspecified. (BARF "Unrecognized pattern of defaulting.")) (CASE OPERATION (EQUAL;; We are just copying base time into abs time. Keep doing it. (SET (CAR TERMS) BASE-TERM-VALUE)) (ADD1;; Set this term one higher than it is in the base time. (LET ((HIGHEST-VALUE;; Compute the highest legal value for this term. (IF (EQ (CAR TERMS) '*ABS-DATE*);; Highest possible value for dates depends on ;; which month this is. (MONTH-LENGTH *BASE-MONTH* *BASE-YEAR*);; Other highest values are just constants. (CAR HIGHEST)))) (COND ((< BASE-TERM-VALUE HIGHEST-VALUE);; No carry. Just add one, and copy the rest. (SET (CAR TERMS) (1+ BASE-TERM-VALUE)) (SETQ OPERATION 'EQUAL)) (T;; Carry into next term. (SET (CAR TERMS) (CAR LOWEST)))))) (SUB1;; Set this term one lower than it is in the base time. (COND ((> BASE-TERM-VALUE (CAR LOWEST));; No borrow. Just subtract one, and copy the rest. (SET (CAR TERMS) (1- BASE-TERM-VALUE)) (SETQ OPERATION 'EQUAL)) (T;; Borrow from the next term. (SET (CAR TERMS) (IF (EQ (CAR TERMS) '*ABS-DATE*);; Highest possible value for dates depends on ;; which month this is. (MONTH-LENGTH (if (eq *base-date* 1) ;;DAB 12-01-89 This case occurs when time is in previous day. The Month-lenght ;;needs to depend upon last month. [10827] (1- *BASE-MONTH*) *BASE-MONTH*) *BASE-YEAR*);; Other highest values are just constants. (CAR HIGHEST)))))) (OTHERWISE (FERROR () "Bad value of OPERATION ~S" OPERATION)))) (OTHERWISE (FERROR () "Bad value of STATE ~S" STATE))))));; Now hack other random defaults. ; (IF (NULL *ABS-TIME-ZONE*) ; (SETQ *ABS-TIME-ZONE* *TIMEZONE*)) ; (SETQ *REL-TIME-ZONE* *ABS-TIME-ZONE*) ;; Check ranges. (CHECK-RANGE *ABS-SECOND* 0 59 "seconds in a minute") (CHECK-RANGE *ABS-MINUTE* 0 59 "minutes in an hour") (CHECK-RANGE *ABS-HOUR* 0 23 "hours in a day");Check this before MONTH-STRING call! (CHECK-RANGE *ABS-MONTH* 1 12 "months in a year") (CHECK-RANGE *ABS-DATE* 1 (MONTH-LENGTH *ABS-MONTH* *ABS-YEAR*) (FORMAT () "days in ~A" (MONTH-STRING *ABS-MONTH*))) (IF (AND DAY-MUST-BE-VALID (NOT (NULL *ABS-DAY-OF-THE-WEEK*))) (VERIFY-DATE *ABS-DATE* *ABS-MONTH* *ABS-YEAR* *ABS-DAY-OF-THE-WEEK*));; Now put it together. (MULTIPLE-VALUE-SETQ (*ABS-SECOND* *ABS-MINUTE* *ABS-HOUR* *ABS-DATE* *ABS-MONTH* *ABS-YEAR*) (COMPUTE-RELATIVE (+ *ABS-SECOND* *REL-SECOND*) (+ *ABS-MINUTE* *REL-MINUTE*) (+ *ABS-HOUR* *REL-HOUR*) (+ *ABS-DATE* *REL-DATE*) (+ *ABS-MONTH* *REL-MONTH*) (+ *ABS-YEAR* *REL-YEAR*))) (RETURN (VALUES (ENCODE-UNIVERSAL-TIME *ABS-SECOND* *ABS-MINUTE* *ABS-HOUR* *ABS-DATE* *ABS-MONTH* *ABS-YEAR* *ABS-TIME-ZONE*) *RELATIVE-P*))) ());This is needed because multiple values )) ))