aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJay Belanger2004-11-24 17:59:37 +0000
committerJay Belanger2004-11-24 17:59:37 +0000
commit98223359965fcd64de1d4d08329e7f614680a993 (patch)
treeb05d7c6c41c008d692ea1adfb9f3eb75a22c2e6a
parent0e7acedf7b7777ffc845b504579cef1e5ca1c0fd (diff)
downloademacs-98223359965fcd64de1d4d08329e7f614680a993.tar.gz
emacs-98223359965fcd64de1d4d08329e7f614680a993.zip
(math-fd-date, math-fd-dt, math-fd-year, math-fd-month)
(math-fd-day, math-fd-weekday, math-fd-hour, math-fd-minute) (math-fd-second, math-fd-bc-flag): New variables. (math-format-date, math-format-date-part): Replace variables date, dt, year, month, day, weekday, hour, minute, second and bc-flag by declared variables. (math-pd-str): New variable. (math-parse-date, math-parse-date-word, math-parse-standard-date): Replace variable str by declared variable. (math-daylight-savings-hook, math-tzone-names): Move definitions to earlier in the file. (var-TimeZone): Declare it. (math-exp-str, math-exp-pos): Declare them. (math-sh-year): New variable. (math-setup-add-holidays, math-setup-holidays) (math-setup-year-holiday): Replace variable `year' by declared variable.
-rw-r--r--lisp/calc/calc-forms.el424
1 files changed, 230 insertions, 194 deletions
diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el
index e64983ad33d..146427b761c 100644
--- a/lisp/calc/calc-forms.el
+++ b/lisp/calc/calc-forms.el
@@ -510,181 +510,200 @@
510 510
511 511
512(defvar math-format-date-cache nil) 512(defvar math-format-date-cache nil)
513(defun math-format-date (date) 513
514 (if (eq (car-safe date) 'date) 514;; The variables math-fd-date, math-fd-dt, math-fd-year,
515 (setq date (nth 1 date))) 515;; math-fd-month, math-fd-day, math-fd-weekday, math-fd-hour,
516 (let ((entry (list date calc-internal-prec calc-date-format))) 516;; math-fd-minute, math-fd-second, math-fd-bc-flag are local
517;; to math-format-date, but are used by math-format-date-part,
518;; which is called by math-format-date.
519(defvar math-fd-date)
520(defvar math-fd-dt)
521(defvar math-fd-year)
522(defvar math-fd-month)
523(defvar math-fd-day)
524(defvar math-fd-weekday)
525(defvar math-fd-hour)
526(defvar math-fd-minute)
527(defvar math-fd-second)
528(defvar math-fd-bc-flag)
529
530(defun math-format-date (math-fd-date)
531 (if (eq (car-safe math-fd-date) 'date)
532 (setq math-fd-date (nth 1 math-fd-date)))
533 (let ((entry (list math-fd-date calc-internal-prec calc-date-format)))
517 (or (cdr (assoc entry math-format-date-cache)) 534 (or (cdr (assoc entry math-format-date-cache))
518 (let* ((dt nil) 535 (let* ((math-fd-dt nil)
519 (calc-group-digits nil) 536 (calc-group-digits nil)
520 (calc-leading-zeros nil) 537 (calc-leading-zeros nil)
521 (calc-number-radix 10) 538 (calc-number-radix 10)
522 year month day weekday hour minute second 539 math-fd-year math-fd-month math-fd-day math-fd-weekday
523 (bc-flag nil) 540 math-fd-hour math-fd-minute math-fd-second
541 (math-fd-bc-flag nil)
524 (fmt (apply 'concat (mapcar 'math-format-date-part 542 (fmt (apply 'concat (mapcar 'math-format-date-part
525 calc-date-format)))) 543 calc-date-format))))
526 (setq math-format-date-cache (cons (cons entry fmt) 544 (setq math-format-date-cache (cons (cons entry fmt)
527 math-format-date-cache)) 545 math-format-date-cache))
528 (and (setq dt (nthcdr 10 math-format-date-cache)) 546 (and (setq math-fd-dt (nthcdr 10 math-format-date-cache))
529 (setcdr dt nil)) 547 (setcdr math-fd-dt nil))
530 fmt)))) 548 fmt))))
531 549
532(defun math-format-date-part (x) 550(defun math-format-date-part (x)
533 (cond ((stringp x) 551 (cond ((stringp x)
534 x) 552 x)
535 ((listp x) 553 ((listp x)
536 (if (math-integerp date) 554 (if (math-integerp math-fd-date)
537 "" 555 ""
538 (apply 'concat (mapcar 'math-format-date-part x)))) 556 (apply 'concat (mapcar 'math-format-date-part x))))
539 ((eq x 'X) 557 ((eq x 'X)
540 "") 558 "")
541 ((eq x 'N) 559 ((eq x 'N)
542 (math-format-number date)) 560 (math-format-number math-fd-date))
543 ((eq x 'n) 561 ((eq x 'n)
544 (math-format-number (math-floor date))) 562 (math-format-number (math-floor math-fd-date)))
545 ((eq x 'J) 563 ((eq x 'J)
546 (math-format-number (math-add date '(float (bigpos 235 214 17) -1)))) 564 (math-format-number (math-add math-fd-date '(float (bigpos 235 214 17) -1))))
547 ((eq x 'j) 565 ((eq x 'j)
548 (math-format-number (math-add (math-floor date) '(bigpos 424 721 1)))) 566 (math-format-number (math-add (math-floor math-fd-date) '(bigpos 424 721 1))))
549 ((eq x 'U) 567 ((eq x 'U)
550 (math-format-number (nth 1 (math-date-parts date 719164)))) 568 (math-format-number (nth 1 (math-date-parts math-fd-date 719164))))
551 ((progn 569 ((progn
552 (or dt 570 (or math-fd-dt
553 (progn 571 (progn
554 (setq dt (math-date-to-dt date) 572 (setq math-fd-dt (math-date-to-dt math-fd-date)
555 year (car dt) 573 math-fd-year (car math-fd-dt)
556 month (nth 1 dt) 574 math-fd-month (nth 1 math-fd-dt)
557 day (nth 2 dt) 575 math-fd-day (nth 2 math-fd-dt)
558 weekday (math-mod (math-add (math-floor date) 6) 7) 576 math-fd-weekday (math-mod
559 hour (nth 3 dt) 577 (math-add (math-floor math-fd-date) 6) 7)
560 minute (nth 4 dt) 578 math-fd-hour (nth 3 math-fd-dt)
561 second (nth 5 dt)) 579 math-fd-minute (nth 4 math-fd-dt)
580 math-fd-second (nth 5 math-fd-dt))
562 (and (memq 'b calc-date-format) 581 (and (memq 'b calc-date-format)
563 (math-negp year) 582 (math-negp math-fd-year)
564 (setq year (math-neg year) 583 (setq math-fd-year (math-neg math-fd-year)
565 bc-flag t)))) 584 math-fd-bc-flag t))))
566 (memq x '(Y YY BY))) 585 (memq x '(Y YY BY)))
567 (if (and (integerp year) (> year 1940) (< year 2040)) 586 (if (and (integerp math-fd-year) (> math-fd-year 1940) (< math-fd-year 2040))
568 (format (cond ((eq x 'YY) "%02d") 587 (format (cond ((eq x 'YY) "%02d")
569 ((eq x 'BYY) "%2d") 588 ((eq x 'BYY) "%2d")
570 (t "%d")) 589 (t "%d"))
571 (% year 100)) 590 (% math-fd-year 100))
572 (if (and (natnump year) (< year 100)) 591 (if (and (natnump math-fd-year) (< math-fd-year 100))
573 (format "+%d" year) 592 (format "+%d" math-fd-year)
574 (math-format-number year)))) 593 (math-format-number math-fd-year))))
575 ((eq x 'YYY) 594 ((eq x 'YYY)
576 (math-format-number year)) 595 (math-format-number math-fd-year))
577 ((eq x 'YYYY) 596 ((eq x 'YYYY)
578 (if (and (natnump year) (< year 100)) 597 (if (and (natnump math-fd-year) (< math-fd-year 100))
579 (format "+%d" year) 598 (format "+%d" math-fd-year)
580 (math-format-number year))) 599 (math-format-number math-fd-year)))
581 ((eq x 'b) "") 600 ((eq x 'b) "")
582 ((eq x 'aa) 601 ((eq x 'aa)
583 (and (not bc-flag) "ad")) 602 (and (not math-fd-bc-flag) "ad"))
584 ((eq x 'AA) 603 ((eq x 'AA)
585 (and (not bc-flag) "AD")) 604 (and (not math-fd-bc-flag) "AD"))
586 ((eq x 'aaa) 605 ((eq x 'aaa)
587 (and (not bc-flag) "ad ")) 606 (and (not math-fd-bc-flag) "ad "))
588 ((eq x 'AAA) 607 ((eq x 'AAA)
589 (and (not bc-flag) "AD ")) 608 (and (not math-fd-bc-flag) "AD "))
590 ((eq x 'aaaa) 609 ((eq x 'aaaa)
591 (and (not bc-flag) "a.d.")) 610 (and (not math-fd-bc-flag) "a.d."))
592 ((eq x 'AAAA) 611 ((eq x 'AAAA)
593 (and (not bc-flag) "A.D.")) 612 (and (not math-fd-bc-flag) "A.D."))
594 ((eq x 'bb) 613 ((eq x 'bb)
595 (and bc-flag "bc")) 614 (and math-fd-bc-flag "bc"))
596 ((eq x 'BB) 615 ((eq x 'BB)
597 (and bc-flag "BC")) 616 (and math-fd-bc-flag "BC"))
598 ((eq x 'bbb) 617 ((eq x 'bbb)
599 (and bc-flag " bc")) 618 (and math-fd-bc-flag " bc"))
600 ((eq x 'BBB) 619 ((eq x 'BBB)
601 (and bc-flag " BC")) 620 (and math-fd-bc-flag " BC"))
602 ((eq x 'bbbb) 621 ((eq x 'bbbb)
603 (and bc-flag "b.c.")) 622 (and math-fd-bc-flag "b.c."))
604 ((eq x 'BBBB) 623 ((eq x 'BBBB)
605 (and bc-flag "B.C.")) 624 (and math-fd-bc-flag "B.C."))
606 ((eq x 'M) 625 ((eq x 'M)
607 (format "%d" month)) 626 (format "%d" math-fd-month))
608 ((eq x 'MM) 627 ((eq x 'MM)
609 (format "%02d" month)) 628 (format "%02d" math-fd-month))
610 ((eq x 'BM) 629 ((eq x 'BM)
611 (format "%2d" month)) 630 (format "%2d" math-fd-month))
612 ((eq x 'mmm) 631 ((eq x 'mmm)
613 (downcase (nth (1- month) math-short-month-names))) 632 (downcase (nth (1- math-fd-month) math-short-month-names)))
614 ((eq x 'Mmm) 633 ((eq x 'Mmm)
615 (nth (1- month) math-short-month-names)) 634 (nth (1- math-fd-month) math-short-month-names))
616 ((eq x 'MMM) 635 ((eq x 'MMM)
617 (upcase (nth (1- month) math-short-month-names))) 636 (upcase (nth (1- math-fd-month) math-short-month-names)))
618 ((eq x 'Mmmm) 637 ((eq x 'Mmmm)
619 (nth (1- month) math-long-month-names)) 638 (nth (1- math-fd-month) math-long-month-names))
620 ((eq x 'MMMM) 639 ((eq x 'MMMM)
621 (upcase (nth (1- month) math-long-month-names))) 640 (upcase (nth (1- math-fd-month) math-long-month-names)))
622 ((eq x 'D) 641 ((eq x 'D)
623 (format "%d" day)) 642 (format "%d" math-fd-day))
624 ((eq x 'DD) 643 ((eq x 'DD)
625 (format "%02d" day)) 644 (format "%02d" math-fd-day))
626 ((eq x 'BD) 645 ((eq x 'BD)
627 (format "%2d" day)) 646 (format "%2d" math-fd-day))
628 ((eq x 'W) 647 ((eq x 'W)
629 (format "%d" weekday)) 648 (format "%d" math-fd-weekday))
630 ((eq x 'www) 649 ((eq x 'www)
631 (downcase (nth weekday math-short-weekday-names))) 650 (downcase (nth math-fd-weekday math-short-weekday-names)))
632 ((eq x 'Www) 651 ((eq x 'Www)
633 (nth weekday math-short-weekday-names)) 652 (nth math-fd-weekday math-short-weekday-names))
634 ((eq x 'WWW) 653 ((eq x 'WWW)
635 (upcase (nth weekday math-short-weekday-names))) 654 (upcase (nth math-fd-weekday math-short-weekday-names)))
636 ((eq x 'Wwww) 655 ((eq x 'Wwww)
637 (nth weekday math-long-weekday-names)) 656 (nth math-fd-weekday math-long-weekday-names))
638 ((eq x 'WWWW) 657 ((eq x 'WWWW)
639 (upcase (nth weekday math-long-weekday-names))) 658 (upcase (nth math-fd-weekday math-long-weekday-names)))
640 ((eq x 'd) 659 ((eq x 'd)
641 (format "%d" (math-day-number year month day))) 660 (format "%d" (math-day-number math-fd-year math-fd-month math-fd-day)))
642 ((eq x 'ddd) 661 ((eq x 'ddd)
643 (format "%03d" (math-day-number year month day))) 662 (format "%03d" (math-day-number math-fd-year math-fd-month math-fd-day)))
644 ((eq x 'bdd) 663 ((eq x 'bdd)
645 (format "%3d" (math-day-number year month day))) 664 (format "%3d" (math-day-number math-fd-year math-fd-month math-fd-day)))
646 ((eq x 'h) 665 ((eq x 'h)
647 (and hour (format "%d" hour))) 666 (and math-fd-hour (format "%d" math-fd-hour)))
648 ((eq x 'hh) 667 ((eq x 'hh)
649 (and hour (format "%02d" hour))) 668 (and math-fd-hour (format "%02d" math-fd-hour)))
650 ((eq x 'bh) 669 ((eq x 'bh)
651 (and hour (format "%2d" hour))) 670 (and math-fd-hour (format "%2d" math-fd-hour)))
652 ((eq x 'H) 671 ((eq x 'H)
653 (and hour (format "%d" (1+ (% (+ hour 11) 12))))) 672 (and math-fd-hour (format "%d" (1+ (% (+ math-fd-hour 11) 12)))))
654 ((eq x 'HH) 673 ((eq x 'HH)
655 (and hour (format "%02d" (1+ (% (+ hour 11) 12))))) 674 (and math-fd-hour (format "%02d" (1+ (% (+ math-fd-hour 11) 12)))))
656 ((eq x 'BH) 675 ((eq x 'BH)
657 (and hour (format "%2d" (1+ (% (+ hour 11) 12))))) 676 (and math-fd-hour (format "%2d" (1+ (% (+ math-fd-hour 11) 12)))))
658 ((eq x 'p) 677 ((eq x 'p)
659 (and hour (if (< hour 12) "a" "p"))) 678 (and math-fd-hour (if (< math-fd-hour 12) "a" "p")))
660 ((eq x 'P) 679 ((eq x 'P)
661 (and hour (if (< hour 12) "A" "P"))) 680 (and math-fd-hour (if (< math-fd-hour 12) "A" "P")))
662 ((eq x 'pp) 681 ((eq x 'pp)
663 (and hour (if (< hour 12) "am" "pm"))) 682 (and math-fd-hour (if (< math-fd-hour 12) "am" "pm")))
664 ((eq x 'PP) 683 ((eq x 'PP)
665 (and hour (if (< hour 12) "AM" "PM"))) 684 (and math-fd-hour (if (< math-fd-hour 12) "AM" "PM")))
666 ((eq x 'pppp) 685 ((eq x 'pppp)
667 (and hour (if (< hour 12) "a.m." "p.m."))) 686 (and math-fd-hour (if (< math-fd-hour 12) "a.m." "p.m.")))
668 ((eq x 'PPPP) 687 ((eq x 'PPPP)
669 (and hour (if (< hour 12) "A.M." "P.M."))) 688 (and math-fd-hour (if (< math-fd-hour 12) "A.M." "P.M.")))
670 ((eq x 'm) 689 ((eq x 'm)
671 (and minute (format "%d" minute))) 690 (and math-fd-minute (format "%d" math-fd-minute)))
672 ((eq x 'mm) 691 ((eq x 'mm)
673 (and minute (format "%02d" minute))) 692 (and math-fd-minute (format "%02d" math-fd-minute)))
674 ((eq x 'bm) 693 ((eq x 'bm)
675 (and minute (format "%2d" minute))) 694 (and math-fd-minute (format "%2d" math-fd-minute)))
676 ((eq x 'C) 695 ((eq x 'C)
677 (and second (not (math-zerop second)) 696 (and math-fd-second (not (math-zerop math-fd-second))
678 ":")) 697 ":"))
679 ((memq x '(s ss bs SS BS)) 698 ((memq x '(s ss bs SS BS))
680 (and second 699 (and math-fd-second
681 (not (and (memq x '(SS BS)) (math-zerop second))) 700 (not (and (memq x '(SS BS)) (math-zerop math-fd-second)))
682 (if (integerp second) 701 (if (integerp math-fd-second)
683 (format (cond ((memq x '(ss SS)) "%02d") 702 (format (cond ((memq x '(ss SS)) "%02d")
684 ((memq x '(bs BS)) "%2d") 703 ((memq x '(bs BS)) "%2d")
685 (t "%d")) 704 (t "%d"))
686 second) 705 math-fd-second)
687 (concat (if (Math-lessp second 10) 706 (concat (if (Math-lessp math-fd-second 10)
688 (cond ((memq x '(ss SS)) "0") 707 (cond ((memq x '(ss SS)) "0")
689 ((memq x '(bs BS)) " ") 708 ((memq x '(bs BS)) " ")
690 (t "")) 709 (t ""))
@@ -692,29 +711,33 @@
692 (let ((calc-float-format 711 (let ((calc-float-format
693 (list 'fix (min (- 12 calc-internal-prec) 712 (list 'fix (min (- 12 calc-internal-prec)
694 0)))) 713 0))))
695 (math-format-number second)))))))) 714 (math-format-number math-fd-second))))))))
696 715
716;; The variable math-pd-str is local to math-parse-date and
717;; math-parse-standard-date, but is used by math-parse-date-word,
718;; which is called by math-parse-date and math-parse-standard-date.
719(defvar math-pd-str)
697 720
698(defun math-parse-date (str) 721(defun math-parse-date (math-pd-str)
699 (catch 'syntax 722 (catch 'syntax
700 (or (math-parse-standard-date str t) 723 (or (math-parse-standard-date math-pd-str t)
701 (math-parse-standard-date str nil) 724 (math-parse-standard-date math-pd-str nil)
702 (and (string-match "\\`[^-+/0-9a-zA-Z]*\\([-+]?[0-9]+\\.?[0-9]*\\([eE][-+]?[0-9]+\\)?\\)[^-+/0-9a-zA-Z]*\\'" str) 725 (and (string-match "\\`[^-+/0-9a-zA-Z]*\\([-+]?[0-9]+\\.?[0-9]*\\([eE][-+]?[0-9]+\\)?\\)[^-+/0-9a-zA-Z]*\\'" math-pd-str)
703 (list 'date (math-read-number (math-match-substring str 1)))) 726 (list 'date (math-read-number (math-match-substring math-pd-str 1))))
704 (let ((case-fold-search t) 727 (let ((case-fold-search t)
705 (year nil) (month nil) (day nil) (weekday nil) 728 (year nil) (month nil) (day nil) (weekday nil)
706 (hour nil) (minute nil) (second nil) (bc-flag nil) 729 (hour nil) (minute nil) (second nil) (bc-flag nil)
707 (a nil) (b nil) (c nil) (bigyear nil) temp) 730 (a nil) (b nil) (c nil) (bigyear nil) temp)
708 731
709 ;; Extract the time, if any. 732 ;; Extract the time, if any.
710 (if (or (string-match "\\([0-9][0-9]?\\):\\([0-9][0-9]?\\)\\(:\\([0-9][0-9]?\\(\\.[0-9]+\\)?\\)\\)? *\\([ap]m?\\|[ap]\\. *m\\.\\|noon\\|n\\>\\|midnight\\|mid\\>\\|m\\>\\)?" str) 733 (if (or (string-match "\\([0-9][0-9]?\\):\\([0-9][0-9]?\\)\\(:\\([0-9][0-9]?\\(\\.[0-9]+\\)?\\)\\)? *\\([ap]m?\\|[ap]\\. *m\\.\\|noon\\|n\\>\\|midnight\\|mid\\>\\|m\\>\\)?" math-pd-str)
711 (string-match "\\([0-9][0-9]?\\)\\(\\)\\(\\(\\(\\)\\)\\) *\\([ap]m?\\|[ap]\\. *m\\.\\|noon\\|n\\>\\|midnight\\|mid\\>\\|m\\>\\)" str)) 734 (string-match "\\([0-9][0-9]?\\)\\(\\)\\(\\(\\(\\)\\)\\) *\\([ap]m?\\|[ap]\\. *m\\.\\|noon\\|n\\>\\|midnight\\|mid\\>\\|m\\>\\)" math-pd-str))
712 (let ((ampm (math-match-substring str 6))) 735 (let ((ampm (math-match-substring math-pd-str 6)))
713 (setq hour (string-to-int (math-match-substring str 1)) 736 (setq hour (string-to-int (math-match-substring math-pd-str 1))
714 minute (math-match-substring str 2) 737 minute (math-match-substring math-pd-str 2)
715 second (math-match-substring str 4) 738 second (math-match-substring math-pd-str 4)
716 str (concat (substring str 0 (match-beginning 0)) 739 math-pd-str (concat (substring math-pd-str 0 (match-beginning 0))
717 (substring str (match-end 0)))) 740 (substring math-pd-str (match-end 0))))
718 (if (equal minute "") 741 (if (equal minute "")
719 (setq minute 0) 742 (setq minute 0)
720 (setq minute (string-to-int minute))) 743 (setq minute (string-to-int minute)))
@@ -736,13 +759,13 @@
736 (setq hour (% (+ hour 12) 24))))))) 759 (setq hour (% (+ hour 12) 24)))))))
737 760
738 ;; Rewrite xx-yy-zz to xx/yy/zz to avoid seeing "-" as a minus sign. 761 ;; Rewrite xx-yy-zz to xx/yy/zz to avoid seeing "-" as a minus sign.
739 (while (string-match "[0-9a-zA-Z]\\(-\\)[0-9a-zA-Z]" str) 762 (while (string-match "[0-9a-zA-Z]\\(-\\)[0-9a-zA-Z]" math-pd-str)
740 (progn 763 (progn
741 (setq str (copy-sequence str)) 764 (setq math-pd-str (copy-sequence math-pd-str))
742 (aset str (match-beginning 1) ?\/))) 765 (aset math-pd-str (match-beginning 1) ?\/)))
743 766
744 ;; Extract obvious month or weekday names. 767 ;; Extract obvious month or weekday names.
745 (if (string-match "[a-zA-Z]" str) 768 (if (string-match "[a-zA-Z]" math-pd-str)
746 (progn 769 (progn
747 (setq month (math-parse-date-word math-long-month-names)) 770 (setq month (math-parse-date-word math-long-month-names))
748 (setq weekday (math-parse-date-word math-long-weekday-names)) 771 (setq weekday (math-parse-date-word math-long-weekday-names))
@@ -756,31 +779,32 @@
756 (or (math-parse-date-word '( "ad" "a.d." )) 779 (or (math-parse-date-word '( "ad" "a.d." ))
757 (if (math-parse-date-word '( "bc" "b.c." )) 780 (if (math-parse-date-word '( "bc" "b.c." ))
758 (setq bc-flag t))) 781 (setq bc-flag t)))
759 (if (string-match "[a-zA-Z]+" str) 782 (if (string-match "[a-zA-Z]+" math-pd-str)
760 (throw 'syntax (format "Bad word in date: \"%s\"" 783 (throw 'syntax (format "Bad word in date: \"%s\""
761 (math-match-substring str 0)))))) 784 (math-match-substring math-pd-str 0))))))
762 785
763 ;; If there is a huge number other than the year, ignore it. 786 ;; If there is a huge number other than the year, ignore it.
764 (while (and (string-match "[-+]?0*[1-9][0-9][0-9][0-9][0-9]+" str) 787 (while (and (string-match "[-+]?0*[1-9][0-9][0-9][0-9][0-9]+" math-pd-str)
765 (setq temp (concat (substring str 0 (match-beginning 0)) 788 (setq temp (concat (substring math-pd-str 0 (match-beginning 0))
766 (substring str (match-end 0)))) 789 (substring math-pd-str (match-end 0))))
767 (string-match "[4-9][0-9]\\|[0-9][0-9][0-9]\\|[-+][0-9]+[^-]*\\'" temp)) 790 (string-match
768 (setq str temp)) 791 "[4-9][0-9]\\|[0-9][0-9][0-9]\\|[-+][0-9]+[^-]*\\'" temp))
792 (setq math-pd-str temp))
769 793
770 ;; If there is a number with a sign or a large number, it is a year. 794 ;; If there is a number with a sign or a large number, it is a year.
771 (if (or (string-match "\\([-+][0-9]+\\)[^-]*\\'" str) 795 (if (or (string-match "\\([-+][0-9]+\\)[^-]*\\'" math-pd-str)
772 (string-match "\\(0*[1-9][0-9][0-9]+\\)" str)) 796 (string-match "\\(0*[1-9][0-9][0-9]+\\)" math-pd-str))
773 (setq year (math-match-substring str 1) 797 (setq year (math-match-substring math-pd-str 1)
774 str (concat (substring str 0 (match-beginning 1)) 798 math-pd-str (concat (substring math-pd-str 0 (match-beginning 1))
775 (substring str (match-end 1))) 799 (substring math-pd-str (match-end 1)))
776 year (math-read-number year) 800 year (math-read-number year)
777 bigyear t)) 801 bigyear t))
778 802
779 ;; Collect remaining numbers. 803 ;; Collect remaining numbers.
780 (setq temp 0) 804 (setq temp 0)
781 (while (string-match "[0-9]+" str temp) 805 (while (string-match "[0-9]+" math-pd-str temp)
782 (and c (throw 'syntax "Too many numbers in date")) 806 (and c (throw 'syntax "Too many numbers in date"))
783 (setq c (string-to-int (math-match-substring str 0))) 807 (setq c (string-to-int (math-match-substring math-pd-str 0)))
784 (or b (setq b c c nil)) 808 (or b (setq b c c nil))
785 (or a (setq a b b nil)) 809 (or a (setq a b b nil))
786 (setq temp (match-end 0))) 810 (setq temp (match-end 0)))
@@ -867,18 +891,18 @@
867 (while (and names (not (string-match (if (equal (car names) "Sep") 891 (while (and names (not (string-match (if (equal (car names) "Sep")
868 "Sept?" 892 "Sept?"
869 (regexp-quote (car names))) 893 (regexp-quote (car names)))
870 str))) 894 math-pd-str)))
871 (setq names (cdr names) 895 (setq names (cdr names)
872 n (1+ n))) 896 n (1+ n)))
873 (and names 897 (and names
874 (or (not front) (= (match-beginning 0) 0)) 898 (or (not front) (= (match-beginning 0) 0))
875 (progn 899 (progn
876 (setq str (concat (substring str 0 (match-beginning 0)) 900 (setq math-pd-str (concat (substring math-pd-str 0 (match-beginning 0))
877 (if front "" " ") 901 (if front "" " ")
878 (substring str (match-end 0)))) 902 (substring math-pd-str (match-end 0))))
879 n)))) 903 n))))
880 904
881(defun math-parse-standard-date (str with-time) 905(defun math-parse-standard-date (math-pd-str with-time)
882 (let ((case-fold-search t) 906 (let ((case-fold-search t)
883 (okay t) num 907 (okay t) num
884 (fmt calc-date-format) this next (gnext nil) 908 (fmt calc-date-format) this next (gnext nil)
@@ -898,16 +922,16 @@
898 (setq gnext fmt 922 (setq gnext fmt
899 fmt this))) 923 fmt this)))
900 ((stringp this) 924 ((stringp this)
901 (if (and (<= (length this) (length str)) 925 (if (and (<= (length this) (length math-pd-str))
902 (equal this 926 (equal this
903 (substring str 0 (length this)))) 927 (substring math-pd-str 0 (length this))))
904 (setq str (substring str (length this))))) 928 (setq math-pd-str (substring math-pd-str (length this)))))
905 ((eq this 'X) 929 ((eq this 'X)
906 t) 930 t)
907 ((memq this '(n N j J)) 931 ((memq this '(n N j J))
908 (and (string-match "\\`[-+]?[0-9.]+\\([eE][-+]?[0-9]+\\)?" str) 932 (and (string-match "\\`[-+]?[0-9.]+\\([eE][-+]?[0-9]+\\)?" math-pd-str)
909 (setq num (math-match-substring str 0) 933 (setq num (math-match-substring math-pd-str 0)
910 str (substring str (match-end 0)) 934 math-pd-str (substring math-pd-str (match-end 0))
911 num (math-date-to-dt (math-read-number num)) 935 num (math-date-to-dt (math-read-number num))
912 num (math-sub num 936 num (math-sub num
913 (if (memq this '(n N)) 937 (if (memq this '(n N))
@@ -924,9 +948,9 @@
924 month (nth 1 num) 948 month (nth 1 num)
925 day (nth 2 num)))) 949 day (nth 2 num))))
926 ((eq this 'U) 950 ((eq this 'U)
927 (and (string-match "\\`[-+]?[0-9]+" str) 951 (and (string-match "\\`[-+]?[0-9]+" math-pd-str)
928 (setq num (math-match-substring str 0) 952 (setq num (math-match-substring math-pd-str 0)
929 str (substring str (match-end 0)) 953 math-pd-str (substring math-pd-str (match-end 0))
930 num (math-date-to-dt 954 num (math-date-to-dt
931 (math-add 719164 955 (math-add 719164
932 (math-div (math-read-number num) 956 (math-div (math-read-number num)
@@ -946,63 +970,63 @@
946 ((memq this '(Wwww WWWW)) 970 ((memq this '(Wwww WWWW))
947 (math-parse-date-word math-long-weekday-names t)) 971 (math-parse-date-word math-long-weekday-names t))
948 ((memq this '(p P)) 972 ((memq this '(p P))
949 (if (string-match "\\`a" str) 973 (if (string-match "\\`a" math-pd-str)
950 (setq hour (if (= hour 12) 0 hour) 974 (setq hour (if (= hour 12) 0 hour)
951 str (substring str 1)) 975 math-pd-str (substring math-pd-str 1))
952 (if (string-match "\\`p" str) 976 (if (string-match "\\`p" math-pd-str)
953 (setq hour (if (= hour 12) 12 (% (+ hour 12) 24)) 977 (setq hour (if (= hour 12) 12 (% (+ hour 12) 24))
954 str (substring str 1))))) 978 math-pd-str (substring math-pd-str 1)))))
955 ((memq this '(pp PP pppp PPPP)) 979 ((memq this '(pp PP pppp PPPP))
956 (if (string-match "\\`am\\|a\\.m\\." str) 980 (if (string-match "\\`am\\|a\\.m\\." math-pd-str)
957 (setq hour (if (= hour 12) 0 hour) 981 (setq hour (if (= hour 12) 0 hour)
958 str (substring str (match-end 0))) 982 math-pd-str (substring math-pd-str (match-end 0)))
959 (if (string-match "\\`pm\\|p\\.m\\." str) 983 (if (string-match "\\`pm\\|p\\.m\\." math-pd-str)
960 (setq hour (if (= hour 12) 12 (% (+ hour 12) 24)) 984 (setq hour (if (= hour 12) 12 (% (+ hour 12) 24))
961 str (substring str (match-end 0)))))) 985 math-pd-str (substring math-pd-str (match-end 0))))))
962 ((memq this '(Y YY BY YYY YYYY)) 986 ((memq this '(Y YY BY YYY YYYY))
963 (and (if (memq next '(MM DD ddd hh HH mm ss SS)) 987 (and (if (memq next '(MM DD ddd hh HH mm ss SS))
964 (if (memq this '(Y YY BYY)) 988 (if (memq this '(Y YY BYY))
965 (string-match "\\` *[0-9][0-9]" str) 989 (string-match "\\` *[0-9][0-9]" math-pd-str)
966 (string-match "\\`[0-9][0-9][0-9][0-9]" str)) 990 (string-match "\\`[0-9][0-9][0-9][0-9]" math-pd-str))
967 (string-match "\\`[-+]?[0-9]+" str)) 991 (string-match "\\`[-+]?[0-9]+" math-pd-str))
968 (setq year (math-match-substring str 0) 992 (setq year (math-match-substring math-pd-str 0)
969 bigyear (or (eq this 'YYY) 993 bigyear (or (eq this 'YYY)
970 (memq (aref str 0) '(?\+ ?\-))) 994 (memq (aref math-pd-str 0) '(?\+ ?\-)))
971 str (substring str (match-end 0)) 995 math-pd-str (substring math-pd-str (match-end 0))
972 year (math-read-number year)))) 996 year (math-read-number year))))
973 ((eq this 'b) 997 ((eq this 'b)
974 t) 998 t)
975 ((memq this '(aa AA aaaa AAAA)) 999 ((memq this '(aa AA aaaa AAAA))
976 (if (string-match "\\` *\\(ad\\|a\\.d\\.\\)" str) 1000 (if (string-match "\\` *\\(ad\\|a\\.d\\.\\)" math-pd-str)
977 (setq str (substring str (match-end 0))))) 1001 (setq math-pd-str (substring math-pd-str (match-end 0)))))
978 ((memq this '(aaa AAA)) 1002 ((memq this '(aaa AAA))
979 (if (string-match "\\` *ad *" str) 1003 (if (string-match "\\` *ad *" math-pd-str)
980 (setq str (substring str (match-end 0))))) 1004 (setq math-pd-str (substring math-pd-str (match-end 0)))))
981 ((memq this '(bb BB bbb BBB bbbb BBBB)) 1005 ((memq this '(bb BB bbb BBB bbbb BBBB))
982 (if (string-match "\\` *\\(bc\\|b\\.c\\.\\)" str) 1006 (if (string-match "\\` *\\(bc\\|b\\.c\\.\\)" math-pd-str)
983 (setq str (substring str (match-end 0)) 1007 (setq math-pd-str (substring math-pd-str (match-end 0))
984 bc-flag t))) 1008 bc-flag t)))
985 ((memq this '(s ss bs SS BS)) 1009 ((memq this '(s ss bs SS BS))
986 (and (if (memq next '(YY YYYY MM DD hh HH mm)) 1010 (and (if (memq next '(YY YYYY MM DD hh HH mm))
987 (string-match "\\` *[0-9][0-9]\\(\\.[0-9]+\\)?" str) 1011 (string-match "\\` *[0-9][0-9]\\(\\.[0-9]+\\)?" math-pd-str)
988 (string-match "\\` *[0-9][0-9]?\\(\\.[0-9]+\\)?" str)) 1012 (string-match "\\` *[0-9][0-9]?\\(\\.[0-9]+\\)?" math-pd-str))
989 (setq second (math-match-substring str 0) 1013 (setq second (math-match-substring math-pd-str 0)
990 str (substring str (match-end 0)) 1014 math-pd-str (substring math-pd-str (match-end 0))
991 second (math-read-number second)))) 1015 second (math-read-number second))))
992 ((eq this 'C) 1016 ((eq this 'C)
993 (if (string-match "\\`:[0-9][0-9]" str) 1017 (if (string-match "\\`:[0-9][0-9]" math-pd-str)
994 (setq str (substring str 1)) 1018 (setq math-pd-str (substring math-pd-str 1))
995 t)) 1019 t))
996 ((or (not (if (and (memq this '(ddd MM DD hh HH mm)) 1020 ((or (not (if (and (memq this '(ddd MM DD hh HH mm))
997 (memq next '(YY YYYY MM DD ddd 1021 (memq next '(YY YYYY MM DD ddd
998 hh HH mm ss SS))) 1022 hh HH mm ss SS)))
999 (if (eq this 'ddd) 1023 (if (eq this 'ddd)
1000 (string-match "\\` *[0-9][0-9][0-9]" str) 1024 (string-match "\\` *[0-9][0-9][0-9]" math-pd-str)
1001 (string-match "\\` *[0-9][0-9]" str)) 1025 (string-match "\\` *[0-9][0-9]" math-pd-str))
1002 (string-match "\\` *[0-9]+" str))) 1026 (string-match "\\` *[0-9]+" math-pd-str)))
1003 (and (setq num (string-to-int 1027 (and (setq num (string-to-int
1004 (math-match-substring str 0)) 1028 (math-match-substring math-pd-str 0))
1005 str (substring str (match-end 0))) 1029 math-pd-str (substring math-pd-str (match-end 0)))
1006 nil)) 1030 nil))
1007 nil) 1031 nil)
1008 ((eq this 'W) 1032 ((eq this 'W)
@@ -1022,7 +1046,7 @@
1022 (if (and month day) 1046 (if (and month day)
1023 (setq yearday nil) 1047 (setq yearday nil)
1024 (setq month 1 day 1))) 1048 (setq month 1 day 1)))
1025 (if (and okay (equal str "")) 1049 (if (and okay (equal math-pd-str ""))
1026 (and month day (or (not (or hour minute second)) 1050 (and month day (or (not (or hour minute second))
1027 (and hour minute)) 1051 (and hour minute))
1028 (progn 1052 (progn
@@ -1148,6 +1172,30 @@
1148 (calcFunc-tzone zone date)) 1172 (calcFunc-tzone zone date))
1149 (math-reject-arg date 'datep)))) 1173 (math-reject-arg date 'datep))))
1150 1174
1175
1176;;; Note: Longer names must appear before shorter names which are
1177;;; substrings of them.
1178(defvar math-tzone-names
1179 '(( "UTC" 0 0)
1180 ( "MEGT" -1 "MET" "METDST" ) ; Middle Europe
1181 ( "METDST" -1 -1 ) ( "MET" -1 0 )
1182 ( "MEGZ" -1 "MEZ" "MESZ" ) ( "MEZ" -1 0 ) ( "MESZ" -1 -1 )
1183 ( "WEGT" 0 "WET" "WETDST" ) ; Western Europe
1184 ( "WETDST" 0 -1 ) ( "WET" 0 0 )
1185 ( "BGT" 0 "GMT" "BST" ) ( "GMT" 0 0 ) ( "BST" 0 -1 ) ; Britain
1186 ( "NGT" (float 35 -1) "NST" "NDT" ) ; Newfoundland
1187 ( "NST" (float 35 -1) 0 ) ( "NDT" (float 35 -1) -1 )
1188 ( "AGT" 4 "AST" "ADT" ) ( "AST" 4 0 ) ( "ADT" 4 -1 ) ; Atlantic
1189 ( "EGT" 5 "EST" "EDT" ) ( "EST" 5 0 ) ( "EDT" 5 -1 ) ; Eastern
1190 ( "CGT" 6 "CST" "CDT" ) ( "CST" 6 0 ) ( "CDT" 6 -1 ) ; Central
1191 ( "MGT" 7 "MST" "MDT" ) ( "MST" 7 0 ) ( "MDT" 7 -1 ) ; Mountain
1192 ( "PGT" 8 "PST" "PDT" ) ( "PST" 8 0 ) ( "PDT" 8 -1 ) ; Pacific
1193 ( "YGT" 9 "YST" "YDT" ) ( "YST" 9 0 ) ( "YDT" 9 -1 ) ; Yukon
1194 )
1195 "No doc yet. See calc manual for now. ")
1196
1197(defvar var-TimeZone)
1198
1151(defun calcFunc-tzone (&optional zone date) 1199(defun calcFunc-tzone (&optional zone date)
1152 (if zone 1200 (if zone
1153 (cond ((math-realp zone) 1201 (cond ((math-realp zone)
@@ -1226,27 +1274,7 @@
1226 (calc-refresh-evaltos 'var-TimeZone) 1274 (calc-refresh-evaltos 'var-TimeZone)
1227 (calcFunc-tzone tz date))))) 1275 (calcFunc-tzone tz date)))))
1228 1276
1229;;; Note: Longer names must appear before shorter names which are 1277(defvar math-daylight-savings-hook 'math-std-daylight-savings)
1230;;; substrings of them.
1231(defvar math-tzone-names
1232 '(( "UTC" 0 0)
1233 ( "MEGT" -1 "MET" "METDST" ) ; Middle Europe
1234 ( "METDST" -1 -1 ) ( "MET" -1 0 )
1235 ( "MEGZ" -1 "MEZ" "MESZ" ) ( "MEZ" -1 0 ) ( "MESZ" -1 -1 )
1236 ( "WEGT" 0 "WET" "WETDST" ) ; Western Europe
1237 ( "WETDST" 0 -1 ) ( "WET" 0 0 )
1238 ( "BGT" 0 "GMT" "BST" ) ( "GMT" 0 0 ) ( "BST" 0 -1 ) ; Britain
1239 ( "NGT" (float 35 -1) "NST" "NDT" ) ; Newfoundland
1240 ( "NST" (float 35 -1) 0 ) ( "NDT" (float 35 -1) -1 )
1241 ( "AGT" 4 "AST" "ADT" ) ( "AST" 4 0 ) ( "ADT" 4 -1 ) ; Atlantic
1242 ( "EGT" 5 "EST" "EDT" ) ( "EST" 5 0 ) ( "EDT" 5 -1 ) ; Eastern
1243 ( "CGT" 6 "CST" "CDT" ) ( "CST" 6 0 ) ( "CDT" 6 -1 ) ; Central
1244 ( "MGT" 7 "MST" "MDT" ) ( "MST" 7 0 ) ( "MDT" 7 -1 ) ; Mountain
1245 ( "PGT" 8 "PST" "PDT" ) ( "PST" 8 0 ) ( "PDT" 8 -1 ) ; Pacific
1246 ( "YGT" 9 "YST" "YDT" ) ( "YST" 9 0 ) ( "YDT" 9 -1 ) ; Yukon
1247 )
1248 "No doc yet. See calc manual for now. ")
1249
1250 1278
1251(defun math-daylight-savings-adjust (date zone &optional dt) 1279(defun math-daylight-savings-adjust (date zone &optional dt)
1252 (or date (setq date (nth 1 (calcFunc-now)))) 1280 (or date (setq date (nth 1 (calcFunc-now))))
@@ -1286,8 +1314,6 @@
1286 (nth 1 (calcFunc-tzconv (list 'date date) z1 z2)) 1314 (nth 1 (calcFunc-tzconv (list 'date date) z1 z2))
1287 (calcFunc-unixtime (calcFunc-unixtime date z1) z2))) 1315 (calcFunc-unixtime (calcFunc-unixtime date z1) z2)))
1288 1316
1289(defvar math-daylight-savings-hook 'math-std-daylight-savings)
1290
1291(defun math-std-daylight-savings (date dt zone bump) 1317(defun math-std-daylight-savings (date dt zone bump)
1292 "Standard North American daylight savings algorithm. 1318 "Standard North American daylight savings algorithm.
1293This implements the rules for the U.S. and Canada as of 1987. 1319This implements the rules for the U.S. and Canada as of 1987.
@@ -1507,6 +1533,10 @@ and ends on the last Sunday of October at 2 a.m."
1507 (and (not (math-setup-holidays day)) 1533 (and (not (math-setup-holidays day))
1508 (list 'date (math-add day time)))))) 1534 (list 'date (math-add day time))))))
1509 1535
1536;; The variable math-sh-year is local to math-setup-holidays
1537;; and math-setup-year-holiday, but is used by math-setup-add-holidays,
1538;; which is called by math-setup-holidays and math-setup-year-holiday.
1539(defvar math-sh-year)
1510 1540
1511(defun math-setup-holidays (&optional date) 1541(defun math-setup-holidays (&optional date)
1512 (or (eq (calc-var-value 'var-Holidays) math-holidays-cache-tag) 1542 (or (eq (calc-var-value 'var-Holidays) math-holidays-cache-tag)
@@ -1581,7 +1611,7 @@ and ends on the last Sunday of October at 2 a.m."
1581 (unwind-protect 1611 (unwind-protect
1582 (let ((days (nth 6 math-holidays-cache))) 1612 (let ((days (nth 6 math-holidays-cache)))
1583 (if days 1613 (if days
1584 (let ((year nil)) ; see below 1614 (let ((math-sh-year nil)) ; see below
1585 (setcar (nthcdr 6 math-holidays-cache) nil) 1615 (setcar (nthcdr 6 math-holidays-cache) nil)
1586 (math-setup-add-holidays (cons 'vec (cdr days))) 1616 (math-setup-add-holidays (cons 'vec (cdr days)))
1587 (setcar (nthcdr 2 math-holidays-cache) (car days)))) 1617 (setcar (nthcdr 2 math-holidays-cache) (car days))))
@@ -1613,10 +1643,10 @@ and ends on the last Sunday of October at 2 a.m."
1613 nil))) 1643 nil)))
1614 (or done (setq math-holidays-cache-tag t)))))) 1644 (or done (setq math-holidays-cache-tag t))))))
1615 1645
1616(defun math-setup-year-holidays (year) 1646(defun math-setup-year-holidays (math-sh-year)
1617 (let ((exprs (nth 2 math-holidays-cache))) 1647 (let ((exprs (nth 2 math-holidays-cache)))
1618 (while exprs 1648 (while exprs
1619 (let* ((var-y year) 1649 (let* ((var-y math-sh-year)
1620 (var-m nil) 1650 (var-m nil)
1621 (expr (math-evaluate-expr (car exprs)))) 1651 (expr (math-evaluate-expr (car exprs))))
1622 (if (math-expr-contains expr '(var m var-m)) 1652 (if (math-expr-contains expr '(var m var-m))
@@ -1626,7 +1656,7 @@ and ends on the last Sunday of October at 2 a.m."
1626 (math-setup-add-holidays expr))) 1656 (math-setup-add-holidays expr)))
1627 (setq exprs (cdr exprs))))) 1657 (setq exprs (cdr exprs)))))
1628 1658
1629(defun math-setup-add-holidays (days) ; uses "year" 1659(defun math-setup-add-holidays (days) ; uses "math-sh-year"
1630 (cond ((eq (car-safe days) 'vec) 1660 (cond ((eq (car-safe days) 'vec)
1631 (while (setq days (cdr days)) 1661 (while (setq days (cdr days))
1632 (math-setup-add-holidays (car days)))) 1662 (math-setup-add-holidays (car days))))
@@ -1641,7 +1671,7 @@ and ends on the last Sunday of October at 2 a.m."
1641 (math-setup-add-holidays (nth 1 days))) 1671 (math-setup-add-holidays (nth 1 days)))
1642 ((eq days 0)) 1672 ((eq days 0))
1643 ((integerp days) 1673 ((integerp days)
1644 (let ((b (math-to-business-day days year))) 1674 (let ((b (math-to-business-day days math-sh-year)))
1645 (or (cdr b) ; don't register holidays twice! 1675 (or (cdr b) ; don't register holidays twice!
1646 (let ((prev (car math-holidays-cache)) 1676 (let ((prev (car math-holidays-cache))
1647 (iprev (nth 1 math-holidays-cache))) 1677 (iprev (nth 1 math-holidays-cache)))
@@ -1789,6 +1819,12 @@ and ends on the last Sunday of October at 2 a.m."
1789 (t 1819 (t
1790 (math-make-intv 2 0 b))))) 1820 (math-make-intv 2 0 b)))))
1791 1821
1822;; The variables math-exp-str and math-exp-pos are local to
1823;; math-read-exprs in math-aent.el, but are used by
1824;; math-read-angle-brackets, which is called (indirectly) by
1825;; math-read-exprs.
1826(defvar math-exp-str)
1827(defvar math-exp-pos)
1792 1828
1793(defun math-read-angle-brackets () 1829(defun math-read-angle-brackets ()
1794 (let* ((last (or (math-check-for-commas t) (length math-exp-str))) 1830 (let* ((last (or (math-check-for-commas t) (length math-exp-str)))