calc-forms.el

Revision 4220, 64.8 kB (checked in by miyoshi, 9 months ago)
Sync up with Emacs22.2.

Line
1	;;; calc-forms.el --- data format conversion functions for Calc
2
3	;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4	;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
5
6	;; Author: David Gillespie <daveg@synaptics.com>
7	;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
8
9	;; This file is part of GNU Emacs.
10
11	;; GNU Emacs is free software; you can redistribute it and/or modify
12	;; it under the terms of the GNU General Public License as published by
13	;; the Free Software Foundation; either version 3, or (at your option)
14	;; any later version.
15
16	;; GNU Emacs is distributed in the hope that it will be useful,
17	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19	;; GNU General Public License for more details.
20
21	;; You should have received a copy of the GNU General Public License
22	;; along with GNU Emacs; see the file COPYING. If not, write to the
23	;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24	;; Boston, MA 02110-1301, USA.
25
26	;;; Commentary:
27
28	;;; Code:
29
30	;; This file is autoloaded from calc-ext.el.
31
32	(require 'calc-ext)
33	(require 'calc-macs)
34
35	(defun calc-time ()
36	(interactive)
37	(calc-wrapper
38	(let ((time (current-time-string)))
39	(calc-enter-result 0 "time"
40	(list 'mod
41	(list 'hms
42	(string-to-number (substring time 11 13))
43	(string-to-number (substring time 14 16))
44	(string-to-number (substring time 17 19)))
45	(list 'hms 24 0 0))))))
46
47	(defun calc-to-hms (arg)
48	(interactive "P")
49	(calc-wrapper
50	(if (calc-is-inverse)
51	(if (eq calc-angle-mode 'rad)
52	(calc-unary-op ">rad" 'calcFunc-rad arg)
53	(calc-unary-op ">deg" 'calcFunc-deg arg))
54	(calc-unary-op ">hms" 'calcFunc-hms arg))))
55
56	(defun calc-from-hms (arg)
57	(interactive "P")
58	(calc-invert-func)
59	(calc-to-hms arg))
60
61
62	(defun calc-hms-notation (fmt)
63	(interactive "sHours-minutes-seconds format (hms, @ ' \", etc.): ")
64	(calc-wrapper
65	(if (string-match *"\\`\$[^,; ]+\$\$[,; ]\$\$[^,; ]\$\$[,; ]\$\$[^,; ]\$\\'"* fmt)
66	(progn
67	(calc-change-mode 'calc-hms-format
68	(concat "%s" (math-match-substring fmt 1)
69	(math-match-substring fmt 2)
70	"%s" (math-match-substring fmt 3)
71	(math-match-substring fmt 4)
72	"%s" (math-match-substring fmt 5))
73	t)
74	(setq-default calc-hms-format calc-hms-format)) ; for minibuffer
75	(error "Bad hours-minutes-seconds format"))))
76
77	(defun calc-date-notation (fmt arg)
78	(interactive "sDate format (e.g., M/D/YY h:mm:ss): \nP")
79	(calc-wrapper
80	(if (equal fmt "")
81	(setq fmt "1"))
82	(if (string-match *"\\` [0-9] \\'"* fmt)
83	(setq fmt (nth (string-to-number fmt) calc-standard-date-formats)))
84	(or (string-match "[a-zA-Z]" fmt)
85	(error "Bad date format specifier"))
86	(and arg
87	(>= (setq arg (prefix-numeric-value arg)) 0)
88	(<= arg 9)
89	(setq calc-standard-date-formats
90	(copy-sequence calc-standard-date-formats))
91	(setcar (nthcdr arg calc-standard-date-formats) fmt))
92	(let ((case-fold-search nil))
93	(and (not (string-match *"<.>"** fmt))
94	(string-match *"\\`[^hHspP]\$[^ac-gi-lnoqrt-zAC-GI-OQRT-Z][bBhHmpPsS]+[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]\$[^hHspP]\\'"* fmt)
95	(string-match (concat *"[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]"**
96	(regexp-quote (math-match-substring fmt 1))
97	*"[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]"**) fmt)
98	(setq fmt (concat (substring fmt 0 (match-beginning 0))
99	"<"
100	(substring fmt (match-beginning 0) (match-end 0))
101	">"
102	(substring fmt (match-end 0))))))
103	(let ((lfmt nil)
104	(fullfmt nil)
105	(time nil)
106	pos pos2 sym temp)
107	(let ((case-fold-search nil))
108	(and (setq temp (string-match ":[BS]S" fmt))
109	(aset fmt temp ?C)))
110	(while (setq pos (string-match "[<>a-zA-Z]" fmt))
111	(if (> pos 0)
112	(setq lfmt (cons (substring fmt 0 pos) lfmt)))
113	(setq pos2 (1+ pos))
114	(cond ((= (aref fmt pos) ?\<)
115	(and time (error "Nested <'s not allowed"))
116	(and lfmt (setq fullfmt (nconc lfmt fullfmt)
117	lfmt nil))
118	(setq time t))
119	((= (aref fmt pos) ?\>)
120	(or time (error "Misplaced > in format"))
121	(and lfmt (setq fullfmt (cons (nreverse lfmt) fullfmt)
122	lfmt nil))
123	(setq time nil))
124	(t
125	(if (string-match *"\\`[^a-zA-Z][bB][a-zA-Z]"** fmt)
126	(setq pos2 (1+ pos2)))
127	(while (and (< pos2 (length fmt))
128	(= (upcase (aref fmt pos2))
129	(upcase (aref fmt (1- pos2)))))
130	(setq pos2 (1+ pos2)))
131	(setq sym (intern (substring fmt pos pos2)))
132	(or (memq sym '(Y YY BY YYY YYYY
133	aa AA aaa AAA aaaa AAAA
134	bb BB bbb BBB bbbb BBBB
135	M MM BM mmm Mmm Mmmm MMM MMMM
136	D DD BD d ddd bdd
137	W www Www Wwww WWW WWWW
138	h hh bh H HH BH
139	p P pp PP pppp PPPP
140	m mm bm s ss bss SS BS C
141	N n J j U b))
142	(and (eq sym 'X) (not lfmt) (not fullfmt))
143	(error "Bad format code: %s" sym))
144	(and (memq sym '(bb BB bbb BBB bbbb BBBB))
145	(setq lfmt (cons 'b lfmt)))
146	(setq lfmt (cons sym lfmt))))
147	(setq fmt (substring fmt pos2)))
148	(or (equal fmt "")
149	(setq lfmt (cons fmt lfmt)))
150	(and lfmt (if time
151	(setq fullfmt (cons (nreverse lfmt) fullfmt))
152	(setq fullfmt (nconc lfmt fullfmt))))
153	(calc-change-mode 'calc-date-format (nreverse fullfmt) t))))
154
155
156	(defun calc-hms-mode ()
157	(interactive)
158	(calc-wrapper
159	(calc-change-mode 'calc-angle-mode 'hms)
160	(message "Angles measured in degrees-minutes-seconds")))
161
162
163	(defun calc-now (arg)
164	(interactive "P")
165	(calc-date-zero-args "now" 'calcFunc-now arg))
166
167	(defun calc-date-part (arg)
168	(interactive "NPart code (1-9 = Y,M,D,H,M,S,Wd,Yd,Hms): ")
169	(if (or (< arg 1) (> arg 9))
170	(error "Part code out of range"))
171	(calc-wrapper
172	(calc-enter-result 1
173	(nth arg '(nil "year" "mnth" "day" "hour" "minu"
174	"sec" "wday" "yday" "hmst"))
175	(list (nth arg '(nil calcFunc-year calcFunc-month
176	calcFunc-day calcFunc-hour
177	calcFunc-minute calcFunc-second
178	calcFunc-weekday calcFunc-yearday
179	calcFunc-time))
180	(calc-top-n 1)))))
181
182	(defun calc-date (arg)
183	(interactive "p")
184	(if (or (< arg 1) (> arg 6))
185	(error "Between one and six arguments are allowed"))
186	(calc-wrapper
187	(calc-enter-result arg "date" (cons 'calcFunc-date (calc-top-list-n arg)))))
188
189	(defun calc-julian (arg)
190	(interactive "P")
191	(calc-date-one-arg "juln" 'calcFunc-julian arg))
192
193	(defun calc-unix-time (arg)
194	(interactive "P")
195	(calc-date-one-arg "unix" 'calcFunc-unixtime arg))
196
197	(defun calc-time-zone (arg)
198	(interactive "P")
199	(calc-date-zero-args "zone" 'calcFunc-tzone arg))
200
201	(defun calc-convert-time-zones (old &optional new)
202	(interactive "sFrom time zone: ")
203	(calc-wrapper
204	(if (equal old "$")
205	(calc-enter-result 3 "tzcv" (cons 'calcFunc-tzconv (calc-top-list-n 3)))
206	(if (equal old "") (setq old "local"))
207	(or new
208	(setq new (read-string (concat "From time zone: " old
209	", to zone: "))))
210	(if (stringp old) (setq old (math-read-expr old)))
211	(if (eq (car-safe old) 'error)
212	(error "Error in expression: %S" (nth 1 old)))
213	(if (equal new "") (setq new "local"))
214	(if (stringp new) (setq new (math-read-expr new)))
215	(if (eq (car-safe new) 'error)
216	(error "Error in expression: %S" (nth 1 new)))
217	(calc-enter-result 1 "tzcv" (list 'calcFunc-tzconv
218	(calc-top-n 1) old new)))))
219
220	(defun calc-new-week (arg)
221	(interactive "P")
222	(calc-date-one-arg "nwwk" 'calcFunc-newweek arg))
223
224	(defun calc-new-month (arg)
225	(interactive "P")
226	(calc-date-one-arg "nwmn" 'calcFunc-newmonth arg))
227
228	(defun calc-new-year (arg)
229	(interactive "P")
230	(calc-date-one-arg "nwyr" 'calcFunc-newyear arg))
231
232	(defun calc-inc-month (arg)
233	(interactive "p")
234	(calc-date-one-arg "incm" 'calcFunc-incmonth arg))
235
236	(defun calc-business-days-plus (arg)
237	(interactive "P")
238	(calc-wrapper
239	(calc-binary-op "bus+" 'calcFunc-badd arg)))
240
241	(defun calc-business-days-minus (arg)
242	(interactive "P")
243	(calc-wrapper
244	(calc-binary-op "bus-" 'calcFunc-bsub arg)))
245
246	(defun calc-date-zero-args (prefix func arg)
247	(calc-wrapper
248	(if (consp arg)
249	(calc-enter-result 1 prefix (list func (calc-top-n 1)))
250	(calc-enter-result 0 prefix (if arg
251	(list func (prefix-numeric-value arg))
252	(list func))))))
253
254	(defun calc-date-one-arg (prefix func arg)
255	(calc-wrapper
256	(if (consp arg)
257	(calc-enter-result 2 prefix (cons func (calc-top-list-n 2)))
258	(calc-enter-result 1 prefix (if arg
259	(list func (calc-top-n 1)
260	(prefix-numeric-value arg))
261	(list func (calc-top-n 1)))))))
262
263
264	;;;; Hours-minutes-seconds forms.
265
266	(defun math-normalize-hms (a)
267	(let ((h (math-normalize (nth 1 a)))
268	(m (math-normalize (nth 2 a)))
269	(s (let ((calc-internal-prec (max (- calc-internal-prec 4) 3)))
270	(math-normalize (nth 3 a)))))
271	(if (math-negp h)
272	(progn
273	(if (math-posp s)
274	(setq s (math-add s -60)
275	m (math-add m 1)))
276	(if (math-posp m)
277	(setq m (math-add m -60)
278	h (math-add h 1)))
279	(if (not (Math-lessp -60 s))
280	(setq s (math-add s 60)
281	m (math-add m -1)))
282	(if (not (Math-lessp -60 m))
283	(setq m (math-add m 60)
284	h (math-add h -1))))
285	(if (math-negp s)
286	(setq s (math-add s 60)
287	m (math-add m -1)))
288	(if (math-negp m)
289	(setq m (math-add m 60)
290	h (math-add h -1)))
291	(if (not (Math-lessp s 60))
292	(setq s (math-add s -60)
293	m (math-add m 1)))
294	(if (not (Math-lessp m 60))
295	(setq m (math-add m -60)
296	h (math-add h 1))))
297	(if (and (eq (car-safe s) 'float)
298	(<= (+ (math-numdigs (nth 1 s)) (nth 2 s))
299	(- 2 calc-internal-prec)))
300	(setq s 0))
301	(list 'hms h m s)))
302
303	;;; Convert A from ANG or current angular mode to HMS format.
304	(defun math-to-hms (a &optional ang) ; [X R] [Public]
305	(cond ((eq (car-safe a) 'hms) a)
306	((eq (car-safe a) 'sdev)
307	(math-make-sdev (math-to-hms (nth 1 a))
308	(math-to-hms (nth 2 a))))
309	((not (Math-numberp a))
310	(list 'calcFunc-hms a))
311	((math-negp a)
312	(math-neg (math-to-hms (math-neg a) ang)))
313	((eq (or ang calc-angle-mode) 'rad)
314	(math-to-hms (math-div a (math-pi-over-180)) 'deg))
315	((memq (car-safe a) '(cplx polar)) a)
316	(t
317	;(setq a (let ((calc-internal-prec (max (1- calc-internal-prec) 3)))
318	; (math-normalize a)))
319	(math-normalize
320	(let* ((b (math-mul a 3600))
321	(hm (math-trunc (math-div b 60)))
322	(hmd (math-idivmod hm 60)))
323	(list 'hms
324	(car hmd)
325	(cdr hmd)
326	(math-sub b (math-mul hm 60))))))))
327	(defun calcFunc-hms (h &optional m s)
328	(or (Math-realp h) (math-reject-arg h 'realp))
329	(or m (setq m 0))
330	(or (Math-realp m) (math-reject-arg m 'realp))
331	(or s (setq s 0))
332	(or (Math-realp s) (math-reject-arg s 'realp))
333	(if (and (not (Math-lessp m 0)) (Math-lessp m 60)
334	(not (Math-lessp s 0)) (Math-lessp s 60))
335	(math-add (math-to-hms h)
336	(list 'hms 0 m s))
337	(math-to-hms (math-add h
338	(math-add (math-div (or m 0) 60)
339	(math-div (or s 0) 3600)))
340	'deg)))
341
342	;;; Convert A from HMS format to ANG or current angular mode.
343	(defun math-from-hms (a &optional ang) ; [R X] [Public]
344	(cond ((not (eq (car-safe a) 'hms))
345	(if (Math-numberp a)
346	a
347	(if (eq (car-safe a) 'sdev)
348	(math-make-sdev (math-from-hms (nth 1 a) ang)
349	(math-from-hms (nth 2 a) ang))
350	(if (eq (or ang calc-angle-mode) 'rad)
351	(list 'calcFunc-rad a)
352	(list 'calcFunc-deg a)))))
353	((math-negp a)
354	(math-neg (math-from-hms (math-neg a) ang)))
355	((eq (or ang calc-angle-mode) 'rad)
356	(math-mul (math-from-hms a 'deg) (math-pi-over-180)))
357	(t
358	(math-add (math-div (math-add (math-div (nth 3 a)
359	'(float 6 1))
360	(nth 2 a))
361	60)
362	(nth 1 a)))))
363
364	;;;; Date forms.
365
366
367	;;; Some of these functions are adapted from Edward Reingold's "calendar.el".
368	;;; These versions are rewritten to use arbitrary-size integers.
369	;;; The Julian calendar is used up to 9/2/1752, after which the Gregorian
370	;;; calendar is used; the first day after 9/2/1752 is 9/14/1752.
371
372	;;; A numerical date is the number of days since midnight on
373	;;; the morning of January 1, 1 A.D. If the date is a non-integer,
374	;;; it represents a specific date and time.
375	;;; A "dt" is a list of the form, (year month day), corresponding to
376	;;; an integer code, or (year month day hour minute second), corresponding
377	;;; to a non-integer code.
378
379	(defun math-date-to-dt (value)
380	(if (eq (car-safe value) 'date)
381	(setq value (nth 1 value)))
382	(or (math-realp value)
383	(math-reject-arg value 'datep))
384	(let* ((parts (math-date-parts value))
385	(date (car parts))
386	(time (nth 1 parts))
387	(month 1)
388	day
389	(year (math-quotient (math-add date (if (Math-lessp date 711859)
390	365 ; for speed, we take
391	-108)) ; >1950 as a special case
392	(if (math-negp value) 366 365)))
393	; this result may be an overestimate
394	temp)
395	(while (Math-lessp date (setq temp (math-absolute-from-date year 1 1)))
396	(setq year (math-add year -1)))
397	(if (eq year 0) (setq year -1))
398	(setq date (1+ (math-sub date temp)))
399	(and (eq year 1752) (>= date 247)
400	(setq date (+ date 11)))
401	(setq temp (if (math-leap-year-p year)
402	[1 32 61 92 122 153 183 214 245 275 306 336 999]
403	[1 32 60 91 121 152 182 213 244 274 305 335 999]))
404	(while (>= date (aref temp month))
405	(setq month (1+ month)))
406	(setq day (1+ (- date (aref temp (1- month)))))
407	(if (math-integerp value)
408	(list year month day)
409	(list year month day
410	(/ time 3600)
411	(% (/ time 60) 60)
412	(math-add (% time 60) (nth 2 parts))))))
413
414	(defun math-dt-to-date (dt)
415	(or (integerp (nth 1 dt))
416	(math-reject-arg (nth 1 dt) 'fixnump))
417	(if (or (< (nth 1 dt) 1) (> (nth 1 dt) 12))
418	(math-reject-arg (nth 1 dt) "Month value is out of range"))
419	(or (integerp (nth 2 dt))
420	(math-reject-arg (nth 2 dt) 'fixnump))
421	(if (or (< (nth 2 dt) 1) (> (nth 2 dt) 31))
422	(math-reject-arg (nth 2 dt) "Day value is out of range"))
423	(let ((date (math-absolute-from-date (car dt) (nth 1 dt) (nth 2 dt))))
424	(if (nth 3 dt)
425	(math-add (math-float date)
426	(math-div (math-add (+ (* (nth 3 dt) 3600)
427	(* (nth 4 dt) 60))
428	(nth 5 dt))
429	'(float 864 2)))
430	date)))
431
432	(defun math-date-parts (value &optional offset)
433	(let* ((date (math-floor value))
434	(time (math-round (math-mul (math-sub value (or offset date)) 86400)
435	(and (> calc-internal-prec 12)
436	(- calc-internal-prec 12))))
437	(ftime (math-floor time)))
438	(list date
439	ftime
440	(math-sub time ftime))))
441
442
443	(defun math-this-year ()
444	(string-to-number (substring (current-time-string) -4)))
445
446	(defun math-leap-year-p (year)
447	(if (Math-lessp year 1752)
448	(if (math-negp year)
449	(= (math-imod (math-neg year) 4) 1)
450	(= (math-imod year 4) 0))
451	(setq year (math-imod year 400))
452	(or (and (= (% year 4) 0) (/= (% year 100) 0))
453	(= year 0))))
454
455	(defun math-days-in-month (year month)
456	(if (and (= month 2) (math-leap-year-p year))
457	29
458	(aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
459
460	(defun math-day-number (year month day)
461	(let ((day-of-year (+ day (* 31 (1- month)))))
462	(if (> month 2)
463	(progn
464	(setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
465	(if (math-leap-year-p year)
466	(setq day-of-year (1+ day-of-year)))))
467	(and (eq year 1752)
468	(or (> month 9)
469	(and (= month 9) (>= day 14)))
470	(setq day-of-year (- day-of-year 11)))
471	day-of-year))
472
473	(defun math-absolute-from-date (year month day)
474	(if (eq year 0) (setq year -1))
475	(let ((yearm1 (math-sub year 1)))
476	(math-sub (math-add (math-day-number year month day)
477	(math-add (math-mul 365 yearm1)
478	(if (math-posp year)
479	(math-quotient yearm1 4)
480	(math-sub 365
481	(math-quotient (math-sub 3 year)
482	4)))))
483	(if (or (Math-lessp year 1753)
484	(and (eq year 1752) (<= month 9)))
485	1
486	(let ((correction (math-mul (math-quotient yearm1 100) 3)))
487	(let ((res (math-idivmod correction 4)))
488	(math-add (if (= (cdr res) 0)
489	-1
490	0)
491	(car res))))))))
492
493
494	;;; It is safe to redefine these in your .emacs file to use a different
495	;;; language.
496
497	(defvar math-long-weekday-names '( "Sunday" "Monday" "Tuesday" "Wednesday"
498	"Thursday" "Friday" "Saturday" ))
499	(defvar math-short-weekday-names '( "Sun" "Mon" "Tue" "Wed"
500	"Thu" "Fri" "Sat" ))
501
502	(defvar math-long-month-names '( "January" "February" "March" "April"
503	"May" "June" "July" "August"
504	"September" "October" "November" "December" ))
505	(defvar math-short-month-names '( "Jan" "Feb" "Mar" "Apr" "May" "Jun"
506	"Jul" "Aug" "Sep" "Oct" "Nov" "Dec" ))
507
508
509	(defvar math-format-date-cache nil)
510
511	;; The variables math-fd-date, math-fd-dt, math-fd-year,
512	;; math-fd-month, math-fd-day, math-fd-weekday, math-fd-hour,
513	;; math-fd-minute, math-fd-second, math-fd-bc-flag are local
514	;; to math-format-date, but are used by math-format-date-part,
515	;; which is called by math-format-date.
516	(defvar math-fd-date)
517	(defvar math-fd-dt)
518	(defvar math-fd-year)
519	(defvar math-fd-month)
520	(defvar math-fd-day)
521	(defvar math-fd-weekday)
522	(defvar math-fd-hour)
523	(defvar math-fd-minute)
524	(defvar math-fd-second)
525	(defvar math-fd-bc-flag)
526
527	(defun math-format-date (math-fd-date)
528	(if (eq (car-safe math-fd-date) 'date)
529	(setq math-fd-date (nth 1 math-fd-date)))
530	(let ((entry (list math-fd-date calc-internal-prec calc-date-format)))
531	(or (cdr (assoc entry math-format-date-cache))
532	(let* ((math-fd-dt nil)
533	(calc-group-digits nil)
534	(calc-leading-zeros nil)
535	(calc-number-radix 10)
536	math-fd-year math-fd-month math-fd-day math-fd-weekday
537	math-fd-hour math-fd-minute math-fd-second
538	(math-fd-bc-flag nil)
539	(fmt (apply 'concat (mapcar 'math-format-date-part
540	calc-date-format))))
541	(setq math-format-date-cache (cons (cons entry fmt)
542	math-format-date-cache))
543	(and (setq math-fd-dt (nthcdr 10 math-format-date-cache))
544	(setcdr math-fd-dt nil))
545	fmt))))
546
547	(defun math-format-date-part (x)
548	(cond ((stringp x)
549	x)
550	((listp x)
551	(if (math-integerp math-fd-date)
552	""
553	(apply 'concat (mapcar 'math-format-date-part x))))
554	((eq x 'X)
555	"")
556	((eq x 'N)
557	(math-format-number math-fd-date))
558	((eq x 'n)
559	(math-format-number (math-floor math-fd-date)))
560	((eq x 'J)
561	(math-format-number (math-add math-fd-date '(float (bigpos 235 214 17) -1))))
562	((eq x 'j)
563	(math-format-number (math-add (math-floor math-fd-date) '(bigpos 424 721 1))))
564	((eq x 'U)
565	(math-format-number (nth 1 (math-date-parts math-fd-date 719164))))
566	((progn
567	(or math-fd-dt
568	(progn
569	(setq math-fd-dt (math-date-to-dt math-fd-date)
570	math-fd-year (car math-fd-dt)
571	math-fd-month (nth 1 math-fd-dt)
572	math-fd-day (nth 2 math-fd-dt)
573	math-fd-weekday (math-mod
574	(math-add (math-floor math-fd-date) 6) 7)
575	math-fd-hour (nth 3 math-fd-dt)
576	math-fd-minute (nth 4 math-fd-dt)
577	math-fd-second (nth 5 math-fd-dt))
578	(and (memq 'b calc-date-format)
579	(math-negp math-fd-year)
580	(setq math-fd-year (math-neg math-fd-year)
581	math-fd-bc-flag t))))
582	(memq x '(Y YY BY)))
583	(if (and (integerp math-fd-year) (> math-fd-year 1940) (< math-fd-year 2040))
584	(format (cond ((eq x 'YY) "%02d")
585	((eq x 'BYY) "%2d")
586	(t "%d"))
587	(% math-fd-year 100))
588	(if (and (natnump math-fd-year) (< math-fd-year 100))
589	(format "+%d" math-fd-year)
590	(math-format-number math-fd-year))))
591	((eq x 'YYY)
592	(math-format-number math-fd-year))
593	((eq x 'YYYY)
594	(if (and (natnump math-fd-year) (< math-fd-year 100))
595	(format "+%d" math-fd-year)
596	(math-format-number math-fd-year)))
597	((eq x 'b) "")
598	((eq x 'aa)
599	(and (not math-fd-bc-flag) "ad"))
600	((eq x 'AA)
601	(and (not math-fd-bc-flag) "AD"))
602	((eq x 'aaa)
603	(and (not math-fd-bc-flag) "ad "))
604	((eq x 'AAA)
605	(and (not math-fd-bc-flag) "AD "))
606	((eq x 'aaaa)
607	(and (not math-fd-bc-flag) "a.d."))
608	((eq x 'AAAA)
609	(and (not math-fd-bc-flag) "A.D."))
610	((eq x 'bb)
611	(and math-fd-bc-flag "bc"))
612	((eq x 'BB)
613	(and math-fd-bc-flag "BC"))
614	((eq x 'bbb)
615	(and math-fd-bc-flag " bc"))
616	((eq x 'BBB)
617	(and math-fd-bc-flag " BC"))
618	((eq x 'bbbb)
619	(and math-fd-bc-flag "b.c."))
620	((eq x 'BBBB)
621	(and math-fd-bc-flag "B.C."))
622	((eq x 'M)
623	(format "%d" math-fd-month))
624	((eq x 'MM)
625	(format "%02d" math-fd-month))
626	((eq x 'BM)
627	(format "%2d" math-fd-month))
628	((eq x 'mmm)
629	(downcase (nth (1- math-fd-month) math-short-month-names)))
630	((eq x 'Mmm)
631	(nth (1- math-fd-month) math-short-month-names))
632	((eq x 'MMM)
633	(upcase (nth (1- math-fd-month) math-short-month-names)))
634	((eq x 'Mmmm)
635	(nth (1- math-fd-month) math-long-month-names))
636	((eq x 'MMMM)
637	(upcase (nth (1- math-fd-month) math-long-month-names)))
638	((eq x 'D)
639	(format "%d" math-fd-day))
640	((eq x 'DD)
641	(format "%02d" math-fd-day))
642	((eq x 'BD)
643	(format "%2d" math-fd-day))
644	((eq x 'W)
645	(format "%d" math-fd-weekday))
646	((eq x 'www)
647	(downcase (nth math-fd-weekday math-short-weekday-names)))
648	((eq x 'Www)
649	(nth math-fd-weekday math-short-weekday-names))
650	((eq x 'WWW)
651	(upcase (nth math-fd-weekday math-short-weekday-names)))
652	((eq x 'Wwww)
653	(nth math-fd-weekday math-long-weekday-names))
654	((eq x 'WWWW)
655	(upcase (nth math-fd-weekday math-long-weekday-names)))
656	((eq x 'd)
657	(format "%d" (math-day-number math-fd-year math-fd-month math-fd-day)))
658	((eq x 'ddd)
659	(format "%03d" (math-day-number math-fd-year math-fd-month math-fd-day)))
660	((eq x 'bdd)
661	(format "%3d" (math-day-number math-fd-year math-fd-month math-fd-day)))
662	((eq x 'h)
663	(and math-fd-hour (format "%d" math-fd-hour)))
664	((eq x 'hh)
665	(and math-fd-hour (format "%02d" math-fd-hour)))
666	((eq x 'bh)
667	(and math-fd-hour (format "%2d" math-fd-hour)))
668	((eq x 'H)
669	(and math-fd-hour (format "%d" (1+ (% (+ math-fd-hour 11) 12)))))
670	((eq x 'HH)
671	(and math-fd-hour (format "%02d" (1+ (% (+ math-fd-hour 11) 12)))))
672	((eq x 'BH)
673	(and math-fd-hour (format "%2d" (1+ (% (+ math-fd-hour 11) 12)))))
674	((eq x 'p)
675	(and math-fd-hour (if (< math-fd-hour 12) "a" "p")))
676	((eq x 'P)
677	(and math-fd-hour (if (< math-fd-hour 12) "A" "P")))
678	((eq x 'pp)
679	(and math-fd-hour (if (< math-fd-hour 12) "am" "pm")))
680	((eq x 'PP)
681	(and math-fd-hour (if (< math-fd-hour 12) "AM" "PM")))
682	((eq x 'pppp)
683	(and math-fd-hour (if (< math-fd-hour 12) "a.m." "p.m.")))
684	((eq x 'PPPP)
685	(and math-fd-hour (if (< math-fd-hour 12) "A.M." "P.M.")))
686	((eq x 'm)
687	(and math-fd-minute (format "%d" math-fd-minute)))
688	((eq x 'mm)
689	(and math-fd-minute (format "%02d" math-fd-minute)))
690	((eq x 'bm)
691	(and math-fd-minute (format "%2d" math-fd-minute)))
692	((eq x 'C)
693	(and math-fd-second (not (math-zerop math-fd-second))
694	":"))
695	((memq x '(s ss bs SS BS))
696	(and math-fd-second
697	(not (and (memq x '(SS BS)) (math-zerop math-fd-second)))
698	(if (integerp math-fd-second)
699	(format (cond ((memq x '(ss SS)) "%02d")
700	((memq x '(bs BS)) "%2d")
701	(t "%d"))
702	math-fd-second)
703	(concat (if (Math-lessp math-fd-second 10)
704	(cond ((memq x '(ss SS)) "0")
705	((memq x '(bs BS)) " ")
706	(t ""))
707	"")
708	(let ((calc-float-format
709	(list 'fix (min (- 12 calc-internal-prec)
710	0))))
711	(math-format-number math-fd-second))))))))
712
713	;; The variable math-pd-str is local to math-parse-date and
714	;; math-parse-standard-date, but is used by math-parse-date-word,
715	;; which is called by math-parse-date and math-parse-standard-date.
716	(defvar math-pd-str)
717
718	(defun math-parse-date (math-pd-str)
719	(catch 'syntax
720	(or (math-parse-standard-date math-pd-str t)
721	(math-parse-standard-date math-pd-str nil)
722	(and (string-match *"\\`[^-+/0-9a-zA-Z]\$[-+]?[0-9]+\\.?[0-9]\\([eE][-+]?[0-9]+\$?\\)[^-+/0-9a-zA-Z]\\'"** math-pd-str)
723	(list 'date (math-read-number (math-match-substring math-pd-str 1))))
724	(let ((case-fold-search t)
725	(year nil) (month nil) (day nil) (weekday nil)
726	(hour nil) (minute nil) (second nil) (bc-flag nil)
727	(a nil) (b nil) (c nil) (bigyear nil) temp)
728
729	;; Extract the time, if any.
730	(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)
731	(string-match *"\$[0-9][0-9]?\$\$\$\$\\(\\(\$\\)\\) \$[ap]\\>\\\|[ap]m\\\|[ap]\\. m\\.\\\|noon\\\|n\\>\\\|midnight\\\|mid\\>\\\|m\\>\$"* math-pd-str))
732	(let ((ampm (math-match-substring math-pd-str 6)))
733	(setq hour (string-to-number (math-match-substring math-pd-str 1))
734	minute (math-match-substring math-pd-str 2)
735	second (math-match-substring math-pd-str 4)
736	math-pd-str (concat (substring math-pd-str 0 (match-beginning 0))
737	(substring math-pd-str (match-end 0))))
738	(if (equal minute "")
739	(setq minute 0)
740	(setq minute (string-to-number minute)))
741	(if (equal second "")
742	(setq second 0)
743	(setq second (math-read-number second)))
744	(if (equal ampm "")
745	(if (> hour 23)
746	(throw 'syntax "Hour value out of range"))
747	(setq ampm (upcase (aref ampm 0)))
748	(if (memq ampm '(?N ?M))
749	(if (and (= hour 12) (= minute 0) (eq second 0))
750	(if (eq ampm ?M) (setq hour 0))
751	(throw 'syntax
752	"Time must be 12:00:00 in this context"))
753	(if (or (= hour 0) (> hour 12))
754	(throw 'syntax "Hour value out of range"))
755	(if (eq (= ampm ?A) (= hour 12))
756	(setq hour (% (+ hour 12) 24)))))))
757
758	;; Rewrite xx-yy-zz to xx/yy/zz to avoid seeing "-" as a minus sign.
759	(while (string-match "[0-9a-zA-Z]\$-\$[0-9a-zA-Z]" math-pd-str)
760	(progn
761	(setq math-pd-str (copy-sequence math-pd-str))
762	(aset math-pd-str (match-beginning 1) ?\/)))
763
764	;; Extract obvious month or weekday names.
765	(if (string-match "[a-zA-Z]" math-pd-str)
766	(progn
767	(setq month (math-parse-date-word math-long-month-names))
768	(setq weekday (math-parse-date-word math-long-weekday-names))
769	(or month (setq month
770	(math-parse-date-word math-short-month-names)))
771	(or weekday (math-parse-date-word math-short-weekday-names))
772	(or hour
773	(if (setq temp (math-parse-date-word
774	'( "noon" "midnight" "mid" )))
775	&