;;; Copyright (c) 2017, Sudhir Shenoy.  All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;;; Parse-Date.lisp - Contains a string to date-time converter that accurately
;;;; parses most common ways of writing dates.
;;;;
;;;; See test-parse-dates.lisp for examples.
;;;;
;;;; Only the string->date function is exported from this file - all other functions
;;;; are simply supporting functions for string->date and are not meant to be used
;;;; elsewhere.
;;;;
;;;; The code is largely based on the Python dateutils library but there are some
;;;; differences and optimizations

(in-package :cl-dates)

(defparameter +white-space+ '(#\space #\tab #\return #\linefeed #\newline))
(defun white-space-p (char)
  (member char +white-space+ :test #'char=))

(defun tokenize (str)
  (let ((token-list nil)
	(state nil)
	(token nil)
	(seen-alpha nil))
    (labels ((split-list (test list &aux (start list) (end list))
	       (loop while (and end (setq start (member-if-not test end)))
		     collect (ldiff start (setq end (member-if test start)))))
	     (emit-token ()
	       (if (and (member state '(:in-alpha-num :in-num-alpha))
			(or seen-alpha
			    (> (count #\. token) 1)
			    (char= #\. (car token)))
			;; ugly special casing for a.m./p.m. strings
			(not (equal token '(#\. #\m #\. #\a)))
			(not (equal token '(#\m #\. #\a)))
			(not (equal token '(#\. #\m #\. #\p)))
			(not (equal token '(#\m #\. #\p))))
		   (progn
		     ;; separate "23.jun.2017" => "23" "." "jun" "." "2017"
		     ;; any trailing period will be dropped
		     (setf token (nreverse token))
		     (loop for tk on (split-list (lambda(x) (char= x #\.)) token)
			   do (progn
				(push (coerce (car tk) 'string) token-list)
				(unless (null (cdr tk))
				  (push "." token-list)))))
		   (push (coerce (nreverse token) 'string) token-list))
	       ;; reset state
	       (setf state nil seen-alpha nil token nil)))
      (do ((i 0 (1+ i))
	   (len-str (length str)))
	  ((>= i len-str))
	(let ((ch (schar str i)))
	  (case state
	    ((nil)
	     (push ch token)
	     (setf state (cond ((alpha-char-p ch) :in-alpha)
			       ((digit-char-p ch) :in-num)
			       ((white-space-p ch) :in-space)
			       (t :in-separators))))
	    (:in-separators
	     (if (or (alphanumericp ch) (white-space-p ch))
		 (progn
		   (decf i)
		   (emit-token))
		 (push ch token)))
	    (:in-space
	     (when (not (white-space-p ch))
	       ;; throw away white space and reset state
	       (decf i)
	       (setf token nil state nil)))
	    (:in-alpha
	     (setf seen-alpha t)
	     (cond ((alpha-char-p ch) (push ch token))
		   ((char= ch #\.)
		    (push ch token)
		    (setf state :in-alpha-num))
		   (t (decf i)
		      (emit-token))))
	    (:in-num
	     (cond ((digit-char-p ch) (push ch token))
		   ((char= ch #\.)
		    (push ch token)
		    (setf state :in-num-alpha))
		   (t (decf i)
		      (emit-token))))
	    (:in-alpha-num
	     (setf seen-alpha t)
	     (cond ((or (alpha-char-p ch) (char= ch #\.)) (push ch token))
		   ((and (digit-char-p ch) token (char= #\. (car token)))
		    (push ch token)
		    (setf state :in-num-alpha))
		   (t (decf i)
		      (emit-token))))
	    (:in-num-alpha
	     (cond ((or (digit-char-p ch) (char= ch #\.)) (push ch token))
		   ((and (alpha-char-p ch) token (char= #\. (car token)))
		    (push ch token)
		    (setf state :in-alpha-num))
		   (t(decf i)
		     (emit-token)))))))
      (when (and token (not (member state '(:in-space :in-separators))))
	(emit-token)))
    (nreverse token-list)))

(defun advance-date (dt dow dir)
  (if (eq dir :closest)
      (let ((next (advance-date dt dow :next))
	    (prev (advance-date dt dow :prev)))
	(if (< (- dt prev) (- next dt))
	    prev
	    next))
      (let ((inc (if (eq dir :next) 1 -1)))
	(loop
	      (if (eq (day-of-week dt) dow)
		  (return dt)
		  (incf dt inc))))))

(defun make-four-digit-year (year)
  (if (> year 99)
      year
      (multiple-value-bind (s m h dd mm yy dw dst zone)
	  (decode-universal-time (get-universal-time) 0)
	(declare (ignore s m h dd mm dw dst zone))
	(let ((century (* 100 (truncate (/ yy 100)))))
	  (incf year century)
	  (if (>= (abs (- year yy)) 50)
	      (if (< year yy)
		  (+ year 100)
		  (- year 100))
	      year)))))

;; decide between yy/mm and mm/yy
(defun assign-yy-mm (list precedence)
  (cond ((> (car list) 12) (values (car list) (cadr list)))
	((> (cadr list) 12) (values (cadr list) (car list)))
	((eq precedence :ymd) (values (car list) (cadr list)))
	(t (values (cadr list) (car list)))))

;; decide between yy/dd and dd/yy
(defun assign-yy-dd (list precedence)
  (cond ((> (car list) 31) (values (car list) (cadr list)))
	((> (cadr list) 31) (values (cadr list) (car list)))
	((eq precedence :ymd) (values (car list) (cadr list)))
	(t (values (cadr list) (car list)))))

;; decide between dd/mm and mm/dd
(defun assign-mm-dd (list precedence)
  (cond ((> (car list) 12) (values (cadr list) (car list)))
	((> (cadr list) 12) (values (car list) (cadr list)))
	((or (eq precedence :ymd) (eq precedence :mdy))
	 (values (car list) (cadr list)))
	(t (values (cadr list) (car list)))))

;; decide order in which day, month and year appear given 2 or 3 numbers
(defun assign-yy-mm-dd (list precedence)
  (if (= 2 (length list))
      (cond ((and (> (car list) 12) (> (cadr list) 12))
	     (multiple-value-bind (yy dd) (assign-yy-dd list precedence)
	       (values yy nil dd)))
	    (t (multiple-value-bind (yy mm) (assign-yy-mm list precedence)
		 (values yy mm nil))))
      (let (tmp)
	(cond ((every (lambda(x) (<= x 12)) list)
	       ;; 01/02/03
	       (cond ((eq precedence :mdy) (values (third list) (first list) (second list)))
		     ((eq precedence :dmy) (values (third list) (second list) (first list)))
		     (t (values (first list) (second list) (third list)))))
	      ((setf tmp (find-if (lambda(x) (> x 31)) list))
	       ;; 12/5/55
	       (setf list (remove tmp list :count 1))
	       (multiple-value-bind (mm dd) (assign-mm-dd list precedence)
		 (values tmp mm dd)))
	      ((= 1 (count-if (lambda(x) (<= x 12)) list))
	       (setf tmp (find-if (lambda(x) (<= x 12)) list)
		     list (remove tmp list :count 1))
	       (multiple-value-bind (yy dd) (assign-yy-dd list precedence)
		 (values yy tmp dd)))
	      (t ;; 5/6/27
	       (cond ((eq precedence :ymd)
		      (multiple-value-bind (mm dd) (assign-mm-dd (cdr list) precedence)
			(values (car list) mm dd)))
		     ((eq precedence :dmy)
		      (multiple-value-bind (yy mm) (assign-yy-mm (cdr list) precedence)
			(values yy mm (car list))))
		     (t (multiple-value-bind (yy dd) (assign-yy-dd (cdr list) precedence)
			  (values yy (car list) dd)))))))))

;; struct to hold values during parse
(defstruct (date-components (:conc-name dt-))
  dow yr mth day hr min sec tz)

(defparameter +date-separators+ '("." "/" "-"))

(defparameter +time-suffixes+ '((:hour . ("h" "hr" "hrs" "hour" "hours"))
				(:minute . ("m" "min" "mins" "minute" "minutes"))
				(:second . ("s" "sec" "secs" "second" "seconds"))))
(defun str-to-hms (str)
  "Interpret string as hour / minute / second"
  (loop for i from 0 below 3
	do (let ((list (elt +time-suffixes+ i)))
	     (when (member str (cdr list) :test #'string-equal)
	       (return-from str-to-hms (car list))))))

(defun str-to-ampm (str)
  "Interpret string as AM / PM"
  (cond ((member str '("a.m." "a.m" "am" "morning") :test #'string-equal) :am)
	((member str '("p.m." "p.m" "pm" "evening" "afternoon") :test #'string-equal) :pm)
	(t nil)))

(defun str-is-day-suffix (str)
  "Return true if string is a suffix for a number"
  (not (null (member str '("st" "nd" "rd" "th") :test #'string-equal))))

(defun str-to-relative-dow (str)
  (cond ((member str '("last" "prev" "previous") :test #'string-equal) :prev)
	((member str '("next" "coming") :test #'string-equal) :next)
	((string-equal str "this") :closest)
	(t nil)))

(defparameter +date-words+ '(("today" . 0) ("tomorrow" . 1) ("yesterday" . -1)))
(defun str-to-relative-date (str)
  (cdr (find str +date-words+ :test #'string-equal :key #'car)))

(defun string->date (string &key (reference-date (todays-datetime)) (precedence :ymd))
  "Convert a string to a date-time if possible and return it. If parsing fails, NIL is returned.

If the date and time are not fully specified, the missing components are copied from the
given reference date (default = current system time). For example, given a string \"24 Feb\",
the year will be set to the current year and time to the current time.

Given ambiguous dates (month & day cannot be distinguished), 'precedence' is used to
assign the month/day correctly. For US-style dates, precedence should be specified as :mdy
and for UK style, it should be :dmy.

Some special strings such as 'today', 'tomorrow', 'next Wednesday' etc are also recognized."
  (setf string (string-downcase (string-trim +white-space+ string)))
  (unless (member precedence '(:ymd :dmy :mdy))
    (error "invalid precedence ~a" precedence))
  (macrolet ((when-null-set (var field value)
	       `(when (null (,field ,var)) (setf (,field ,var) ,value))))
    (let* ((res (make-date-components))
	   (tokens (tokenize string))
	   (num-tok (length tokens))
	   (skipped-tokens nil)		; tokens that were ignored
	   (relative-dow nil)		; when day of week is qualified by this/next/prev
	   (date-comps nil)		; uncertain whether day/month/year
	   (num-date-comps 0)		; length of date-comps + date components in res
	   (time-parsed nil))		; whether all of h/m/s have been parsed
      (do ((i 0 (1+ i)))
	  ((>= i num-tok))
	(let* ((token (elt tokens i))
	       (len (length token))
	       (next-tok (if (>= (1+ i) num-tok) nil (elt tokens (1+ i))))
	       (prev-tok (if (> i 0) (elt tokens (1- i)) nil))
	       (num (parse-number token))
	       tmp)
	  (when (numberp num)
	    (cond
	      ;; e.g. yyyymmddThhmmss or yyyymmddThh:mm:ss
	      ((and (= num-date-comps 3)
		    (or (= len 2) (= len 4) (= len 6))
		    prev-tok (string= prev-tok "t")
		    (null (find #\. token)))
	       ;; if colon separated time, only hour will be parsed
	       ;; cannot set time-parsed to T unless len > 2
	       (setf (dt-hr res) (parse-integer (subseq token 0 2)))
	       (when (>= len 4)
		 (setf (dt-min res) (parse-integer (subseq token 2 4))
		       time-parsed t))
	       (when (= len 6)
		 (setf (dt-sec res) (parse-integer (subseq token 4)))))
	      ;; YYMMDD or HHMMSS
	      ((or (= len 6)
		   (and (> len 7) (setf tmp (position #\. token)) (= tmp 6)))
	       (if (and (= 0 num-date-comps) (= len 6)
			(or (null prev-tok) (string/= prev-tok "t")))
		   ;; date if not yet parsed and not explicitly marked as time
		   (let* ((yy (truncate (/ num 10000)))
			  (mm (truncate (- (/ num 100) (* yy 100))))
			  (dd (truncate (- num (+ (* yy 10000) (* mm 100))))))
		     (setf date-comps (list dd mm yy)) ; reverse order of specification
		     (incf num-date-comps 3))
		   ;; time
		   (setf (dt-hr res) (parse-integer (subseq token 0 2))
			 (dt-min res) (parse-integer (subseq token 2 4))
			 (dt-sec res) (parse-number (subseq token 4))
			 time-parsed t)))
	      ;; YYYYMMDD - only format for 8 digit date (ddmmyyyy must be e.g. dd/mm/yyyy)
	      ((= len 8)
	       (when (find #\. token)
		 ;; nnnn.nnn
		 (return-from string->date nil))
	       (let* ((yy (truncate (/ num 10000)))
		      (mm (truncate (- (/ num 100) (* yy 100))))
		      (dd (truncate (- num (+ (* yy 10000) (* mm 100))))))
		 (setf (dt-yr res) yy (dt-mth res) mm (dt-day res) dd)
		 (incf num-date-comps 3)))
	      ;; YYYYMMDDHHMM[SS[.ss]]
	      ((or (= len 12) (= len 14)
		   (and (> len 15) (setf tmp (position #\. token)) (= tmp 14)))
	       (setf (dt-yr res) (parse-integer (subseq token 0 4))
		     (dt-mth res) (parse-integer (subseq token 4 6))
		     (dt-day res) (parse-integer (subseq token 6 8))
		     (dt-hr res) (parse-integer (subseq token 8 10))
		     (dt-min res) (parse-integer (subseq token 10 12)))
	       (incf num-date-comps 3)
	       (when (> len 12)
		 (setf (dt-sec res) (parse-number (subseq token 12))))
	       (setf time-parsed t))
	      ;; HH:MM:SS
	      ((or (and next-tok (string= next-tok ":"))
		   (and (not (null (dt-hr res))) prev-tok (string= prev-tok ":")))
	       ;; distinguish case when coming here from yyyymmddThh:mm:ss
	       (unless (and prev-tok (not time-parsed) (string= prev-tok ":"))
		 (setf (dt-hr res) num)
		 (incf i 2))		; advance pointer to minute
	       (setf num (parse-number (elt tokens i)))
	       (when (null num)
		 (return-from string->date nil))
	       ;; also handle weirdness like hh:mm.ss
	       (multiple-value-bind (int frac) (truncate num)
		 (setf (dt-min res) int)
		 (when (> frac 0)
		   (setf (dt-sec res) (* 60 frac))
		   (when (and (< (1+ i) num-tok) (string= (elt tokens (1+ i)) ":"))
		     ;; can't handle hh:mm.ss:wtf
		     (return-from string->date nil))))
	       (when (and (< (1+ i) num-tok) (string= (elt tokens (1+ i)) ":"))
		 (incf i 2)		; position on second
		 ;; both hh:mm:<eos> and hh:mm:ss are acceptable
		 (when (< i num-tok)
		   (setf num (parse-number (elt tokens i)))
		   (when (null num)
		     (return-from string->date nil))
		   (setf (dt-sec res) num))))
	      ;; dd/mm/yy and variants
	      ((and next-tok (member next-tok +date-separators+ :test #'string=))
	       (let ((sep next-tok)
		     (is-ymd nil))
		 (if (> num 31)
		     ;; year - default to yymmdd format
		     (setf (dt-yr res) num
			   is-ymd t)
		     (push num date-comps))
		 (incf num-date-comps)
		 (incf i 2)		; position on second component
		 (when (>= i num-tok)
		   ;; reject strings ending in trailing slash
		   (return-from string->date nil))
		 (setf num (parse-number (elt tokens i)))
		 (if (numberp num)
		     (cond ((and is-ymd (<= num 12)) (setf (dt-mth res) num))
			   (is-ymd (setf (dt-day res) num))
			   (t (push num date-comps)))
		     (progn
		       (setf tmp (str-to-month (elt tokens i)))
		       (if tmp
			   (setf (dt-mth res) tmp)
			   ;; not number or month name
			   (return-from string->date nil))))
		 (incf num-date-comps)
		 (when (and (< (1+ i) num-tok) (string= sep (elt tokens (1+ i))))
		   (incf i 2)		; position on last component
		   (when (>= i num-tok)
		     (return-from string->date nil)) ; trailing slash
		   (setf num (parse-number (elt tokens i)))
		   (when (null num)
		     ;; month name in last position is not accepted
		     (return-from string->date nil))
		   (cond ((and is-ymd (not (null (dt-day res)))) (setf (dt-mth res) num))
			 (is-ymd (setf (dt-day res) num))
			 (t (push num date-comps)))
		   (incf num-date-comps))))
	      ;; 2nd, 3rd, 21st etc. - parse as day
	      ((and next-tok (str-is-day-suffix next-tok))
	       (incf i)			; skip suffix
	       (setf (dt-day res) num)
	       (incf num-date-comps))
	      ;; 13h45m, 13h 45, etc - parse as time
	      ((and next-tok (setf tmp (str-to-hms next-tok)))
	       (loop
		;; consume following tokens as far as possible
		(multiple-value-bind (int frac) (truncate num)
		  (cond ((eq tmp :hour)
			 (setf (dt-hr res) int)
			 (when (> frac 0)
			   (setf (dt-min res) (* 60 frac))))
			((eq tmp :minute)
			 (setf (dt-min res) int)
			 (when (> frac 0)
			   (setf (dt-sec res) (* 60 frac))))
			((eq tmp :second)
			 (setf (dt-sec res) num
			       time-parsed t))))
		(incf i)		; pointer is on suffix
		(when (or (>= (1+ i) num-tok) (eq tmp :second))
		  (return))		; done
		(setf num (parse-number (elt tokens (1+ i))))
		(when (null num)
		  (return))
		(incf i)		; pointer on number after time suffix
		(if (or (>= (1+ i) num-tok)
			(null (str-to-hms (elt tokens (1+ i)))))
		    ;; no time suffix - set to min/sec based on what prev token was
		    (progn
		      (if (eq tmp :hour)
			  (multiple-value-bind (int frac) (truncate num)
			    (setf (dt-min res) int)
			    (when (> frac 0)
			      (setf (dt-sec res) (* 60 frac))))
			  (setf (dt-sec res) num))
		      (setf time-parsed t)
		      (return))
		    ;; set up var for next loop iteration
		    (setf tmp (str-to-hms (elt tokens (1+ i)))))))
	      ;; time with am/pm indicator e.g. 10 am
	      ((and next-tok (setf tmp (str-to-ampm next-tok)))
	       (when (> num 12)
		 (return-from string->date nil))
	       (multiple-value-bind (int frac) (truncate num)
		 (if (and (< int 12) (eq tmp :pm))
		     (incf int 12)
		     (when (and (= int 12) (eq tmp :am))
		       (setf int 0)))
		 (setf (dt-hr res) int)
		 (when (> frac 0)
		   ;; 10.37 pm - frac is minutes not fraction of hour
		   (setf (dt-min res) frac
			 time-parsed t))))
	      ;; all other numbers - assume it is a date component
	      (t (if (and prev-tok (string= prev-tok "of") (not (null (dt-mth res))))
		     ;; june of 1976
		     (setf (dt-yr res) num)
		     (push num date-comps))
		 (incf num-date-comps)))
	    ;; avoid giant if-then-else
	    (go end-of-do-loop))
	  ;; token is not a number
	  (cond
	    ;; weekday
	    ((setf tmp (str-to-weekday token)) (setf (dt-dow res) tmp))
	    ;; relative day of week
	    ((setf tmp (str-to-relative-dow token)) (setf relative-dow tmp))
	    ;; today / tomorrow etc
	    ((setf tmp (str-to-relative-date token))
	     (when (/= 0 num-date-comps)
	       (return-from string->date nil))
	     (multiple-value-bind (yy mm dd h m s) (date->ymd (+ reference-date tmp) :want-time t)
	       (setf (dt-yr res) yy
		     (dt-mth res) mm
		     (dt-day res) dd
		     num-date-comps 3)
	       (when-null-set res dt-hr h)
	       (when-null-set res dt-min m)
	       (when-null-set res dt-sec s)))
	    ;; am/pm
	    ((setf tmp (str-to-ampm token))
	     (let ((hr (dt-hr res)))
	       (when (null hr)
		 ;; am/pm not accepted before time string
		 (return-from string->date nil))
	       (if (and (= hr 12) (eq tmp :am))
		   (setf hr 0)
		   (when (and (< hr 12) (eq tmp :pm))
		     (incf hr 12)))
	       (setf (dt-hr res) hr)))
	    ;; time zone name
	    ((or (and (> (length token) 2) (setf tmp (str-to-tz-offset token)))
		 ;; military time zone spec valid only at end of string
		 (and (<= (length token) 2) (null next-tok) (setf tmp (str-to-tz-offset token))))
	     (when (null (dt-hr res))
	       (return-from string->date nil))
	     ;; if a time zone is specified as e.g. GMT+9 or JST-1,
	     ;; the next cond-clause for numeric offset will process it.
	     ;; offset is stored as fractions of a day since we add it to the julian date
	     (setf (dt-tz res) (/ tmp 24)))
	    ;; Numeric time zone offset: e.g., +0530 or +05:30 or -5
	    ;; also handles GMT+9 etc in conjunction with previous clause
	    ((and (or (string= token "+") (string= token "-"))
		  next-tok (not (null (parse-number next-tok))))
	     (when (null (dt-hr res))
	       (return-from string->date nil))
	     (let ((sign (if (string= token "+") 1 -1))
		   offset-hrs)
	       (incf i)			; position on number
	       (cond
		 ;; e.g. 5:30
		 ((and (< (1+ i) num-tok) (string= ":" (elt tokens (1+ i))))
		  (setf offset-hrs (/ (parse-integer next-tok) 24))
		  (incf i 2) 		; position on minutes
		  (if (or (>= i num-tok) (null (setf tmp (parse-number (elt tokens i)))))
		      (return-from string->date nil)
		      (incf offset-hrs (/ tmp 1440))))
		 ;; e.g., 3.5 or 11
		 ((or (not (null (position #\. next-tok))) (< (length next-tok) 3))
		  (setf offset-hrs (/ (parse-number next-tok) 24)))
		 ;; e.g., 0530
		 ((= 4 (length next-tok))
		  (setf offset-hrs (+ (/ (parse-integer (subseq next-tok 0 2)) 24)
				      (/ (parse-integer (subseq next-tok 2 4)) 1440))))
		 ;; e.g., 530
		 ((= 3 (length next-tok))
		  (setf offset-hrs (+ (/ (parse-integer (subseq next-tok 0 1)) 24)
				      (/ (parse-integer (subseq next-tok 1 3)) 1440))))
		 ;; all others are invalid
		 (t (return-from string->date nil)))
	       (setf offset-hrs (* sign offset-hrs))
	       (if (null (dt-tz res))
		   (setf (dt-tz res) offset-hrs)
		   (incf (dt-tz res) offset-hrs))))
	    ;; Alphabetic month name
	    ((setf tmp (str-to-month token))
	     (when (dt-mth res)
	       (return-from string->date nil)) ; duplicate spec
	     (setf (dt-mth res) tmp)
	     (incf num-date-comps)
	     (when (and next-tok (member next-tok +date-separators+ :test #'string=))
	       ;; Jul/23/1956
	       (let ((sep next-tok))
		 (incf i 2)		; point to second component
		 (when (< i num-tok)
		   (setf num (parse-number (elt tokens i)))
		   (when (null num)
		     (return-from string->date nil))
		   (incf num-date-comps)
		   (if (> num 31)
		       (setf (dt-yr res) num) ; clearly a year
		       (push num date-comps))
		   (when (and (< (1+ i) num-tok) (string= sep (elt tokens (1+ i))))
		     (incf i 2) 	; point to third component
		     (setf num (parse-number (elt tokens i)))
		     (when (null num)
		       (return-from string->date nil))
		     (incf num-date-comps)
		     (if (> num 31)
			 (if (dt-yr res)
			     ;; Jul/99/1985
			     (return-from string->date nil)
			     ;; unambiguous date
			     (setf (dt-yr res) num
				   (dt-day res) (pop date-comps)))
			 (if (dt-yr res)
			     (setf (dt-day res) num)
			     (push num date-comps))))))))
	    ;; default - skip token
	    (t (push token skipped-tokens))))
       end-of-do-loop)
      (when (> num-date-comps 3)
	(return-from string->date nil))
      (when (and (= num-date-comps 0) (dt-dow res)
		 (null relative-dow))
	;; day of week without date is relative to reference date
	(setf relative-dow :closest))
      (when date-comps
	(setf date-comps (nreverse date-comps)) ; order of appearance
	(let ((len (length date-comps)))
	  (cond ((or (= 3 num-date-comps len)
		     (= 2 num-date-comps len)) ; all uncertain
		 (multiple-value-bind (yy mm dd) (assign-yy-mm-dd date-comps precedence)
		   (setf (dt-yr res) yy (dt-mth res) mm (dt-day res) dd)))
		((and (= 3 num-date-comps) (= 2 len)) ; 2 of 3 are not certain
		 (cond ((dt-day res) (multiple-value-bind (yy mm) (assign-yy-mm date-comps precedence)
				       (setf (dt-yr res) yy (dt-mth res) mm)))
		       ((dt-mth res) (multiple-value-bind (yy dd) (assign-yy-dd date-comps precedence)
				       (setf (dt-yr res) yy (dt-day res) dd)))
		       ((dt-yr res) (multiple-value-bind (mm dd) (assign-mm-dd date-comps precedence)
				      (setf (dt-mth res) mm (dt-day res) dd)))))
		((and (= 3 num-date-comps) (= 1 len)) ; assign to null memeber in res
		 (when-null-set res dt-yr (car date-comps))
		 (when-null-set res dt-mth (car date-comps))
		 (when-null-set res dt-day (car date-comps)))
		((and (= 2 num-date-comps) (= 1 len))
		 (cond ((dt-yr res) ;; dd or mm
			(cond ((> (car date-comps) 12) (setf (dt-day res) (car date-comps)))
			      ((eq precedence :dmy) (setf (dt-day res) (car date-comps)))
			      (t (setf (dt-mth res) (car date-comps)))))
		       ((dt-mth res) ;; dd or yy
			(if (> (car date-comps) 31)
			    (setf (dt-yr res) (car date-comps))
			    (setf (dt-day res) (car date-comps))))
		       ((dt-day res) ;; mm or yy
			(if (> (car date-comps) 12)
			    (setf (dt-yr res) (car date-comps))
			    (setf (dt-mth res) (car date-comps))))))
		(t ;; i.e., num-date-comps = 1 so one of dd or mm or yy
		 (cond ((> (car date-comps) 31) (setf (dt-yr res) (car date-comps)))
		       ((<= (car date-comps) 12) (setf (dt-mth res) (car date-comps)))
		       (t ;; between 12 and 31
			(setf (dt-day res) (car date-comps))))))))
      ;; check that we could assign all date components
      (when (/= num-date-comps (+ (if (dt-yr res) 1 0) (if (dt-mth res) 1 0) (if (dt-day res) 1 0)))
	;; duplicate day / mth / year
	(return-from string->date nil))
      ;; handle two-digit years
      (when (dt-yr res)
	(setf (dt-yr res) (make-four-digit-year (dt-yr res))))
      ;; copy all missing values from the reference date
      (multiple-value-bind (yy mm dd h m s) (date->ymd reference-date :want-time t)
	(when-null-set res dt-yr yy)
	(when-null-set res dt-mth mm)
	(when-null-set res dt-day dd)
	(when-null-set res dt-hr h)
	(when-null-set res dt-min m)
	(when-null-set res dt-sec s))
      (unless (and (valid-date-p (dt-yr res) (dt-mth res) (dt-day res))
		   (valid-time-p (dt-hr res) (dt-min res) (dt-sec res)))
	(return-from string->date nil))
      (let ((dt (ymd->date (dt-yr res) (dt-mth res) (dt-day res)
			    (dt-hr res) (dt-min res) (dt-sec res))))
	(if (and relative-dow (dt-dow res))
	    (setf dt (advance-date dt (dt-dow res) relative-dow))
	    (when (dt-dow res)
	      (when (and (= 3 num-date-comps) (not (eq (dt-dow res) (day-of-week dt))))
		;; date was misparsed or day of week is not consistent with date
		(return-from string->date nil))))
	(when (dt-tz res)
	  ;; +ve offset = subtract, -ve offset = add
	  (decf dt (dt-tz res)))
	(values dt skipped-tokens)))))