calc-forms.el 66.1 KB
Newer Older
1 2
;;; calc-forms.el --- data format conversion functions for Calc

3
;; Copyright (C) 1990-1993, 2001-2012 Free Software Foundation, Inc.
4 5

;; Author: David Gillespie <daveg@synaptics.com>
Jay Belanger's avatar
Jay Belanger committed
6
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
Eli Zaretskii's avatar
Eli Zaretskii committed
7 8 9

;; This file is part of GNU Emacs.

10
;; GNU Emacs is free software: you can redistribute it and/or modify
11
;; it under the terms of the GNU General Public License as published by
12 13
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
14

Eli Zaretskii's avatar
Eli Zaretskii committed
15
;; GNU Emacs is distributed in the hope that it will be useful,
16 17 18 19 20
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
21
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Eli Zaretskii's avatar
Eli Zaretskii committed
22

23
;;; Commentary:
Eli Zaretskii's avatar
Eli Zaretskii committed
24

25
;;; Code:
Eli Zaretskii's avatar
Eli Zaretskii committed
26 27 28

;; This file is autoloaded from calc-ext.el.

Jay Belanger's avatar
Jay Belanger committed
29
(require 'calc-ext)
Eli Zaretskii's avatar
Eli Zaretskii committed
30 31
(require 'calc-macs)

Jay Belanger's avatar
Jay Belanger committed
32 33 34 35 36 37
;; Declare functions which are defined elsewhere.
(declare-function calendar-current-time-zone "cal-dst" ())
(declare-function calendar-absolute-from-gregorian "calendar" (date))
(declare-function dst-in-effect "cal-dst" (date))


Eli Zaretskii's avatar
Eli Zaretskii committed
38 39 40 41 42 43 44
(defun calc-time ()
  (interactive)
  (calc-wrapper
   (let ((time (current-time-string)))
     (calc-enter-result 0 "time"
			(list 'mod
			      (list 'hms
45 46 47
				    (string-to-number (substring time 11 13))
				    (string-to-number (substring time 14 16))
				    (string-to-number (substring time 17 19)))
48
			      (list 'hms 24 0 0))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
49 50 51 52 53 54 55 56

(defun calc-to-hms (arg)
  (interactive "P")
  (calc-wrapper
   (if (calc-is-inverse)
       (if (eq calc-angle-mode 'rad)
	   (calc-unary-op ">rad" 'calcFunc-rad arg)
	 (calc-unary-op ">deg" 'calcFunc-deg arg))
57
     (calc-unary-op ">hms" 'calcFunc-hms arg))))
Eli Zaretskii's avatar
Eli Zaretskii committed
58 59 60 61

(defun calc-from-hms (arg)
  (interactive "P")
  (calc-invert-func)
62
  (calc-to-hms arg))
Eli Zaretskii's avatar
Eli Zaretskii committed
63 64 65 66 67 68 69 70 71 72 73 74 75 76 77


(defun calc-hms-notation (fmt)
  (interactive "sHours-minutes-seconds format (hms, @ ' \", etc.): ")
  (calc-wrapper
   (if (string-match "\\`\\([^,; ]+\\)\\([,; ]*\\)\\([^,; ]\\)\\([,; ]*\\)\\([^,; ]\\)\\'" fmt)
       (progn
	 (calc-change-mode 'calc-hms-format
			   (concat "%s" (math-match-substring fmt 1)
				   (math-match-substring fmt 2)
				   "%s" (math-match-substring fmt 3)
				   (math-match-substring fmt 4)
				   "%s" (math-match-substring fmt 5))
			   t)
	 (setq-default calc-hms-format calc-hms-format))  ; for minibuffer
78
     (error "Bad hours-minutes-seconds format"))))
Eli Zaretskii's avatar
Eli Zaretskii committed
79 80 81 82

(defun calc-date-notation (fmt arg)
  (interactive "sDate format (e.g., M/D/YY h:mm:ss): \nP")
  (calc-wrapper
83
   (if (string-match-p "\\`\\s-*\\'" fmt)
Eli Zaretskii's avatar
Eli Zaretskii committed
84 85
       (setq fmt "1"))
   (if (string-match "\\` *[0-9] *\\'" fmt)
86
       (setq fmt (nth (string-to-number fmt) calc-standard-date-formats)))
Eli Zaretskii's avatar
Eli Zaretskii committed
87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155
   (or (string-match "[a-zA-Z]" fmt)
       (error "Bad date format specifier"))
   (and arg
	(>= (setq arg (prefix-numeric-value arg)) 0)
	(<= arg 9)
	(setq calc-standard-date-formats
	      (copy-sequence calc-standard-date-formats))
	(setcar (nthcdr arg calc-standard-date-formats) fmt))
   (let ((case-fold-search nil))
     (and (not (string-match "<.*>" fmt))
	  (string-match "\\`[^hHspP]*\\([^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*[bBhHmpPsS]+[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*\\)[^hHspP]*\\'" fmt)
	  (string-match (concat "[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*"
				(regexp-quote (math-match-substring fmt 1))
				"[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*") fmt)
	  (setq fmt (concat (substring fmt 0 (match-beginning 0))
			    "<"
			    (substring fmt (match-beginning 0) (match-end 0))
			    ">"
			    (substring fmt (match-end 0))))))
   (let ((lfmt nil)
	 (fullfmt nil)
	 (time nil)
	 pos pos2 sym temp)
     (let ((case-fold-search nil))
       (and (setq temp (string-match ":[BS]S" fmt))
	    (aset fmt temp ?C)))
     (while (setq pos (string-match "[<>a-zA-Z]" fmt))
       (if (> pos 0)
	   (setq lfmt (cons (substring fmt 0 pos) lfmt)))
       (setq pos2 (1+ pos))
       (cond ((= (aref fmt pos) ?\<)
	      (and time (error "Nested <'s not allowed"))
	      (and lfmt (setq fullfmt (nconc lfmt fullfmt)
			      lfmt nil))
	      (setq time t))
	     ((= (aref fmt pos) ?\>)
	      (or time (error "Misplaced > in format"))
	      (and lfmt (setq fullfmt (cons (nreverse lfmt) fullfmt)
			      lfmt nil))
	      (setq time nil))
	     (t
	      (if (string-match "\\`[^a-zA-Z]*[bB][a-zA-Z]" fmt)
		  (setq pos2 (1+ pos2)))
	      (while (and (< pos2 (length fmt))
			  (= (upcase (aref fmt pos2))
			     (upcase (aref fmt (1- pos2)))))
		(setq pos2 (1+ pos2)))
	      (setq sym (intern (substring fmt pos pos2)))
	      (or (memq sym '(Y YY BY YYY YYYY
				aa AA aaa AAA aaaa AAAA
				bb BB bbb BBB bbbb BBBB
				M MM BM mmm Mmm Mmmm MMM MMMM
				D DD BD d ddd bdd
				W www Www Wwww WWW WWWW
				h hh bh H HH BH
				p P pp PP pppp PPPP
				m mm bm s ss bss SS BS C
				N n J j U b))
		  (and (eq sym 'X) (not lfmt) (not fullfmt))
		  (error "Bad format code: %s" sym))
	      (and (memq sym '(bb BB bbb BBB bbbb BBBB))
		   (setq lfmt (cons 'b lfmt)))
	      (setq lfmt (cons sym lfmt))))
       (setq fmt (substring fmt pos2)))
     (or (equal fmt "")
	 (setq lfmt (cons fmt lfmt)))
     (and lfmt (if time
		   (setq fullfmt (cons (nreverse lfmt) fullfmt))
		 (setq fullfmt (nconc lfmt fullfmt))))
156
     (calc-change-mode 'calc-date-format (nreverse fullfmt) t))))
Eli Zaretskii's avatar
Eli Zaretskii committed
157 158 159 160 161 162


(defun calc-hms-mode ()
  (interactive)
  (calc-wrapper
   (calc-change-mode 'calc-angle-mode 'hms)
163
   (message "Angles measured in degrees-minutes-seconds")))
Eli Zaretskii's avatar
Eli Zaretskii committed
164 165 166 167


(defun calc-now (arg)
  (interactive "P")
168
  (calc-date-zero-args "now" 'calcFunc-now arg))
Eli Zaretskii's avatar
Eli Zaretskii committed
169 170 171 172 173 174 175 176 177 178 179 180 181 182

(defun calc-date-part (arg)
  (interactive "NPart code (1-9 = Y,M,D,H,M,S,Wd,Yd,Hms): ")
  (if (or (< arg 1) (> arg 9))
      (error "Part code out of range"))
  (calc-wrapper
   (calc-enter-result 1
		      (nth arg '(nil "year" "mnth" "day" "hour" "minu"
				      "sec" "wday" "yday" "hmst"))
		      (list (nth arg '(nil calcFunc-year calcFunc-month
					   calcFunc-day calcFunc-hour
					   calcFunc-minute calcFunc-second
					   calcFunc-weekday calcFunc-yearday
					   calcFunc-time))
183
			    (calc-top-n 1)))))
Eli Zaretskii's avatar
Eli Zaretskii committed
184 185 186 187 188 189

(defun calc-date (arg)
  (interactive "p")
  (if (or (< arg 1) (> arg 6))
      (error "Between one and six arguments are allowed"))
  (calc-wrapper
190
   (calc-enter-result arg "date" (cons 'calcFunc-date (calc-top-list-n arg)))))
Eli Zaretskii's avatar
Eli Zaretskii committed
191 192 193

(defun calc-julian (arg)
  (interactive "P")
194
  (calc-date-one-arg "juln" 'calcFunc-julian arg))
Eli Zaretskii's avatar
Eli Zaretskii committed
195 196 197

(defun calc-unix-time (arg)
  (interactive "P")
198
  (calc-date-one-arg "unix" 'calcFunc-unixtime arg))
Eli Zaretskii's avatar
Eli Zaretskii committed
199 200 201

(defun calc-time-zone (arg)
  (interactive "P")
202
  (calc-date-zero-args "zone" 'calcFunc-tzone arg))
Eli Zaretskii's avatar
Eli Zaretskii committed
203 204 205 206 207 208 209 210 211 212 213 214

(defun calc-convert-time-zones (old &optional new)
  (interactive "sFrom time zone: ")
  (calc-wrapper
   (if (equal old "$")
       (calc-enter-result 3 "tzcv" (cons 'calcFunc-tzconv (calc-top-list-n 3)))
     (if (equal old "") (setq old "local"))
     (or new
	 (setq new (read-string (concat "From time zone: " old
					", to zone: "))))
     (if (stringp old) (setq old (math-read-expr old)))
     (if (eq (car-safe old) 'error)
215
	 (error "Error in expression: %S" (nth 1 old)))
Eli Zaretskii's avatar
Eli Zaretskii committed
216 217 218
     (if (equal new "") (setq new "local"))
     (if (stringp new) (setq new (math-read-expr new)))
     (if (eq (car-safe new) 'error)
219
	 (error "Error in expression: %S" (nth 1 new)))
Eli Zaretskii's avatar
Eli Zaretskii committed
220
     (calc-enter-result 1 "tzcv" (list 'calcFunc-tzconv
221
				       (calc-top-n 1) old new)))))
Eli Zaretskii's avatar
Eli Zaretskii committed
222 223 224

(defun calc-new-week (arg)
  (interactive "P")
225
  (calc-date-one-arg "nwwk" 'calcFunc-newweek arg))
Eli Zaretskii's avatar
Eli Zaretskii committed
226 227 228

(defun calc-new-month (arg)
  (interactive "P")
229
  (calc-date-one-arg "nwmn" 'calcFunc-newmonth arg))
Eli Zaretskii's avatar
Eli Zaretskii committed
230 231 232

(defun calc-new-year (arg)
  (interactive "P")
233
  (calc-date-one-arg "nwyr" 'calcFunc-newyear arg))
Eli Zaretskii's avatar
Eli Zaretskii committed
234 235 236

(defun calc-inc-month (arg)
  (interactive "p")
237
  (calc-date-one-arg "incm" 'calcFunc-incmonth arg))
Eli Zaretskii's avatar
Eli Zaretskii committed
238 239 240 241

(defun calc-business-days-plus (arg)
  (interactive "P")
  (calc-wrapper
242
   (calc-binary-op "bus+" 'calcFunc-badd arg)))
Eli Zaretskii's avatar
Eli Zaretskii committed
243 244 245 246

(defun calc-business-days-minus (arg)
  (interactive "P")
  (calc-wrapper
247
   (calc-binary-op "bus-" 'calcFunc-bsub arg)))
Eli Zaretskii's avatar
Eli Zaretskii committed
248 249 250 251 252 253 254

(defun calc-date-zero-args (prefix func arg)
  (calc-wrapper
   (if (consp arg)
       (calc-enter-result 1 prefix (list func (calc-top-n 1)))
     (calc-enter-result 0 prefix (if arg
				     (list func (prefix-numeric-value arg))
255
				   (list func))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
256 257 258 259 260 261 262 263

(defun calc-date-one-arg (prefix func arg)
  (calc-wrapper
   (if (consp arg)
       (calc-enter-result 2 prefix (cons func (calc-top-list-n 2)))
     (calc-enter-result 1 prefix (if arg
				     (list func (calc-top-n 1)
					   (prefix-numeric-value arg))
264
				   (list func (calc-top-n 1)))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303


;;;; Hours-minutes-seconds forms.

(defun math-normalize-hms (a)
  (let ((h (math-normalize (nth 1 a)))
	(m (math-normalize (nth 2 a)))
	(s (let ((calc-internal-prec (max (- calc-internal-prec 4) 3)))
	     (math-normalize (nth 3 a)))))
    (if (math-negp h)
	(progn
	  (if (math-posp s)
	      (setq s (math-add s -60)
		    m (math-add m 1)))
	  (if (math-posp m)
	      (setq m (math-add m -60)
		    h (math-add h 1)))
	  (if (not (Math-lessp -60 s))
	      (setq s (math-add s 60)
		    m (math-add m -1)))
	  (if (not (Math-lessp -60 m))
	      (setq m (math-add m 60)
		    h (math-add h -1))))
      (if (math-negp s)
	  (setq s (math-add s 60)
		m (math-add m -1)))
      (if (math-negp m)
	  (setq m (math-add m 60)
		h (math-add h -1)))
      (if (not (Math-lessp s 60))
	  (setq s (math-add s -60)
		m (math-add m 1)))
      (if (not (Math-lessp m 60))
	  (setq m (math-add m -60)
		h (math-add h 1))))
    (if (and (eq (car-safe s) 'float)
	     (<= (+ (math-numdigs (nth 1 s)) (nth 2 s))
		 (- 2 calc-internal-prec)))
	(setq s 0))
304
    (list 'hms h m s)))
Eli Zaretskii's avatar
Eli Zaretskii committed
305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328

;;; Convert A from ANG or current angular mode to HMS format.
(defun math-to-hms (a &optional ang)   ; [X R] [Public]
  (cond ((eq (car-safe a) 'hms) a)
	((eq (car-safe a) 'sdev)
	 (math-make-sdev (math-to-hms (nth 1 a))
			 (math-to-hms (nth 2 a))))
	((not (Math-numberp a))
	 (list 'calcFunc-hms a))
	((math-negp a)
	 (math-neg (math-to-hms (math-neg a) ang)))
	((eq (or ang calc-angle-mode) 'rad)
	 (math-to-hms (math-div a (math-pi-over-180)) 'deg))
	((memq (car-safe a) '(cplx polar)) a)
	(t
	 ;(setq a (let ((calc-internal-prec (max (1- calc-internal-prec) 3)))
	 ;	    (math-normalize a)))
	 (math-normalize
	  (let* ((b (math-mul a 3600))
		 (hm (math-trunc (math-div b 60)))
		 (hmd (math-idivmod hm 60)))
	    (list 'hms
		  (car hmd)
		  (cdr hmd)
329
		  (math-sub b (math-mul hm 60))))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
330 331 332 333 334 335 336 337 338 339 340 341 342
(defun calcFunc-hms (h &optional m s)
  (or (Math-realp h) (math-reject-arg h 'realp))
  (or m (setq m 0))
  (or (Math-realp m) (math-reject-arg m 'realp))
  (or s (setq s 0))
  (or (Math-realp s) (math-reject-arg s 'realp))
  (if (and (not (Math-lessp m 0)) (Math-lessp m 60)
	   (not (Math-lessp s 0)) (Math-lessp s 60))
      (math-add (math-to-hms h)
		(list 'hms 0 m s))
    (math-to-hms (math-add h
			   (math-add (math-div (or m 0) 60)
				     (math-div (or s 0) 3600)))
343
		 'deg)))
Eli Zaretskii's avatar
Eli Zaretskii committed
344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364

;;; Convert A from HMS format to ANG or current angular mode.
(defun math-from-hms (a &optional ang)   ; [R X] [Public]
  (cond ((not (eq (car-safe a) 'hms))
	 (if (Math-numberp a)
	     a
	   (if (eq (car-safe a) 'sdev)
	       (math-make-sdev (math-from-hms (nth 1 a) ang)
			       (math-from-hms (nth 2 a) ang))
	     (if (eq (or ang calc-angle-mode) 'rad)
		 (list 'calcFunc-rad a)
	       (list 'calcFunc-deg a)))))
	((math-negp a)
	 (math-neg (math-from-hms (math-neg a) ang)))
	((eq (or ang calc-angle-mode) 'rad)
	 (math-mul (math-from-hms a 'deg) (math-pi-over-180)))
	(t
	 (math-add (math-div (math-add (math-div (nth 3 a)
						 '(float 6 1))
				       (nth 2 a))
			     60)
365
		   (nth 1 a)))))
Eli Zaretskii's avatar
Eli Zaretskii committed
366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414

;;;; Date forms.


;;; Some of these functions are adapted from Edward Reingold's "calendar.el".
;;; These versions are rewritten to use arbitrary-size integers.
;;; The Julian calendar is used up to 9/2/1752, after which the Gregorian
;;; calendar is used; the first day after 9/2/1752 is 9/14/1752.

;;; A numerical date is the number of days since midnight on
;;; the morning of January 1, 1 A.D.  If the date is a non-integer,
;;; it represents a specific date and time.
;;; A "dt" is a list of the form, (year month day), corresponding to
;;; an integer code, or (year month day hour minute second), corresponding
;;; to a non-integer code.

(defun math-date-to-dt (value)
  (if (eq (car-safe value) 'date)
      (setq value (nth 1 value)))
  (or (math-realp value)
      (math-reject-arg value 'datep))
  (let* ((parts (math-date-parts value))
	 (date (car parts))
	 (time (nth 1 parts))
	 (month 1)
	 day
	 (year (math-quotient (math-add date (if (Math-lessp date 711859)
						 365  ; for speed, we take
					       -108)) ; >1950 as a special case
			      (if (math-negp value) 366 365)))
					; this result may be an overestimate
	 temp)
    (while (Math-lessp date (setq temp (math-absolute-from-date year 1 1)))
      (setq year (math-add year -1)))
    (if (eq year 0) (setq year -1))
    (setq date (1+ (math-sub date temp)))
    (and (eq year 1752) (>= date 247)
	 (setq date (+ date 11)))
    (setq temp (if (math-leap-year-p year)
		   [1 32 61 92 122 153 183 214 245 275 306 336 999]
		 [1 32 60 91 121 152 182 213 244 274 305 335 999]))
    (while (>= date (aref temp month))
      (setq month (1+ month)))
    (setq day (1+ (- date (aref temp (1- month)))))
    (if (math-integerp value)
	(list year month day)
      (list year month day
	    (/ time 3600)
	    (% (/ time 60) 60)
415
	    (math-add (% time 60) (nth 2 parts))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432

(defun math-dt-to-date (dt)
  (or (integerp (nth 1 dt))
      (math-reject-arg (nth 1 dt) 'fixnump))
  (if (or (< (nth 1 dt) 1) (> (nth 1 dt) 12))
      (math-reject-arg (nth 1 dt) "Month value is out of range"))
  (or (integerp (nth 2 dt))
      (math-reject-arg (nth 2 dt) 'fixnump))
  (if (or (< (nth 2 dt) 1) (> (nth 2 dt) 31))
      (math-reject-arg (nth 2 dt) "Day value is out of range"))
  (let ((date (math-absolute-from-date (car dt) (nth 1 dt) (nth 2 dt))))
    (if (nth 3 dt)
	(math-add (math-float date)
		  (math-div (math-add (+ (* (nth 3 dt) 3600)
					 (* (nth 4 dt) 60))
				      (nth 5 dt))
			    '(float 864 2)))
433
      date)))
Eli Zaretskii's avatar
Eli Zaretskii committed
434 435 436 437 438 439 440 441 442

(defun math-date-parts (value &optional offset)
  (let* ((date (math-floor value))
	 (time (math-round (math-mul (math-sub value (or offset date)) 86400)
			   (and (> calc-internal-prec 12)
				(- calc-internal-prec 12))))
	 (ftime (math-floor time)))
    (list date
	  ftime
443
	  (math-sub time ftime))))
Eli Zaretskii's avatar
Eli Zaretskii committed
444 445 446


(defun math-this-year ()
Paul Eggert's avatar
Paul Eggert committed
447
  (nth 5 (decode-time)))
Eli Zaretskii's avatar
Eli Zaretskii committed
448 449 450 451 452 453 454 455

(defun math-leap-year-p (year)
  (if (Math-lessp year 1752)
      (if (math-negp year)
	  (= (math-imod (math-neg year) 4) 1)
	(= (math-imod year 4) 0))
    (setq year (math-imod year 400))
    (or (and (= (% year 4) 0) (/= (% year 100) 0))
456
	(= year 0))))
Eli Zaretskii's avatar
Eli Zaretskii committed
457 458 459 460

(defun math-days-in-month (year month)
  (if (and (= month 2) (math-leap-year-p year))
      29
461
    (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
Eli Zaretskii's avatar
Eli Zaretskii committed
462 463 464 465 466 467 468 469 470 471 472 473

(defun math-day-number (year month day)
  (let ((day-of-year (+ day (* 31 (1- month)))))
    (if (> month 2)
	(progn
	  (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
	  (if (math-leap-year-p year)
	      (setq day-of-year (1+ day-of-year)))))
    (and (eq year 1752)
	 (or (> month 9)
	     (and (= month 9) (>= day 14)))
	 (setq day-of-year (- day-of-year 11)))
474
    day-of-year))
Eli Zaretskii's avatar
Eli Zaretskii committed
475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493

(defun math-absolute-from-date (year month day)
  (if (eq year 0) (setq year -1))
  (let ((yearm1 (math-sub year 1)))
    (math-sub (math-add (math-day-number year month day)
			(math-add (math-mul 365 yearm1)
				  (if (math-posp year)
				      (math-quotient yearm1 4)
				    (math-sub 365
					      (math-quotient (math-sub 3 year)
							     4)))))
	      (if (or (Math-lessp year 1753)
		      (and (eq year 1752) (<= month 9)))
		  1
		(let ((correction (math-mul (math-quotient yearm1 100) 3)))
		  (let ((res (math-idivmod correction 4)))
		    (math-add (if (= (cdr res) 0)
				  -1
				0)
494
			      (car res))))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511


;;; It is safe to redefine these in your .emacs file to use a different
;;; language.

(defvar math-long-weekday-names '( "Sunday" "Monday" "Tuesday" "Wednesday"
				   "Thursday" "Friday" "Saturday" ))
(defvar math-short-weekday-names '( "Sun" "Mon" "Tue" "Wed"
				    "Thu" "Fri" "Sat" ))

(defvar math-long-month-names '( "January" "February" "March" "April"
				 "May" "June" "July" "August"
				 "September" "October" "November" "December" ))
(defvar math-short-month-names '( "Jan" "Feb" "Mar" "Apr" "May" "Jun"
				  "Jul" "Aug" "Sep" "Oct" "Nov" "Dec" ))


512
(defvar math-format-date-cache nil)
513

Kim F. Storm's avatar
Kim F. Storm committed
514
;; The variables math-fd-date, math-fd-dt, math-fd-year,
515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533
;; math-fd-month, math-fd-day, math-fd-weekday, math-fd-hour,
;; math-fd-minute, math-fd-second, math-fd-bc-flag are local
;; to math-format-date, but are used by math-format-date-part,
;; which is called by math-format-date.
(defvar math-fd-date)
(defvar math-fd-dt)
(defvar math-fd-year)
(defvar math-fd-month)
(defvar math-fd-day)
(defvar math-fd-weekday)
(defvar math-fd-hour)
(defvar math-fd-minute)
(defvar math-fd-second)
(defvar math-fd-bc-flag)

(defun math-format-date (math-fd-date)
  (if (eq (car-safe math-fd-date) 'date)
      (setq math-fd-date (nth 1 math-fd-date)))
  (let ((entry (list math-fd-date calc-internal-prec calc-date-format)))
Eli Zaretskii's avatar
Eli Zaretskii committed
534
    (or (cdr (assoc entry math-format-date-cache))
535
	(let* ((math-fd-dt nil)
Eli Zaretskii's avatar
Eli Zaretskii committed
536 537 538
	       (calc-group-digits nil)
	       (calc-leading-zeros nil)
	       (calc-number-radix 10)
Jay Belanger's avatar
Jay Belanger committed
539
               (calc-twos-complement-mode nil)
Kim F. Storm's avatar
Kim F. Storm committed
540
	       math-fd-year math-fd-month math-fd-day math-fd-weekday
541 542
               math-fd-hour math-fd-minute math-fd-second
	       (math-fd-bc-flag nil)
Eli Zaretskii's avatar
Eli Zaretskii committed
543 544 545 546
	       (fmt (apply 'concat (mapcar 'math-format-date-part
					   calc-date-format))))
	  (setq math-format-date-cache (cons (cons entry fmt)
					     math-format-date-cache))
547 548
	  (and (setq math-fd-dt (nthcdr 10 math-format-date-cache))
	       (setcdr math-fd-dt nil))
549
	  fmt))))
Eli Zaretskii's avatar
Eli Zaretskii committed
550

551 552 553 554 555 556 557 558
(defconst math-julian-date-beginning '(float 17214235 -1)
  "The beginning of the Julian calendar,
as measured in the number of days before January 1 of the year 1AD.")

(defconst math-julian-date-beginning-int 1721424
  "The beginning of the Julian calendar,
as measured in the integer number of days before January 1 of the year 1AD.")

Eli Zaretskii's avatar
Eli Zaretskii committed
559 560 561 562
(defun math-format-date-part (x)
  (cond ((stringp x)
	 x)
	((listp x)
563
	 (if (math-integerp math-fd-date)
Eli Zaretskii's avatar
Eli Zaretskii committed
564 565 566 567 568
	     ""
	   (apply 'concat (mapcar 'math-format-date-part x))))
	((eq x 'X)
	 "")
	((eq x 'N)
569
	 (math-format-number math-fd-date))
Eli Zaretskii's avatar
Eli Zaretskii committed
570
	((eq x 'n)
571
	 (math-format-number (math-floor math-fd-date)))
Eli Zaretskii's avatar
Eli Zaretskii committed
572
	((eq x 'J)
573
	 (math-format-number 
574
          (math-add math-fd-date math-julian-date-beginning)))
Eli Zaretskii's avatar
Eli Zaretskii committed
575
	((eq x 'j)
576 577
	 (math-format-number (math-add 
                              (math-floor math-fd-date) 
578
                              math-julian-date-beginning-int)))
Eli Zaretskii's avatar
Eli Zaretskii committed
579
	((eq x 'U)
580
	 (math-format-number (nth 1 (math-date-parts math-fd-date 719164))))
Eli Zaretskii's avatar
Eli Zaretskii committed
581
	((progn
582
	   (or math-fd-dt
Eli Zaretskii's avatar
Eli Zaretskii committed
583
	       (progn
584 585 586 587
		 (setq math-fd-dt (math-date-to-dt math-fd-date)
		       math-fd-year (car math-fd-dt)
		       math-fd-month (nth 1 math-fd-dt)
		       math-fd-day (nth 2 math-fd-dt)
Kim F. Storm's avatar
Kim F. Storm committed
588
		       math-fd-weekday (math-mod
589 590 591 592
                                        (math-add (math-floor math-fd-date) 6) 7)
		       math-fd-hour (nth 3 math-fd-dt)
		       math-fd-minute (nth 4 math-fd-dt)
		       math-fd-second (nth 5 math-fd-dt))
Eli Zaretskii's avatar
Eli Zaretskii committed
593
		 (and (memq 'b calc-date-format)
594 595 596
		      (math-negp math-fd-year)
		      (setq math-fd-year (math-neg math-fd-year)
			    math-fd-bc-flag t))))
Eli Zaretskii's avatar
Eli Zaretskii committed
597
	   (memq x '(Y YY BY)))
598
	 (if (and (integerp math-fd-year) (> math-fd-year 1940) (< math-fd-year 2040))
Eli Zaretskii's avatar
Eli Zaretskii committed
599 600 601
	     (format (cond ((eq x 'YY) "%02d")
			   ((eq x 'BYY) "%2d")
			   (t "%d"))
602 603 604 605
		     (% math-fd-year 100))
	   (if (and (natnump math-fd-year) (< math-fd-year 100))
	       (format "+%d" math-fd-year)
	     (math-format-number math-fd-year))))
Eli Zaretskii's avatar
Eli Zaretskii committed
606
	((eq x 'YYY)
607
	 (math-format-number math-fd-year))
Eli Zaretskii's avatar
Eli Zaretskii committed
608
	((eq x 'YYYY)
609 610 611
	 (if (and (natnump math-fd-year) (< math-fd-year 100))
	     (format "+%d" math-fd-year)
	   (math-format-number math-fd-year)))
Eli Zaretskii's avatar
Eli Zaretskii committed
612 613
	((eq x 'b) "")
	((eq x 'aa)
614
	 (and (not math-fd-bc-flag) "ad"))
Eli Zaretskii's avatar
Eli Zaretskii committed
615
	((eq x 'AA)
616
	 (and (not math-fd-bc-flag) "AD"))
Eli Zaretskii's avatar
Eli Zaretskii committed
617
	((eq x 'aaa)
618
	 (and (not math-fd-bc-flag) "ad "))
Eli Zaretskii's avatar
Eli Zaretskii committed
619
	((eq x 'AAA)
620
	 (and (not math-fd-bc-flag) "AD "))
Eli Zaretskii's avatar
Eli Zaretskii committed
621
	((eq x 'aaaa)
622
	 (and (not math-fd-bc-flag) "a.d."))
Eli Zaretskii's avatar
Eli Zaretskii committed
623
	((eq x 'AAAA)
624
	 (and (not math-fd-bc-flag) "A.D."))
Eli Zaretskii's avatar
Eli Zaretskii committed
625
	((eq x 'bb)
626
	 (and math-fd-bc-flag "bc"))
Eli Zaretskii's avatar
Eli Zaretskii committed
627
	((eq x 'BB)
628
	 (and math-fd-bc-flag "BC"))
Eli Zaretskii's avatar
Eli Zaretskii committed
629
	((eq x 'bbb)
630
	 (and math-fd-bc-flag " bc"))
Eli Zaretskii's avatar
Eli Zaretskii committed
631
	((eq x 'BBB)
632
	 (and math-fd-bc-flag " BC"))
Eli Zaretskii's avatar
Eli Zaretskii committed
633
	((eq x 'bbbb)
634
	 (and math-fd-bc-flag "b.c."))
Eli Zaretskii's avatar
Eli Zaretskii committed
635
	((eq x 'BBBB)
636
	 (and math-fd-bc-flag "B.C."))
Eli Zaretskii's avatar
Eli Zaretskii committed
637
	((eq x 'M)
638
	 (format "%d" math-fd-month))
Eli Zaretskii's avatar
Eli Zaretskii committed
639
	((eq x 'MM)
640
	 (format "%02d" math-fd-month))
Eli Zaretskii's avatar
Eli Zaretskii committed
641
	((eq x 'BM)
642
	 (format "%2d" math-fd-month))
Eli Zaretskii's avatar
Eli Zaretskii committed
643
	((eq x 'mmm)
644
	 (downcase (nth (1- math-fd-month) math-short-month-names)))
Eli Zaretskii's avatar
Eli Zaretskii committed
645
	((eq x 'Mmm)
646
	 (nth (1- math-fd-month) math-short-month-names))
Eli Zaretskii's avatar
Eli Zaretskii committed
647
	((eq x 'MMM)
648
	 (upcase (nth (1- math-fd-month) math-short-month-names)))
Eli Zaretskii's avatar
Eli Zaretskii committed
649
	((eq x 'Mmmm)
650
	 (nth (1- math-fd-month) math-long-month-names))
Eli Zaretskii's avatar
Eli Zaretskii committed
651
	((eq x 'MMMM)
652
	 (upcase (nth (1- math-fd-month) math-long-month-names)))
Eli Zaretskii's avatar
Eli Zaretskii committed
653
	((eq x 'D)
654
	 (format "%d" math-fd-day))
Eli Zaretskii's avatar
Eli Zaretskii committed
655
	((eq x 'DD)
656
	 (format "%02d" math-fd-day))
Eli Zaretskii's avatar
Eli Zaretskii committed
657
	((eq x 'BD)
658
	 (format "%2d" math-fd-day))
Eli Zaretskii's avatar
Eli Zaretskii committed
659
	((eq x 'W)
660
	 (format "%d" math-fd-weekday))
Eli Zaretskii's avatar
Eli Zaretskii committed
661
	((eq x 'www)
662
	 (downcase (nth math-fd-weekday math-short-weekday-names)))
Eli Zaretskii's avatar
Eli Zaretskii committed
663
	((eq x 'Www)
664
	 (nth math-fd-weekday math-short-weekday-names))
Eli Zaretskii's avatar
Eli Zaretskii committed
665
	((eq x 'WWW)
666
	 (upcase (nth math-fd-weekday math-short-weekday-names)))
Eli Zaretskii's avatar
Eli Zaretskii committed
667
	((eq x 'Wwww)
668
	 (nth math-fd-weekday math-long-weekday-names))
Eli Zaretskii's avatar
Eli Zaretskii committed
669
	((eq x 'WWWW)
670
	 (upcase (nth math-fd-weekday math-long-weekday-names)))
Eli Zaretskii's avatar
Eli Zaretskii committed
671
	((eq x 'd)
672
	 (format "%d" (math-day-number math-fd-year math-fd-month math-fd-day)))
Eli Zaretskii's avatar
Eli Zaretskii committed
673
	((eq x 'ddd)
674
	 (format "%03d" (math-day-number math-fd-year math-fd-month math-fd-day)))
Eli Zaretskii's avatar
Eli Zaretskii committed
675
	((eq x 'bdd)
676
	 (format "%3d" (math-day-number math-fd-year math-fd-month math-fd-day)))
Eli Zaretskii's avatar
Eli Zaretskii committed
677
	((eq x 'h)
678
	 (and math-fd-hour (format "%d" math-fd-hour)))
Eli Zaretskii's avatar
Eli Zaretskii committed
679
	((eq x 'hh)
680
	 (and math-fd-hour (format "%02d" math-fd-hour)))
Eli Zaretskii's avatar
Eli Zaretskii committed
681
	((eq x 'bh)
682
	 (and math-fd-hour (format "%2d" math-fd-hour)))
Eli Zaretskii's avatar
Eli Zaretskii committed
683
	((eq x 'H)
684
	 (and math-fd-hour (format "%d" (1+ (% (+ math-fd-hour 11) 12)))))
Eli Zaretskii's avatar
Eli Zaretskii committed
685
	((eq x 'HH)
686
	 (and math-fd-hour (format "%02d" (1+ (% (+ math-fd-hour 11) 12)))))
Eli Zaretskii's avatar
Eli Zaretskii committed
687
	((eq x 'BH)
688
	 (and math-fd-hour (format "%2d" (1+ (% (+ math-fd-hour 11) 12)))))
Eli Zaretskii's avatar
Eli Zaretskii committed
689
	((eq x 'p)
690
	 (and math-fd-hour (if (< math-fd-hour 12) "a" "p")))
Eli Zaretskii's avatar
Eli Zaretskii committed
691
	((eq x 'P)
692
	 (and math-fd-hour (if (< math-fd-hour 12) "A" "P")))
Eli Zaretskii's avatar
Eli Zaretskii committed
693
	((eq x 'pp)
694
	 (and math-fd-hour (if (< math-fd-hour 12) "am" "pm")))
Eli Zaretskii's avatar
Eli Zaretskii committed
695
	((eq x 'PP)
696
	 (and math-fd-hour (if (< math-fd-hour 12) "AM" "PM")))
Eli Zaretskii's avatar
Eli Zaretskii committed
697
	((eq x 'pppp)
698
	 (and math-fd-hour (if (< math-fd-hour 12) "a.m." "p.m.")))
Eli Zaretskii's avatar
Eli Zaretskii committed
699
	((eq x 'PPPP)
700
	 (and math-fd-hour (if (< math-fd-hour 12) "A.M." "P.M.")))
Eli Zaretskii's avatar
Eli Zaretskii committed
701
	((eq x 'm)
702
	 (and math-fd-minute (format "%d" math-fd-minute)))
Eli Zaretskii's avatar
Eli Zaretskii committed
703
	((eq x 'mm)
704
	 (and math-fd-minute (format "%02d" math-fd-minute)))
Eli Zaretskii's avatar
Eli Zaretskii committed
705
	((eq x 'bm)
706
	 (and math-fd-minute (format "%2d" math-fd-minute)))
Eli Zaretskii's avatar
Eli Zaretskii committed
707
	((eq x 'C)
708
	 (and math-fd-second (not (math-zerop math-fd-second))
Eli Zaretskii's avatar
Eli Zaretskii committed
709 710
	      ":"))
	((memq x '(s ss bs SS BS))
711 712 713
	 (and math-fd-second
	      (not (and (memq x '(SS BS)) (math-zerop math-fd-second)))
	      (if (integerp math-fd-second)
Eli Zaretskii's avatar
Eli Zaretskii committed
714 715 716
		  (format (cond ((memq x '(ss SS)) "%02d")
				((memq x '(bs BS)) "%2d")
				(t "%d"))
717 718
			  math-fd-second)
		(concat (if (Math-lessp math-fd-second 10)
Eli Zaretskii's avatar
Eli Zaretskii committed
719 720 721 722 723 724 725
			    (cond ((memq x '(ss SS)) "0")
				  ((memq x '(bs BS)) " ")
				  (t ""))
			  "")
			(let ((calc-float-format
			       (list 'fix (min (- 12 calc-internal-prec)
					       0))))
726
			  (math-format-number math-fd-second))))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
727

728 729 730 731
;; The variable math-pd-str is local to math-parse-date and
;; math-parse-standard-date, but is used by math-parse-date-word,
;; which is called by math-parse-date and math-parse-standard-date.
(defvar math-pd-str)
Eli Zaretskii's avatar
Eli Zaretskii committed
732

733
(defun math-parse-date (math-pd-str)
Eli Zaretskii's avatar
Eli Zaretskii committed
734
  (catch 'syntax
735 736 737 738
    (or (math-parse-standard-date math-pd-str t)
	(math-parse-standard-date math-pd-str nil)
	(and (string-match "\\`[^-+/0-9a-zA-Z]*\\([-+]?[0-9]+\\.?[0-9]*\\([eE][-+]?[0-9]+\\)?\\)[^-+/0-9a-zA-Z]*\\'" math-pd-str)
	     (list 'date (math-read-number (math-match-substring math-pd-str 1))))
Eli Zaretskii's avatar
Eli Zaretskii committed
739 740 741 742 743 744
	(let ((case-fold-search t)
	      (year nil) (month nil) (day nil) (weekday nil)
	      (hour nil) (minute nil) (second nil) (bc-flag nil)
	      (a nil) (b nil) (c nil) (bigyear nil) temp)

	  ;; Extract the time, if any.
745 746
	  (if (or (string-match "\\([0-9][0-9]?\\):\\([0-9][0-9]?\\)\\(:\\([0-9][0-9]?\\(\\.[0-9]+\\)?\\)\\)? *\\([ap]\\>\\|[ap]m\\|[ap]\\. *m\\.\\|noon\\|n\\>\\|midnight\\|mid\\>\\|m\\>\\)?" math-pd-str)
		  (string-match "\\([0-9][0-9]?\\)\\(\\)\\(\\(\\(\\)\\)\\) *\\([ap]\\>\\|[ap]m\\|[ap]\\. *m\\.\\|noon\\|n\\>\\|midnight\\|mid\\>\\|m\\>\\)" math-pd-str))
747
	      (let ((ampm (math-match-substring math-pd-str 6)))
748
		(setq hour (string-to-number (math-match-substring math-pd-str 1))
749 750 751 752
		      minute (math-match-substring math-pd-str 2)
		      second (math-match-substring math-pd-str 4)
		      math-pd-str (concat (substring math-pd-str 0 (match-beginning 0))
				  (substring math-pd-str (match-end 0))))
Eli Zaretskii's avatar
Eli Zaretskii committed
753 754
		(if (equal minute "")
		    (setq minute 0)
755
		  (setq minute (string-to-number minute)))
Eli Zaretskii's avatar
Eli Zaretskii committed
756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773
		(if (equal second "")
		    (setq second 0)
		  (setq second (math-read-number second)))
		(if (equal ampm "")
		    (if (> hour 23)
			(throw 'syntax "Hour value out of range"))
		  (setq ampm (upcase (aref ampm 0)))
		  (if (memq ampm '(?N ?M))
		      (if (and (= hour 12) (= minute 0) (eq second 0))
			  (if (eq ampm ?M) (setq hour 0))
			(throw 'syntax
			       "Time must be 12:00:00 in this context"))
		    (if (or (= hour 0) (> hour 12))
			(throw 'syntax "Hour value out of range"))
		    (if (eq (= ampm ?A) (= hour 12))
			(setq hour (% (+ hour 12) 24)))))))

	  ;; Rewrite xx-yy-zz to xx/yy/zz to avoid seeing "-" as a minus sign.
774
	  (while (string-match "[0-9a-zA-Z]\\(-\\)[0-9a-zA-Z]" math-pd-str)
Eli Zaretskii's avatar
Eli Zaretskii committed
775
	    (progn
776 777
	      (setq math-pd-str (copy-sequence math-pd-str))
	      (aset math-pd-str (match-beginning 1) ?\/)))
Eli Zaretskii's avatar
Eli Zaretskii committed
778 779

	  ;; Extract obvious month or weekday names.
780
	  (if (string-match "[a-zA-Z]" math-pd-str)
Eli Zaretskii's avatar
Eli Zaretskii committed
781 782 783 784 785 786 787 788 789 790 791 792 793
	      (progn
		(setq month (math-parse-date-word math-long-month-names))
		(setq weekday (math-parse-date-word math-long-weekday-names))
		(or month (setq month
				(math-parse-date-word math-short-month-names)))
		(or weekday (math-parse-date-word math-short-weekday-names))
		(or hour
		    (if (setq temp (math-parse-date-word
				    '( "noon" "midnight" "mid" )))
			(setq hour (if (= temp 1) 12 0) minute 0 second 0)))
		(or (math-parse-date-word '( "ad" "a.d." ))
		    (if (math-parse-date-word '( "bc" "b.c." ))
			(setq bc-flag t)))
794
		(if (string-match "[a-zA-Z]+" math-pd-str)
Eli Zaretskii's avatar
Eli Zaretskii committed
795
		    (throw 'syntax (format "Bad word in date: \"%s\""
796
					   (math-match-substring math-pd-str 0))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
797 798

	  ;; If there is a huge number other than the year, ignore it.
799 800 801
	  (while (and (string-match "[-+]?0*[1-9][0-9][0-9][0-9][0-9]+" math-pd-str)
		      (setq temp (concat (substring math-pd-str 0 (match-beginning 0))
					 (substring math-pd-str (match-end 0))))
Kim F. Storm's avatar
Kim F. Storm committed
802
		      (string-match
803 804
                       "[4-9][0-9]\\|[0-9][0-9][0-9]\\|[-+][0-9]+[^-]*\\'" temp))
	    (setq math-pd-str temp))
Eli Zaretskii's avatar
Eli Zaretskii committed
805 806

	  ;; If there is a number with a sign or a large number, it is a year.
807 808 809 810 811
	  (if (or (string-match "\\([-+][0-9]+\\)[^-]*\\'" math-pd-str)
		  (string-match "\\(0*[1-9][0-9][0-9]+\\)" math-pd-str))
	      (setq year (math-match-substring math-pd-str 1)
		    math-pd-str (concat (substring math-pd-str 0 (match-beginning 1))
				(substring math-pd-str (match-end 1)))
Eli Zaretskii's avatar
Eli Zaretskii committed
812 813 814 815 816
		    year (math-read-number year)
		    bigyear t))

	  ;; Collect remaining numbers.
	  (setq temp 0)
817
	  (while (string-match "[0-9]+" math-pd-str temp)
Eli Zaretskii's avatar
Eli Zaretskii committed
818
	    (and c (throw 'syntax "Too many numbers in date"))
819
	    (setq c (string-to-number (math-match-substring math-pd-str 0)))
Eli Zaretskii's avatar
Eli Zaretskii committed
820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878
	    (or b (setq b c c nil))
	    (or a (setq a b b nil))
	    (setq temp (match-end 0)))

	  ;; Check that we have the right amount of information.
	  (setq temp (+ (if year 1 0) (if month 1 0) (if day 1 0)
			(if a 1 0) (if b 1 0) (if c 1 0)))
	  (if (> temp 3)
	      (throw 'syntax "Too many numbers in date")
	    (if (or (< temp 2) (and year (= temp 2)))
		(throw 'syntax "Not enough numbers in date")
	      (if (= temp 2)   ; if year omitted, assume current year
		  (setq year (math-this-year)))))

	  ;; A large number must be a year.
	  (or year
	      (if (and a (or (> a 31) (< a 1)))
		  (setq year a a b b c c nil)
		(if (and b (or (> b 31) (< b 1)))
		    (setq year b b c c nil)
		  (if (and c (or (> c 31) (< c 1)))
		      (setq year c c nil)))))

	  ;; A medium-large number must be a day.
	  (if year
	      (if (and a (> a 12))
		  (setq day a a b b c c nil)
		(if (and b (> b 12))
		    (setq day b b c c nil)
		  (if (and c (> c 12))
		      (setq day c c nil)))))

	  ;; We may know enough to sort it out now.
	  (if (and year day)
	      (or month (setq month a))
	    (if (and year month)
		(setq day a)

	      ;; Interpret order of numbers as same as for display format.
	      (setq temp calc-date-format)
	      (while temp
		(cond ((not (symbolp (car temp))))
		      ((memq (car temp) '(Y YY BY YYY YYYY))
		       (or year (setq year a a b b c)))
		      ((memq (car temp) '(M MM BM mmm Mmm Mmmm MMM MMMM))
		       (or month (setq month a a b b c)))
		      ((memq (car temp) '(D DD BD))
		       (or day (setq day a a b b c))))
		(setq temp (cdr temp)))

	      ;; If display format was not complete, assume American style.
	      (or month (setq month a a b b c))
	      (or day (setq day a a b b c))
	      (or year (setq year a a b b c))))

	  (if bc-flag
	      (setq year (math-neg (math-abs year))))

	  (math-parse-date-validate year bigyear month day
879
				    hour minute second)))))
Eli Zaretskii's avatar
Eli Zaretskii committed
880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898

(defun math-parse-date-validate (year bigyear month day hour minute second)
  (and (not bigyear) (natnump year) (< year 100)
       (setq year (+ year (if (< year 40) 2000 1900))))
  (if (eq year 0)
      (throw 'syntax "Year value is out of range"))
  (if (or (< month 1) (> month 12))
      (throw 'syntax "Month value is out of range"))
  (if (or (< day 1) (> day (math-days-in-month year month)))
      (throw 'syntax "Day value is out of range"))
  (and hour
       (progn
	 (if (or (< hour 0) (> hour 23))
	     (throw 'syntax "Hour value is out of range"))
	 (if (or (< minute 0) (> minute 59))
	     (throw 'syntax "Minute value is out of range"))
	 (if (or (math-negp second) (not (Math-lessp second 60)))
	     (throw 'syntax "Seconds value is out of range"))))
  (list 'date (math-dt-to-date (append (list year month day)
899
				       (and hour (list hour minute second))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
900 901 902 903 904 905

(defun math-parse-date-word (names &optional front)
  (let ((n 1))
    (while (and names (not (string-match (if (equal (car names) "Sep")
					     "Sept?"
					   (regexp-quote (car names)))
906
					 math-pd-str)))
Eli Zaretskii's avatar
Eli Zaretskii committed
907 908 909 910 911
      (setq names (cdr names)
	    n (1+ n)))
    (and names
	 (or (not front) (= (match-beginning 0) 0))
	 (progn
912
	   (setq math-pd-str (concat (substring math-pd-str 0 (match-beginning 0))
Eli Zaretskii's avatar
Eli Zaretskii committed
913
			     (if front "" " ")
914
			     (substring math-pd-str (match-end 0))))
915
	   n))))
Eli Zaretskii's avatar
Eli Zaretskii committed
916

917
(defun math-parse-standard-date (math-pd-str with-time)
Eli Zaretskii's avatar
Eli Zaretskii committed
918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936
  (let ((case-fold-search t)
	(okay t) num
	(fmt calc-date-format) this next (gnext nil)
	(year nil) (month nil) (day nil) (bigyear nil) (yearday nil)
	(hour nil) (minute nil) (second nil) (bc-flag nil))
    (while (and fmt okay)
      (setq this (car fmt)
	    fmt (setq fmt (or (cdr fmt)
				(prog1
				    gnext
				  (setq gnext nil))))
	    next (car fmt))
      (if (consp next) (setq next (car next)))
      (or (cond ((listp this)
		 (or (not with-time)
		     (not this)
		     (setq gnext fmt
			   fmt this)))
		((stringp this)
937
		 (if (and (<= (length this) (length math-pd-str))
Eli Zaretskii's avatar
Eli Zaretskii committed
938
			  (equal this
939 940
				 (substring math-pd-str 0 (length this))))
		     (setq math-pd-str (substring math-pd-str (length this)))))
Eli Zaretskii's avatar
Eli Zaretskii committed
941 942 943
		((eq this 'X)
		 t)
		((memq this '(n N j J))
944 945 946
		 (and (string-match "\\`[-+]?[0-9.]+\\([eE][-+]?[0-9]+\\)?" math-pd-str)
		      (setq num (math-match-substring math-pd-str 0)
			    math-pd-str (substring math-pd-str (match-end 0))
Eli Zaretskii's avatar
Eli Zaretskii committed
947 948 949 950 951 952
			    num (math-date-to-dt (math-read-number num))
			    num (math-sub num
					  (if (memq this '(n N))
					      0
					    (if (or (eq this 'j)
						    (math-integerp num))
953 954
                                                math-julian-date-beginning-int
                                              math-julian-date-beginning)))
Eli Zaretskii's avatar
Eli Zaretskii committed
955 956 957 958 959 960 961
			    hour (or (nth 3 num) hour)
			    minute (or (nth 4 num) minute)
			    second (or (nth 5 num) second)
			    year (car num)
			    month (nth 1 num)
			    day (nth 2 num))))
		((eq this 'U)
962 963 964
		 (and (string-match "\\`[-+]?[0-9]+" math-pd-str)
		      (setq num (math-match-substring math-pd-str 0)
			    math-pd-str (substring math-pd-str (match-end 0))
Eli Zaretskii's avatar
Eli Zaretskii committed
965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983
			    num (math-date-to-dt
				 (math-add 719164
					   (math-div (math-read-number num)
						     '(float 864 2))))
			    hour (nth 3 num)
			    minute (nth 4 num)
			    second (nth 5 num)
			    year (car num)
			    month (nth 1 num)
			    day (nth 2 num))))
		((memq this '(mmm Mmm MMM))
		 (setq month (math-parse-date-word math-short-month-names t)))
		((memq this '(Mmmm MMMM))
		 (setq month (math-parse-date-word math-long-month-names t)))
		((memq this '(www Www WWW))
		 (math-parse-date-word math-short-weekday-names t))
		((memq this '(Wwww WWWW))
		 (math-parse-date-word math-long-weekday-names t))
		((memq this '(p P))
984
		 (if (string-match "\\`a" math-pd-str)
Eli Zaretskii's avatar
Eli Zaretskii committed
985
		     (setq hour (if (= hour 12) 0 hour)
986 987
			   math-pd-str (substring math-pd-str 1))
		   (if (string-match "\\`p" math-pd-str)
Eli Zaretskii's avatar
Eli Zaretskii committed
988
		       (setq hour (if (= hour 12) 12 (% (+ hour 12) 24))
989
			     math-pd-str (substring math-pd-str 1)))))
Eli Zaretskii's avatar
Eli Zaretskii committed
990
		((memq this '(pp PP pppp PPPP))
991
		 (if (string-match "\\`am\\|a\\.m\\." math-pd-str)
Eli Zaretskii's avatar
Eli Zaretskii committed
992
		     (setq hour (if (= hour 12) 0 hour)
993 994
			   math-pd-str (substring math-pd-str (match-end 0)))
		   (if (string-match "\\`pm\\|p\\.m\\." math-pd-str)
Eli Zaretskii's avatar
Eli Zaretskii committed
995
		       (setq hour (if (= hour 12) 12 (% (+ hour 12) 24))
996
			     math-pd-str (substring math-pd-str (match-end 0))))))
Eli Zaretskii's avatar
Eli Zaretskii committed
997 998 999
		((memq this '(Y YY BY YYY YYYY))
		 (and (if (memq next '(MM DD ddd hh HH mm ss SS))
			  (if (memq this '(Y YY BYY))
1000 1001 1002 1003
			      (string-match "\\` *[0-9][0-9]" math-pd-str)
			    (string-match "\\`[0-9][0-9][0-9][0-9]" math-pd-str))
			(string-match "\\`[-+]?[0-9]+" math-pd-str))
		      (setq year (math-match-substring math-pd-str 0)
Eli Zaretskii's avatar
Eli Zaretskii committed
1004
			    bigyear (or (eq this 'YYY)
1005 1006
					(memq (aref math-pd-str 0) '(?\+ ?\-)))
			    math-pd-str (substring math-pd-str (match-end 0))
Eli Zaretskii's avatar
Eli Zaretskii committed
1007 1008 1009 1010
			    year (math-read-number year))))
		((eq this 'b)
		 t)
		((memq this '(aa AA aaaa AAAA))
1011 1012
		 (if (string-match "\\` *\\(ad\\|a\\.d\\.\\)" math-pd-str)
		     (setq math-pd-str (substring math-pd-str (match-end 0)))))
Eli Zaretskii's avatar
Eli Zaretskii committed
1013
		((memq this '(aaa AAA))
1014 1015
		 (if (string-match "\\` *ad *" math-pd-str)
		     (setq math-pd-str (substring math-pd-str (match-end 0)))))
Eli Zaretskii's avatar
Eli Zaretskii committed
1016
		((memq this '(bb BB bbb BBB bbbb BBBB))
1017 1018
		 (if (string-match "\\` *\\(bc\\|b\\.c\\.\\)" math-pd-str)
		     (setq math-pd-str (substring math-pd-str (match-end 0))
Eli Zaretskii's avatar
Eli Zaretskii committed
1019 1020 1021
			   bc-flag t)))
		((memq this '(s ss bs SS BS))
		 (and (if (memq next '(YY YYYY MM DD hh HH mm))
1022 1023 1024 1025
			  (string-match "\\` *[0-9][0-9]\\(\\.[0-9]+\\)?" math-pd-str)
			(string-match "\\` *[0-9][0-9]?\\(\\.[0-9]+\\)?" math-pd-str))
		      (setq second (math-match-substring math-pd-str 0)
			    math-pd-str (substring math-pd-str (match-end 0))
Eli Zaretskii's avatar
Eli Zaretskii committed
1026 1027
			    second (math-read-number second))))
		((eq this 'C)
1028 1029
		 (if (string-match "\\`:[0-9][0-9]" math-pd-str)
		     (setq math-pd-str (substring math-pd-str 1))
Eli Zaretskii's avatar
Eli Zaretskii committed
1030 1031 1032 1033 1034
		   t))
		((or (not (if (and (memq this '(ddd MM DD hh HH mm))
				   (memq next '(YY YYYY MM DD ddd
						   hh HH mm ss SS)))
			      (if (eq this 'ddd)
1035 1036 1037
				  (string-match "\\` *[0-9][0-9][0-9]" math-pd-str)
				(string-match "\\` *[0-9][0-9]" math-pd-str))
			    (string-match "\\` *[0-9]+" math-pd-str)))
1038
		     (and (setq num (string-to-number
1039 1040
				     (math-match-substring math-pd-str 0))
				math-pd-str (substring math-pd-str (match-end 0)))
Eli Zaretskii's avatar
Eli Zaretskii committed
1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059
			  nil))
		 nil)
		((eq this 'W)
		 (and (>= num 0) (< num 7)))
		((memq this '(d ddd bdd))
		 (setq yearday num))
		((memq this '(M MM BM))
		 (setq month num))
		((memq this '(D DD BD))
		 (setq day num))
		((memq this '(h hh bh H HH BH))
		 (setq hour num))
		((memq this '(m mm bm))
		 (setq minute num)))
	  (setq okay nil)))
    (if yearday
	(if (and month day)
	    (setq yearday nil)
	  (setq month 1 day 1)))
1060
    (if (and okay (equal math-pd-str ""))
Eli Zaretskii's avatar
Eli Zaretskii committed
1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071
	(and month day (or (not (or hour minute second))
			   (and hour minute))
	     (progn
	       (or year (setq year (math-this-year)))
	       (or second (setq second 0))
	       (if bc-flag
		   (setq year (math-neg (math-abs year))))
	       (setq day (math-parse-date-validate year bigyear month day
						   hour minute second))
	       (if yearday
		   (setq day (math-add day (1- yearday))))
1072
	       day)))))
Eli Zaretskii's avatar
Eli Zaretskii committed
1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084


(defun calcFunc-now (&optional zone)
  (let ((date (let ((calc-date-format nil))
		(math-parse-date (current-time-string)))))
    (if (consp date)
	(if zone
	    (math-add date (math-div (math-sub (calcFunc-tzone nil date)
					       (calcFunc-tzone zone date))
				     '(float 864 2)))
	  date)
      (calc-record-why "*Unable to interpret current date from system")