Mercurial > emacs

comparison lisp/calc/calc-forms.el @ 88155:d7ddb3e565de

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
sync with trunk
author Henrik Enberg <henrik.enberg@telia.com>
date Mon, 16 Jan 2006 00:03:54 +0000
parents 0d8b17d428b5
children
comparison
equal deleted inserted replaced
88154:8ce476d3ba36 88155:d7ddb3e565de
1 ;;; calc-forms.el --- data format conversion functions for Calc 1 ;;; calc-forms.el --- data format conversion functions for Calc
2 2
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. 3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
4 ;; 2005 Free Software Foundation, Inc.
4 5
5 ;; Author: David Gillespie <daveg@synaptics.com> 6 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainers: D. Goel <deego@gnufans.org> 7 ;; Maintainer: Jay Belanger <belanger@truman.edu>
7 ;; Colin Walters <walters@debian.org>
8 8
9 ;; This file is part of GNU Emacs. 9 ;; This file is part of GNU Emacs.
10 10
11 ;; GNU Emacs is distributed in the hope that it will be useful, 11 ;; GNU Emacs is distributed in the hope that it will be useful,
12 ;; but WITHOUT ANY WARRANTY. No author or distributor 12 ;; but WITHOUT ANY WARRANTY. No author or distributor
26 ;;; Commentary: 26 ;;; Commentary:
27 27
28 ;;; Code: 28 ;;; Code:
29 29
30 ;; This file is autoloaded from calc-ext.el. 30 ;; This file is autoloaded from calc-ext.el.
31
31 (require 'calc-ext) 32 (require 'calc-ext)
32
33 (require 'calc-macs) 33 (require 'calc-macs)
34
35 (defun calc-Need-calc-forms () nil)
36
37 34
38 (defun calc-time () 35 (defun calc-time ()
39 (interactive) 36 (interactive)
40 (calc-wrapper 37 (calc-wrapper
41 (let ((time (current-time-string))) 38 (let ((time (current-time-string)))
42 (calc-enter-result 0 "time" 39 (calc-enter-result 0 "time"
43 (list 'mod 40 (list 'mod
44 (list 'hms 41 (list 'hms
45 (string-to-int (substring time 11 13)) 42 (string-to-number (substring time 11 13))
46 (string-to-int (substring time 14 16)) 43 (string-to-number (substring time 14 16))
47 (string-to-int (substring time 17 19))) 44 (string-to-number (substring time 17 19)))
48 (list 'hms 24 0 0)))))) 45 (list 'hms 24 0 0))))))
49 46
50 (defun calc-to-hms (arg) 47 (defun calc-to-hms (arg)
51 (interactive "P") 48 (interactive "P")
52 (calc-wrapper 49 (calc-wrapper
81 (interactive "sDate format (e.g., M/D/YY h:mm:ss): \nP") 78 (interactive "sDate format (e.g., M/D/YY h:mm:ss): \nP")
82 (calc-wrapper 79 (calc-wrapper
83 (if (equal fmt "") 80 (if (equal fmt "")
84 (setq fmt "1")) 81 (setq fmt "1"))
85 (if (string-match "\\` *[0-9] *\\'" fmt) 82 (if (string-match "\\` *[0-9] *\\'" fmt)
86 (setq fmt (nth (string-to-int fmt) calc-standard-date-formats))) 83 (setq fmt (nth (string-to-number fmt) calc-standard-date-formats)))
87 (or (string-match "[a-zA-Z]" fmt) 84 (or (string-match "[a-zA-Z]" fmt)
88 (error "Bad date format specifier")) 85 (error "Bad date format specifier"))
89 (and arg 86 (and arg
90 (>= (setq arg (prefix-numeric-value arg)) 0) 87 (>= (setq arg (prefix-numeric-value arg)) 0)
91 (<= arg 9) 88 (<= arg 9)
210 (or new 207 (or new
211 (setq new (read-string (concat "From time zone: " old 208 (setq new (read-string (concat "From time zone: " old
212 ", to zone: ")))) 209 ", to zone: "))))
213 (if (stringp old) (setq old (math-read-expr old))) 210 (if (stringp old) (setq old (math-read-expr old)))
214 (if (eq (car-safe old) 'error) 211 (if (eq (car-safe old) 'error)
215 (error "Error in expression: " (nth 1 old))) 212 (error "Error in expression: %S" (nth 1 old)))
216 (if (equal new "") (setq new "local")) 213 (if (equal new "") (setq new "local"))
217 (if (stringp new) (setq new (math-read-expr new))) 214 (if (stringp new) (setq new (math-read-expr new)))
218 (if (eq (car-safe new) 'error) 215 (if (eq (car-safe new) 'error)
219 (error "Error in expression: " (nth 1 new))) 216 (error "Error in expression: %S" (nth 1 new)))
220 (calc-enter-result 1 "tzcv" (list 'calcFunc-tzconv 217 (calc-enter-result 1 "tzcv" (list 'calcFunc-tzconv
221 (calc-top-n 1) old new))))) 218 (calc-top-n 1) old new)))))
222 219
223 (defun calc-new-week (arg) 220 (defun calc-new-week (arg)
224 (interactive "P") 221 (interactive "P")
442 ftime 439 ftime
443 (math-sub time ftime)))) 440 (math-sub time ftime))))
444 441
445 442
446 (defun math-this-year () 443 (defun math-this-year ()
447 (string-to-int (substring (current-time-string) -4))) 444 (string-to-number (substring (current-time-string) -4)))
448 445
449 (defun math-leap-year-p (year) 446 (defun math-leap-year-p (year)
450 (if (Math-lessp year 1752) 447 (if (Math-lessp year 1752)
451 (if (math-negp year) 448 (if (math-negp year)
452 (= (math-imod (math-neg year) 4) 1) 449 (= (math-imod (math-neg year) 4) 1)
508 (defvar math-short-month-names '( "Jan" "Feb" "Mar" "Apr" "May" "Jun" 505 (defvar math-short-month-names '( "Jan" "Feb" "Mar" "Apr" "May" "Jun"
509 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec" )) 506 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec" ))
510 507
511 508
512 (defvar math-format-date-cache nil) 509 (defvar math-format-date-cache nil)
513 (defun math-format-date (date) 510
514 (if (eq (car-safe date) 'date) 511 ;; The variables math-fd-date, math-fd-dt, math-fd-year,
515 (setq date (nth 1 date))) 512 ;; math-fd-month, math-fd-day, math-fd-weekday, math-fd-hour,
516 (let ((entry (list date calc-internal-prec calc-date-format))) 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)))
517 (or (cdr (assoc entry math-format-date-cache)) 531 (or (cdr (assoc entry math-format-date-cache))
518 (let* ((dt nil) 532 (let* ((math-fd-dt nil)
519 (calc-group-digits nil) 533 (calc-group-digits nil)
520 (calc-leading-zeros nil) 534 (calc-leading-zeros nil)
521 (calc-number-radix 10) 535 (calc-number-radix 10)
522 year month day weekday hour minute second 536 math-fd-year math-fd-month math-fd-day math-fd-weekday
523 (bc-flag nil) 537 math-fd-hour math-fd-minute math-fd-second
538 (math-fd-bc-flag nil)
524 (fmt (apply 'concat (mapcar 'math-format-date-part 539 (fmt (apply 'concat (mapcar 'math-format-date-part
525 calc-date-format)))) 540 calc-date-format))))
526 (setq math-format-date-cache (cons (cons entry fmt) 541 (setq math-format-date-cache (cons (cons entry fmt)
527 math-format-date-cache)) 542 math-format-date-cache))
528 (and (setq dt (nthcdr 10 math-format-date-cache)) 543 (and (setq math-fd-dt (nthcdr 10 math-format-date-cache))
529 (setcdr dt nil)) 544 (setcdr math-fd-dt nil))
530 fmt)))) 545 fmt))))
531 546
532 (defun math-format-date-part (x) 547 (defun math-format-date-part (x)
533 (cond ((stringp x) 548 (cond ((stringp x)
534 x) 549 x)
535 ((listp x) 550 ((listp x)
536 (if (math-integerp date) 551 (if (math-integerp math-fd-date)
537 "" 552 ""
538 (apply 'concat (mapcar 'math-format-date-part x)))) 553 (apply 'concat (mapcar 'math-format-date-part x))))
539 ((eq x 'X) 554 ((eq x 'X)
540 "") 555 "")
541 ((eq x 'N) 556 ((eq x 'N)
542 (math-format-number date)) 557 (math-format-number math-fd-date))
543 ((eq x 'n) 558 ((eq x 'n)
544 (math-format-number (math-floor date))) 559 (math-format-number (math-floor math-fd-date)))
545 ((eq x 'J) 560 ((eq x 'J)
546 (math-format-number (math-add date '(float (bigpos 235 214 17) -1)))) 561 (math-format-number (math-add math-fd-date '(float (bigpos 235 214 17) -1))))
547 ((eq x 'j) 562 ((eq x 'j)
548 (math-format-number (math-add (math-floor date) '(bigpos 424 721 1)))) 563 (math-format-number (math-add (math-floor math-fd-date) '(bigpos 424 721 1))))
549 ((eq x 'U) 564 ((eq x 'U)
550 (math-format-number (nth 1 (math-date-parts date 719164)))) 565 (math-format-number (nth 1 (math-date-parts math-fd-date 719164))))
551 ((progn 566 ((progn
552 (or dt 567 (or math-fd-dt
553 (progn 568 (progn
554 (setq dt (math-date-to-dt date) 569 (setq math-fd-dt (math-date-to-dt math-fd-date)
555 year (car dt) 570 math-fd-year (car math-fd-dt)
556 month (nth 1 dt) 571 math-fd-month (nth 1 math-fd-dt)
557 day (nth 2 dt) 572 math-fd-day (nth 2 math-fd-dt)
558 weekday (math-mod (math-add (math-floor date) 6) 7) 573 math-fd-weekday (math-mod
559 hour (nth 3 dt) 574 (math-add (math-floor math-fd-date) 6) 7)
560 minute (nth 4 dt) 575 math-fd-hour (nth 3 math-fd-dt)
561 second (nth 5 dt)) 576 math-fd-minute (nth 4 math-fd-dt)
577 math-fd-second (nth 5 math-fd-dt))
562 (and (memq 'b calc-date-format) 578 (and (memq 'b calc-date-format)
563 (math-negp year) 579 (math-negp math-fd-year)
564 (setq year (math-neg year) 580 (setq math-fd-year (math-neg math-fd-year)
565 bc-flag t)))) 581 math-fd-bc-flag t))))
566 (memq x '(Y YY BY))) 582 (memq x '(Y YY BY)))
567 (if (and (integerp year) (> year 1940) (< year 2040)) 583 (if (and (integerp math-fd-year) (> math-fd-year 1940) (< math-fd-year 2040))
568 (format (cond ((eq x 'YY) "%02d") 584 (format (cond ((eq x 'YY) "%02d")
569 ((eq x 'BYY) "%2d") 585 ((eq x 'BYY) "%2d")
570 (t "%d")) 586 (t "%d"))
571 (% year 100)) 587 (% math-fd-year 100))
572 (if (and (natnump year) (< year 100)) 588 (if (and (natnump math-fd-year) (< math-fd-year 100))
573 (format "+%d" year) 589 (format "+%d" math-fd-year)
574 (math-format-number year)))) 590 (math-format-number math-fd-year))))
575 ((eq x 'YYY) 591 ((eq x 'YYY)
576 (math-format-number year)) 592 (math-format-number math-fd-year))
577 ((eq x 'YYYY) 593 ((eq x 'YYYY)
578 (if (and (natnump year) (< year 100)) 594 (if (and (natnump math-fd-year) (< math-fd-year 100))
579 (format "+%d" year) 595 (format "+%d" math-fd-year)
580 (math-format-number year))) 596 (math-format-number math-fd-year)))
581 ((eq x 'b) "") 597 ((eq x 'b) "")
582 ((eq x 'aa) 598 ((eq x 'aa)
583 (and (not bc-flag) "ad")) 599 (and (not math-fd-bc-flag) "ad"))
584 ((eq x 'AA) 600 ((eq x 'AA)
585 (and (not bc-flag) "AD")) 601 (and (not math-fd-bc-flag) "AD"))
586 ((eq x 'aaa) 602 ((eq x 'aaa)
587 (and (not bc-flag) "ad ")) 603 (and (not math-fd-bc-flag) "ad "))
588 ((eq x 'AAA) 604 ((eq x 'AAA)
589 (and (not bc-flag) "AD ")) 605 (and (not math-fd-bc-flag) "AD "))
590 ((eq x 'aaaa) 606 ((eq x 'aaaa)
591 (and (not bc-flag) "a.d.")) 607 (and (not math-fd-bc-flag) "a.d."))
592 ((eq x 'AAAA) 608 ((eq x 'AAAA)
593 (and (not bc-flag) "A.D.")) 609 (and (not math-fd-bc-flag) "A.D."))
594 ((eq x 'bb) 610 ((eq x 'bb)
595 (and bc-flag "bc")) 611 (and math-fd-bc-flag "bc"))
596 ((eq x 'BB) 612 ((eq x 'BB)
597 (and bc-flag "BC")) 613 (and math-fd-bc-flag "BC"))
598 ((eq x 'bbb) 614 ((eq x 'bbb)
599 (and bc-flag " bc")) 615 (and math-fd-bc-flag " bc"))
600 ((eq x 'BBB) 616 ((eq x 'BBB)
601 (and bc-flag " BC")) 617 (and math-fd-bc-flag " BC"))
602 ((eq x 'bbbb) 618 ((eq x 'bbbb)
603 (and bc-flag "b.c.")) 619 (and math-fd-bc-flag "b.c."))
604 ((eq x 'BBBB) 620 ((eq x 'BBBB)
605 (and bc-flag "B.C.")) 621 (and math-fd-bc-flag "B.C."))
606 ((eq x 'M) 622 ((eq x 'M)
607 (format "%d" month)) 623 (format "%d" math-fd-month))
608 ((eq x 'MM) 624 ((eq x 'MM)
609 (format "%02d" month)) 625 (format "%02d" math-fd-month))
610 ((eq x 'BM) 626 ((eq x 'BM)
611 (format "%2d" month)) 627 (format "%2d" math-fd-month))
612 ((eq x 'mmm) 628 ((eq x 'mmm)
613 (downcase (nth (1- month) math-short-month-names))) 629 (downcase (nth (1- math-fd-month) math-short-month-names)))
614 ((eq x 'Mmm) 630 ((eq x 'Mmm)
615 (nth (1- month) math-short-month-names)) 631 (nth (1- math-fd-month) math-short-month-names))
616 ((eq x 'MMM) 632 ((eq x 'MMM)
617 (upcase (nth (1- month) math-short-month-names))) 633 (upcase (nth (1- math-fd-month) math-short-month-names)))
618 ((eq x 'Mmmm) 634 ((eq x 'Mmmm)
619 (nth (1- month) math-long-month-names)) 635 (nth (1- math-fd-month) math-long-month-names))
620 ((eq x 'MMMM) 636 ((eq x 'MMMM)
621 (upcase (nth (1- month) math-long-month-names))) 637 (upcase (nth (1- math-fd-month) math-long-month-names)))
622 ((eq x 'D) 638 ((eq x 'D)
623 (format "%d" day)) 639 (format "%d" math-fd-day))
624 ((eq x 'DD) 640 ((eq x 'DD)
625 (format "%02d" day)) 641 (format "%02d" math-fd-day))
626 ((eq x 'BD) 642 ((eq x 'BD)
627 (format "%2d" day)) 643 (format "%2d" math-fd-day))
628 ((eq x 'W) 644 ((eq x 'W)
629 (format "%d" weekday)) 645 (format "%d" math-fd-weekday))
630 ((eq x 'www) 646 ((eq x 'www)
631 (downcase (nth weekday math-short-weekday-names))) 647 (downcase (nth math-fd-weekday math-short-weekday-names)))
632 ((eq x 'Www) 648 ((eq x 'Www)
633 (nth weekday math-short-weekday-names)) 649 (nth math-fd-weekday math-short-weekday-names))
634 ((eq x 'WWW) 650 ((eq x 'WWW)
635 (upcase (nth weekday math-short-weekday-names))) 651 (upcase (nth math-fd-weekday math-short-weekday-names)))
636 ((eq x 'Wwww) 652 ((eq x 'Wwww)
637 (nth weekday math-long-weekday-names)) 653 (nth math-fd-weekday math-long-weekday-names))
638 ((eq x 'WWWW) 654 ((eq x 'WWWW)
639 (upcase (nth weekday math-long-weekday-names))) 655 (upcase (nth math-fd-weekday math-long-weekday-names)))
640 ((eq x 'd) 656 ((eq x 'd)
641 (format "%d" (math-day-number year month day))) 657 (format "%d" (math-day-number math-fd-year math-fd-month math-fd-day)))
642 ((eq x 'ddd) 658 ((eq x 'ddd)
643 (format "%03d" (math-day-number year month day))) 659 (format "%03d" (math-day-number math-fd-year math-fd-month math-fd-day)))
644 ((eq x 'bdd) 660 ((eq x 'bdd)
645 (format "%3d" (math-day-number year month day))) 661 (format "%3d" (math-day-number math-fd-year math-fd-month math-fd-day)))
646 ((eq x 'h) 662 ((eq x 'h)
647 (and hour (format "%d" hour))) 663 (and math-fd-hour (format "%d" math-fd-hour)))
648 ((eq x 'hh) 664 ((eq x 'hh)
649 (and hour (format "%02d" hour))) 665 (and math-fd-hour (format "%02d" math-fd-hour)))
650 ((eq x 'bh) 666 ((eq x 'bh)
651 (and hour (format "%2d" hour))) 667 (and math-fd-hour (format "%2d" math-fd-hour)))
652 ((eq x 'H) 668 ((eq x 'H)
653 (and hour (format "%d" (1+ (% (+ hour 11) 12))))) 669 (and math-fd-hour (format "%d" (1+ (% (+ math-fd-hour 11) 12)))))
654 ((eq x 'HH) 670 ((eq x 'HH)
655 (and hour (format "%02d" (1+ (% (+ hour 11) 12))))) 671 (and math-fd-hour (format "%02d" (1+ (% (+ math-fd-hour 11) 12)))))
656 ((eq x 'BH) 672 ((eq x 'BH)
657 (and hour (format "%2d" (1+ (% (+ hour 11) 12))))) 673 (and math-fd-hour (format "%2d" (1+ (% (+ math-fd-hour 11) 12)))))
658 ((eq x 'p) 674 ((eq x 'p)
659 (and hour (if (< hour 12) "a" "p"))) 675 (and math-fd-hour (if (< math-fd-hour 12) "a" "p")))
660 ((eq x 'P) 676 ((eq x 'P)
661 (and hour (if (< hour 12) "A" "P"))) 677 (and math-fd-hour (if (< math-fd-hour 12) "A" "P")))
662 ((eq x 'pp) 678 ((eq x 'pp)
663 (and hour (if (< hour 12) "am" "pm"))) 679 (and math-fd-hour (if (< math-fd-hour 12) "am" "pm")))
664 ((eq x 'PP) 680 ((eq x 'PP)
665 (and hour (if (< hour 12) "AM" "PM"))) 681 (and math-fd-hour (if (< math-fd-hour 12) "AM" "PM")))
666 ((eq x 'pppp) 682 ((eq x 'pppp)
667 (and hour (if (< hour 12) "a.m." "p.m."))) 683 (and math-fd-hour (if (< math-fd-hour 12) "a.m." "p.m.")))
668 ((eq x 'PPPP) 684 ((eq x 'PPPP)
669 (and hour (if (< hour 12) "A.M." "P.M."))) 685 (and math-fd-hour (if (< math-fd-hour 12) "A.M." "P.M.")))
670 ((eq x 'm) 686 ((eq x 'm)
671 (and minute (format "%d" minute))) 687 (and math-fd-minute (format "%d" math-fd-minute)))
672 ((eq x 'mm) 688 ((eq x 'mm)
673 (and minute (format "%02d" minute))) 689 (and math-fd-minute (format "%02d" math-fd-minute)))
674 ((eq x 'bm) 690 ((eq x 'bm)
675 (and minute (format "%2d" minute))) 691 (and math-fd-minute (format "%2d" math-fd-minute)))
676 ((eq x 'C) 692 ((eq x 'C)
677 (and second (not (math-zerop second)) 693 (and math-fd-second (not (math-zerop math-fd-second))
678 ":")) 694 ":"))
679 ((memq x '(s ss bs SS BS)) 695 ((memq x '(s ss bs SS BS))
680 (and second 696 (and math-fd-second
681 (not (and (memq x '(SS BS)) (math-zerop second))) 697 (not (and (memq x '(SS BS)) (math-zerop math-fd-second)))
682 (if (integerp second) 698 (if (integerp math-fd-second)
683 (format (cond ((memq x '(ss SS)) "%02d") 699 (format (cond ((memq x '(ss SS)) "%02d")
684 ((memq x '(bs BS)) "%2d") 700 ((memq x '(bs BS)) "%2d")
685 (t "%d")) 701 (t "%d"))
686 second) 702 math-fd-second)
687 (concat (if (Math-lessp second 10) 703 (concat (if (Math-lessp math-fd-second 10)
688 (cond ((memq x '(ss SS)) "0") 704 (cond ((memq x '(ss SS)) "0")
689 ((memq x '(bs BS)) " ") 705 ((memq x '(bs BS)) " ")
690 (t "")) 706 (t ""))
691 "") 707 "")
692 (let ((calc-float-format 708 (let ((calc-float-format
693 (list 'fix (min (- 12 calc-internal-prec) 709 (list 'fix (min (- 12 calc-internal-prec)
694 0)))) 710 0))))
695 (math-format-number second)))))))) 711 (math-format-number math-fd-second))))))))
696 712
697 713 ;; The variable math-pd-str is local to math-parse-date and
698 (defun math-parse-date (str) 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)
699 (catch 'syntax 719 (catch 'syntax
700 (or (math-parse-standard-date str t) 720 (or (math-parse-standard-date math-pd-str t)
701 (math-parse-standard-date str nil) 721 (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) 722 (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)))) 723 (list 'date (math-read-number (math-match-substring math-pd-str 1))))
704 (let ((case-fold-search t) 724 (let ((case-fold-search t)
705 (year nil) (month nil) (day nil) (weekday nil) 725 (year nil) (month nil) (day nil) (weekday nil)
706 (hour nil) (minute nil) (second nil) (bc-flag nil) 726 (hour nil) (minute nil) (second nil) (bc-flag nil)
707 (a nil) (b nil) (c nil) (bigyear nil) temp) 727 (a nil) (b nil) (c nil) (bigyear nil) temp)
708 728
709 ;; Extract the time, if any. 729 ;; 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) 730 (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)) 731 (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))) 732 (let ((ampm (math-match-substring math-pd-str 6)))
713 (setq hour (string-to-int (math-match-substring str 1)) 733 (setq hour (string-to-number (math-match-substring math-pd-str 1))
714 minute (math-match-substring str 2) 734 minute (math-match-substring math-pd-str 2)
715 second (math-match-substring str 4) 735 second (math-match-substring math-pd-str 4)
716 str (concat (substring str 0 (match-beginning 0)) 736 math-pd-str (concat (substring math-pd-str 0 (match-beginning 0))
717 (substring str (match-end 0)))) 737 (substring math-pd-str (match-end 0))))
718 (if (equal minute "") 738 (if (equal minute "")
719 (setq minute 0) 739 (setq minute 0)
720 (setq minute (string-to-int minute))) 740 (setq minute (string-to-number minute)))
721 (if (equal second "") 741 (if (equal second "")
722 (setq second 0) 742 (setq second 0)
723 (setq second (math-read-number second))) 743 (setq second (math-read-number second)))
724 (if (equal ampm "") 744 (if (equal ampm "")
725 (if (> hour 23) 745 (if (> hour 23)
734 (throw 'syntax "Hour value out of range")) 754 (throw 'syntax "Hour value out of range"))
735 (if (eq (= ampm ?A) (= hour 12)) 755 (if (eq (= ampm ?A) (= hour 12))
736 (setq hour (% (+ hour 12) 24))))))) 756 (setq hour (% (+ hour 12) 24)))))))
737 757
738 ;; Rewrite xx-yy-zz to xx/yy/zz to avoid seeing "-" as a minus sign. 758 ;; 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) 759 (while (string-match "[0-9a-zA-Z]\\(-\\)[0-9a-zA-Z]" math-pd-str)
740 (progn 760 (progn
741 (setq str (copy-sequence str)) 761 (setq math-pd-str (copy-sequence math-pd-str))
742 (aset str (match-beginning 1) ?\/))) 762 (aset math-pd-str (match-beginning 1) ?\/)))
743 763
744 ;; Extract obvious month or weekday names. 764 ;; Extract obvious month or weekday names.
745 (if (string-match "[a-zA-Z]" str) 765 (if (string-match "[a-zA-Z]" math-pd-str)
746 (progn 766 (progn
747 (setq month (math-parse-date-word math-long-month-names)) 767 (setq month (math-parse-date-word math-long-month-names))
748 (setq weekday (math-parse-date-word math-long-weekday-names)) 768 (setq weekday (math-parse-date-word math-long-weekday-names))
749 (or month (setq month 769 (or month (setq month
750 (math-parse-date-word math-short-month-names))) 770 (math-parse-date-word math-short-month-names)))
754 '( "noon" "midnight" "mid" ))) 774 '( "noon" "midnight" "mid" )))
755 (setq hour (if (= temp 1) 12 0) minute 0 second 0))) 775 (setq hour (if (= temp 1) 12 0) minute 0 second 0)))
756 (or (math-parse-date-word '( "ad" "a.d." )) 776 (or (math-parse-date-word '( "ad" "a.d." ))
757 (if (math-parse-date-word '( "bc" "b.c." )) 777 (if (math-parse-date-word '( "bc" "b.c." ))
758 (setq bc-flag t))) 778 (setq bc-flag t)))
759 (if (string-match "[a-zA-Z]+" str) 779 (if (string-match "[a-zA-Z]+" math-pd-str)
760 (throw 'syntax (format "Bad word in date: \"%s\"" 780 (throw 'syntax (format "Bad word in date: \"%s\""
761 (math-match-substring str 0)))))) 781 (math-match-substring math-pd-str 0))))))
762 782
763 ;; If there is a huge number other than the year, ignore it. 783 ;; 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) 784 (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)) 785 (setq temp (concat (substring math-pd-str 0 (match-beginning 0))
766 (substring str (match-end 0)))) 786 (substring math-pd-str (match-end 0))))
767 (string-match "[4-9][0-9]\\|[0-9][0-9][0-9]\\|[-+][0-9]+[^-]*\\'" temp)) 787 (string-match
768 (setq str temp)) 788 "[4-9][0-9]\\|[0-9][0-9][0-9]\\|[-+][0-9]+[^-]*\\'" temp))
789 (setq math-pd-str temp))
769 790
770 ;; If there is a number with a sign or a large number, it is a year. 791 ;; If there is a number with a sign or a large number, it is a year.
771 (if (or (string-match "\\([-+][0-9]+\\)[^-]*\\'" str) 792 (if (or (string-match "\\([-+][0-9]+\\)[^-]*\\'" math-pd-str)
772 (string-match "\\(0*[1-9][0-9][0-9]+\\)" str)) 793 (string-match "\\(0*[1-9][0-9][0-9]+\\)" math-pd-str))
773 (setq year (math-match-substring str 1) 794 (setq year (math-match-substring math-pd-str 1)
774 str (concat (substring str 0 (match-beginning 1)) 795 math-pd-str (concat (substring math-pd-str 0 (match-beginning 1))
775 (substring str (match-end 1))) 796 (substring math-pd-str (match-end 1)))
776 year (math-read-number year) 797 year (math-read-number year)
777 bigyear t)) 798 bigyear t))
778 799
779 ;; Collect remaining numbers. 800 ;; Collect remaining numbers.
780 (setq temp 0) 801 (setq temp 0)
781 (while (string-match "[0-9]+" str temp) 802 (while (string-match "[0-9]+" math-pd-str temp)
782 (and c (throw 'syntax "Too many numbers in date")) 803 (and c (throw 'syntax "Too many numbers in date"))
783 (setq c (string-to-int (math-match-substring str 0))) 804 (setq c (string-to-number (math-match-substring math-pd-str 0)))
784 (or b (setq b c c nil)) 805 (or b (setq b c c nil))
785 (or a (setq a b b nil)) 806 (or a (setq a b b nil))
786 (setq temp (match-end 0))) 807 (setq temp (match-end 0)))
787 808
788 ;; Check that we have the right amount of information. 809 ;; Check that we have the right amount of information.
865 (defun math-parse-date-word (names &optional front) 886 (defun math-parse-date-word (names &optional front)
866 (let ((n 1)) 887 (let ((n 1))
867 (while (and names (not (string-match (if (equal (car names) "Sep") 888 (while (and names (not (string-match (if (equal (car names) "Sep")
868 "Sept?" 889 "Sept?"
869 (regexp-quote (car names))) 890 (regexp-quote (car names)))
870 str))) 891 math-pd-str)))
871 (setq names (cdr names) 892 (setq names (cdr names)
872 n (1+ n))) 893 n (1+ n)))
873 (and names 894 (and names
874 (or (not front) (= (match-beginning 0) 0)) 895 (or (not front) (= (match-beginning 0) 0))
875 (progn 896 (progn
876 (setq str (concat (substring str 0 (match-beginning 0)) 897 (setq math-pd-str (concat (substring math-pd-str 0 (match-beginning 0))
877 (if front "" " ") 898 (if front "" " ")
878 (substring str (match-end 0)))) 899 (substring math-pd-str (match-end 0))))
879 n)))) 900 n))))
880 901
881 (defun math-parse-standard-date (str with-time) 902 (defun math-parse-standard-date (math-pd-str with-time)
882 (let ((case-fold-search t) 903 (let ((case-fold-search t)
883 (okay t) num 904 (okay t) num
884 (fmt calc-date-format) this next (gnext nil) 905 (fmt calc-date-format) this next (gnext nil)
885 (year nil) (month nil) (day nil) (bigyear nil) (yearday nil) 906 (year nil) (month nil) (day nil) (bigyear nil) (yearday nil)
886 (hour nil) (minute nil) (second nil) (bc-flag nil)) 907 (hour nil) (minute nil) (second nil) (bc-flag nil))
896 (or (not with-time) 917 (or (not with-time)
897 (not this) 918 (not this)
898 (setq gnext fmt 919 (setq gnext fmt
899 fmt this))) 920 fmt this)))
900 ((stringp this) 921 ((stringp this)
901 (if (and (<= (length this) (length str)) 922 (if (and (<= (length this) (length math-pd-str))
902 (equal this 923 (equal this
903 (substring str 0 (length this)))) 924 (substring math-pd-str 0 (length this))))
904 (setq str (substring str (length this))))) 925 (setq math-pd-str (substring math-pd-str (length this)))))
905 ((eq this 'X) 926 ((eq this 'X)
906 t) 927 t)
907 ((memq this '(n N j J)) 928 ((memq this '(n N j J))
908 (and (string-match "\\`[-+]?[0-9.]+\\([eE][-+]?[0-9]+\\)?" str) 929 (and (string-match "\\`[-+]?[0-9.]+\\([eE][-+]?[0-9]+\\)?" math-pd-str)
909 (setq num (math-match-substring str 0) 930 (setq num (math-match-substring math-pd-str 0)
910 str (substring str (match-end 0)) 931 math-pd-str (substring math-pd-str (match-end 0))
911 num (math-date-to-dt (math-read-number num)) 932 num (math-date-to-dt (math-read-number num))
912 num (math-sub num 933 num (math-sub num
913 (if (memq this '(n N)) 934 (if (memq this '(n N))
914 0 935 0
915 (if (or (eq this 'j) 936 (if (or (eq this 'j)
922 second (or (nth 5 num) second) 943 second (or (nth 5 num) second)
923 year (car num) 944 year (car num)
924 month (nth 1 num) 945 month (nth 1 num)
925 day (nth 2 num)))) 946 day (nth 2 num))))
926 ((eq this 'U) 947 ((eq this 'U)
927 (and (string-match "\\`[-+]?[0-9]+" str) 948 (and (string-match "\\`[-+]?[0-9]+" math-pd-str)
928 (setq num (math-match-substring str 0) 949 (setq num (math-match-substring math-pd-str 0)
929 str (substring str (match-end 0)) 950 math-pd-str (substring math-pd-str (match-end 0))
930 num (math-date-to-dt 951 num (math-date-to-dt
931 (math-add 719164 952 (math-add 719164
932 (math-div (math-read-number num) 953 (math-div (math-read-number num)
933 '(float 864 2)))) 954 '(float 864 2))))
934 hour (nth 3 num) 955 hour (nth 3 num)
944 ((memq this '(www Www WWW)) 965 ((memq this '(www Www WWW))
945 (math-parse-date-word math-short-weekday-names t)) 966 (math-parse-date-word math-short-weekday-names t))
946 ((memq this '(Wwww WWWW)) 967 ((memq this '(Wwww WWWW))
947 (math-parse-date-word math-long-weekday-names t)) 968 (math-parse-date-word math-long-weekday-names t))
948 ((memq this '(p P)) 969 ((memq this '(p P))
949 (if (string-match "\\`a" str) 970 (if (string-match "\\`a" math-pd-str)
950 (setq hour (if (= hour 12) 0 hour) 971 (setq hour (if (= hour 12) 0 hour)
951 str (substring str 1)) 972 math-pd-str (substring math-pd-str 1))
952 (if (string-match "\\`p" str) 973 (if (string-match "\\`p" math-pd-str)
953 (setq hour (if (= hour 12) 12 (% (+ hour 12) 24)) 974 (setq hour (if (= hour 12) 12 (% (+ hour 12) 24))
954 str (substring str 1))))) 975 math-pd-str (substring math-pd-str 1)))))
955 ((memq this '(pp PP pppp PPPP)) 976 ((memq this '(pp PP pppp PPPP))
956 (if (string-match "\\`am\\|a\\.m\\." str) 977 (if (string-match "\\`am\\|a\\.m\\." math-pd-str)
957 (setq hour (if (= hour 12) 0 hour) 978 (setq hour (if (= hour 12) 0 hour)
958 str (substring str (match-end 0))) 979 math-pd-str (substring math-pd-str (match-end 0)))
959 (if (string-match "\\`pm\\|p\\.m\\." str) 980 (if (string-match "\\`pm\\|p\\.m\\." math-pd-str)
960 (setq hour (if (= hour 12) 12 (% (+ hour 12) 24)) 981 (setq hour (if (= hour 12) 12 (% (+ hour 12) 24))
961 str (substring str (match-end 0)))))) 982 math-pd-str (substring math-pd-str (match-end 0))))))
962 ((memq this '(Y YY BY YYY YYYY)) 983 ((memq this '(Y YY BY YYY YYYY))
963 (and (if (memq next '(MM DD ddd hh HH mm ss SS)) 984 (and (if (memq next '(MM DD ddd hh HH mm ss SS))
964 (if (memq this '(Y YY BYY)) 985 (if (memq this '(Y YY BYY))
965 (string-match "\\` *[0-9][0-9]" str) 986 (string-match "\\` *[0-9][0-9]" math-pd-str)
966 (string-match "\\`[0-9][0-9][0-9][0-9]" str)) 987 (string-match "\\`[0-9][0-9][0-9][0-9]" math-pd-str))
967 (string-match "\\`[-+]?[0-9]+" str)) 988 (string-match "\\`[-+]?[0-9]+" math-pd-str))
968 (setq year (math-match-substring str 0) 989 (setq year (math-match-substring math-pd-str 0)
969 bigyear (or (eq this 'YYY) 990 bigyear (or (eq this 'YYY)
970 (memq (aref str 0) '(?\+ ?\-))) 991 (memq (aref math-pd-str 0) '(?\+ ?\-)))
971 str (substring str (match-end 0)) 992 math-pd-str (substring math-pd-str (match-end 0))
972 year (math-read-number year)))) 993 year (math-read-number year))))
973 ((eq this 'b) 994 ((eq this 'b)
974 t) 995 t)
975 ((memq this '(aa AA aaaa AAAA)) 996 ((memq this '(aa AA aaaa AAAA))
976 (if (string-match "\\` *\\(ad\\|a\\.d\\.\\)" str) 997 (if (string-match "\\` *\\(ad\\|a\\.d\\.\\)" math-pd-str)
977 (setq str (substring str (match-end 0))))) 998 (setq math-pd-str (substring math-pd-str (match-end 0)))))
978 ((memq this '(aaa AAA)) 999 ((memq this '(aaa AAA))
979 (if (string-match "\\` *ad *" str) 1000 (if (string-match "\\` *ad *" math-pd-str)
980 (setq str (substring str (match-end 0))))) 1001 (setq math-pd-str (substring math-pd-str (match-end 0)))))
981 ((memq this '(bb BB bbb BBB bbbb BBBB)) 1002 ((memq this '(bb BB bbb BBB bbbb BBBB))
982 (if (string-match "\\` *\\(bc\\|b\\.c\\.\\)" str) 1003 (if (string-match "\\` *\\(bc\\|b\\.c\\.\\)" math-pd-str)
983 (setq str (substring str (match-end 0)) 1004 (setq math-pd-str (substring math-pd-str (match-end 0))
984 bc-flag t))) 1005 bc-flag t)))
985 ((memq this '(s ss bs SS BS)) 1006 ((memq this '(s ss bs SS BS))
986 (and (if (memq next '(YY YYYY MM DD hh HH mm)) 1007 (and (if (memq next '(YY YYYY MM DD hh HH mm))
987 (string-match "\\` *[0-9][0-9]\\(\\.[0-9]+\\)?" str) 1008 (string-match "\\` *[0-9][0-9]\\(\\.[0-9]+\\)?" math-pd-str)
988 (string-match "\\` *[0-9][0-9]?\\(\\.[0-9]+\\)?" str)) 1009 (string-match "\\` *[0-9][0-9]?\\(\\.[0-9]+\\)?" math-pd-str))
989 (setq second (math-match-substring str 0) 1010 (setq second (math-match-substring math-pd-str 0)
990 str (substring str (match-end 0)) 1011 math-pd-str (substring math-pd-str (match-end 0))
991 second (math-read-number second)))) 1012 second (math-read-number second))))
992 ((eq this 'C) 1013 ((eq this 'C)
993 (if (string-match "\\`:[0-9][0-9]" str) 1014 (if (string-match "\\`:[0-9][0-9]" math-pd-str)
994 (setq str (substring str 1)) 1015 (setq math-pd-str (substring math-pd-str 1))
995 t)) 1016 t))
996 ((or (not (if (and (memq this '(ddd MM DD hh HH mm)) 1017 ((or (not (if (and (memq this '(ddd MM DD hh HH mm))
997 (memq next '(YY YYYY MM DD ddd 1018 (memq next '(YY YYYY MM DD ddd
998 hh HH mm ss SS))) 1019 hh HH mm ss SS)))
999 (if (eq this 'ddd) 1020 (if (eq this 'ddd)
1000 (string-match "\\` *[0-9][0-9][0-9]" str) 1021 (string-match "\\` *[0-9][0-9][0-9]" math-pd-str)
1001 (string-match "\\` *[0-9][0-9]" str)) 1022 (string-match "\\` *[0-9][0-9]" math-pd-str))
1002 (string-match "\\` *[0-9]+" str))) 1023 (string-match "\\` *[0-9]+" math-pd-str)))
1003 (and (setq num (string-to-int 1024 (and (setq num (string-to-number
1004 (math-match-substring str 0)) 1025 (math-match-substring math-pd-str 0))
1005 str (substring str (match-end 0))) 1026 math-pd-str (substring math-pd-str (match-end 0)))
1006 nil)) 1027 nil))
1007 nil) 1028 nil)
1008 ((eq this 'W) 1029 ((eq this 'W)
1009 (and (>= num 0) (< num 7))) 1030 (and (>= num 0) (< num 7)))
1010 ((memq this '(d ddd bdd)) 1031 ((memq this '(d ddd bdd))
1020 (setq okay nil))) 1041 (setq okay nil)))
1021 (if yearday 1042 (if yearday
1022 (if (and month day) 1043 (if (and month day)
1023 (setq yearday nil) 1044 (setq yearday nil)
1024 (setq month 1 day 1))) 1045 (setq month 1 day 1)))
1025 (if (and okay (equal str "")) 1046 (if (and okay (equal math-pd-str ""))
1026 (and month day (or (not (or hour minute second)) 1047 (and month day (or (not (or hour minute second))
1027 (and hour minute)) 1048 (and hour minute))
1028 (progn 1049 (progn
1029 (or year (setq year (math-this-year))) 1050 (or year (setq year (math-this-year)))
1030 (or second (setq second 0)) 1051 (or second (setq second 0))
1145 '(float 864 2))))) 1166 '(float 864 2)))))
1146 (if (eq (car date) 'date) 1167 (if (eq (car date) 'date)
1147 (math-add (nth 1 (math-date-parts (nth 1 date) 719164)) 1168 (math-add (nth 1 (math-date-parts (nth 1 date) 719164))
1148 (calcFunc-tzone zone date)) 1169 (calcFunc-tzone zone date))
1149 (math-reject-arg date 'datep)))) 1170 (math-reject-arg date 'datep))))
1171
1172
1173 ;;; Note: Longer names must appear before shorter names which are
1174 ;;; substrings of them.
1175 (defvar math-tzone-names
1176 '(( "UTC" 0 0)
1177 ( "MEGT" -1 "MET" "METDST" ) ; Middle Europe
1178 ( "METDST" -1 -1 ) ( "MET" -1 0 )
1179 ( "MEGZ" -1 "MEZ" "MESZ" ) ( "MEZ" -1 0 ) ( "MESZ" -1 -1 )
1180 ( "WEGT" 0 "WET" "WETDST" ) ; Western Europe
1181 ( "WETDST" 0 -1 ) ( "WET" 0 0 )
1182 ( "BGT" 0 "GMT" "BST" ) ( "GMT" 0 0 ) ( "BST" 0 -1 ) ; Britain
1183 ( "NGT" (float 35 -1) "NST" "NDT" ) ; Newfoundland
1184 ( "NST" (float 35 -1) 0 ) ( "NDT" (float 35 -1) -1 )
1185 ( "AGT" 4 "AST" "ADT" ) ( "AST" 4 0 ) ( "ADT" 4 -1 ) ; Atlantic
1186 ( "EGT" 5 "EST" "EDT" ) ( "EST" 5 0 ) ( "EDT" 5 -1 ) ; Eastern
1187 ( "CGT" 6 "CST" "CDT" ) ( "CST" 6 0 ) ( "CDT" 6 -1 ) ; Central
1188 ( "MGT" 7 "MST" "MDT" ) ( "MST" 7 0 ) ( "MDT" 7 -1 ) ; Mountain
1189 ( "PGT" 8 "PST" "PDT" ) ( "PST" 8 0 ) ( "PDT" 8 -1 ) ; Pacific
1190 ( "YGT" 9 "YST" "YDT" ) ( "YST" 9 0 ) ( "YDT" 9 -1 ) ; Yukon
1191 )
1192 "No doc yet. See calc manual for now. ")
1193
1194 (defvar var-TimeZone)
1150 1195
1151 (defun calcFunc-tzone (&optional zone date) 1196 (defun calcFunc-tzone (&optional zone date)
1152 (if zone 1197 (if zone
1153 (cond ((math-realp zone) 1198 (cond ((math-realp zone)
1154 (math-round (math-mul zone 3600))) 1199 (math-round (math-mul zone 3600)))
1189 (let ((case-fold-search t)) 1234 (let ((case-fold-search t))
1190 (while (and p (not (search-forward (car (car p)) nil t))) 1235 (while (and p (not (search-forward (car (car p)) nil t)))
1191 (setq p (cdr p)))) 1236 (setq p (cdr p))))
1192 (if (looking-at "\\([-+][0-9]?[0-9]\\)\\([0-9][0-9]\\)?\\(\\'\\|[^0-9]\\)") 1237 (if (looking-at "\\([-+][0-9]?[0-9]\\)\\([0-9][0-9]\\)?\\(\\'\\|[^0-9]\\)")
1193 (setq offset (math-add 1238 (setq offset (math-add
1194 (string-to-int (buffer-substring 1239 (string-to-number (buffer-substring
1195 (match-beginning 1) 1240 (match-beginning 1)
1196 (match-end 1))) 1241 (match-end 1)))
1197 (if (match-beginning 2) 1242 (if (match-beginning 2)
1198 (math-div (string-to-int (buffer-substring 1243 (math-div (string-to-number (buffer-substring
1199 (match-beginning 2) 1244 (match-beginning 2)
1200 (match-end 2))) 1245 (match-end 2)))
1201 60) 1246 60)
1202 0))))) 1247 0)))))
1203 (if p 1248 (if p
1204 (progn 1249 (progn
1205 (setq p (car p)) 1250 (setq p (car p))
1224 (kill-buffer " *Calc Temporary*") 1269 (kill-buffer " *Calc Temporary*")
1225 (setq var-TimeZone tz) 1270 (setq var-TimeZone tz)
1226 (calc-refresh-evaltos 'var-TimeZone) 1271 (calc-refresh-evaltos 'var-TimeZone)
1227 (calcFunc-tzone tz date))))) 1272 (calcFunc-tzone tz date)))))
1228 1273
1229 ;;; Note: Longer names must appear before shorter names which are 1274 (defvar math-daylight-savings-hook 'math-std-daylight-savings)
1230 ;;; substrings of them.
1231 (defvar math-tzone-names
1232 '( ( "MEGT" -1 "MET" "METDST" ) ; Middle Europe
1233 ( "METDST" -1 -1 ) ( "MET" -1 0 )
1234 ( "MEGZ" -1 "MEZ" "MESZ" ) ( "MEZ" -1 0 ) ( "MESZ" -1 -1 )
1235 ( "WEGT" 0 "WET" "WETDST" ) ; Western Europe
1236 ( "WETDST" 0 -1 ) ( "WET" 0 0 )
1237 ( "BGT" 0 "GMT" "BST" ) ( "GMT" 0 0 ) ( "BST" 0 -1 ) ; Britain
1238 ( "NGT" (float 35 -1) "NST" "NDT" ) ; Newfoundland
1239 ( "NST" (float 35 -1) 0 ) ( "NDT" (float 35 -1) -1 )
1240 ( "AGT" 4 "AST" "ADT" ) ( "AST" 4 0 ) ( "ADT" 4 -1 ) ; Atlantic
1241 ( "EGT" 5 "EST" "EDT" ) ( "EST" 5 0 ) ( "EDT" 5 -1 ) ; Eastern
1242 ( "CGT" 6 "CST" "CDT" ) ( "CST" 6 0 ) ( "CDT" 6 -1 ) ; Central
1243 ( "MGT" 7 "MST" "MDT" ) ( "MST" 7 0 ) ( "MDT" 7 -1 ) ; Mountain
1244 ( "PGT" 8 "PST" "PDT" ) ( "PST" 8 0 ) ( "PDT" 8 -1 ) ; Pacific
1245 ( "YGT" 9 "YST" "YDT" ) ( "YST" 9 0 ) ( "YDT" 9 -1 ) ; Yukon
1246 ))
1247
1248 1275
1249 (defun math-daylight-savings-adjust (date zone &optional dt) 1276 (defun math-daylight-savings-adjust (date zone &optional dt)
1250 (or date (setq date (nth 1 (calcFunc-now)))) 1277 (or date (setq date (nth 1 (calcFunc-now))))
1251 (let (bump) 1278 (let (bump)
1252 (if (eq (car-safe date) 'date) 1279 (if (eq (car-safe date) 'date)
1281 1308
1282 (defun calcFunc-tzconv (date z1 z2) 1309 (defun calcFunc-tzconv (date z1 z2)
1283 (if (math-realp date) 1310 (if (math-realp date)
1284 (nth 1 (calcFunc-tzconv (list 'date date) z1 z2)) 1311 (nth 1 (calcFunc-tzconv (list 'date date) z1 z2))
1285 (calcFunc-unixtime (calcFunc-unixtime date z1) z2))) 1312 (calcFunc-unixtime (calcFunc-unixtime date z1) z2)))
1286
1287 (defvar math-daylight-savings-hook 'math-std-daylight-savings)
1288 1313
1289 (defun math-std-daylight-savings (date dt zone bump) 1314 (defun math-std-daylight-savings (date dt zone bump)
1290 "Standard North American daylight savings algorithm. 1315 "Standard North American daylight savings algorithm.
1291 This implements the rules for the U.S. and Canada as of 1987. 1316 This implements the rules for the U.S. and Canada as of 1987.
1292 Daylight savings begins on the first Sunday of April at 2 a.m., 1317 Daylight savings begins on the first Sunday of April at 2 a.m.,
1408 (defvar math-holidays-cache nil) 1433 (defvar math-holidays-cache nil)
1409 (defvar math-holidays-cache-tag t) 1434 (defvar math-holidays-cache-tag t)
1410 (defun calcFunc-badd (a b) 1435 (defun calcFunc-badd (a b)
1411 (if (eq (car-safe b) 'date) 1436 (if (eq (car-safe b) 'date)
1412 (if (eq (car-safe a) 'date) 1437 (if (eq (car-safe a) 'date)
1413 (math-reject-arg nil "*Illegal combination in date arithmetic") 1438 (math-reject-arg nil "*Invalid combination in date arithmetic")
1414 (calcFunc-badd b a)) 1439 (calcFunc-badd b a))
1415 (if (eq (car-safe a) 'date) 1440 (if (eq (car-safe a) 'date)
1416 (if (Math-realp b) 1441 (if (Math-realp b)
1417 (if (Math-zerop b) 1442 (if (Math-zerop b)
1418 a 1443 a
1426 (let ((hours (nth 7 math-holidays-cache))) 1451 (let ((hours (nth 7 math-holidays-cache)))
1427 (setq b (math-div (math-from-hms b 'deg) 24)) 1452 (setq b (math-div (math-from-hms b 'deg) 24))
1428 (if hours 1453 (if hours
1429 (setq b (math-div b (cdr hours)))) 1454 (setq b (math-div b (cdr hours))))
1430 (calcFunc-badd a b)) 1455 (calcFunc-badd a b))
1431 (math-reject-arg nil "*Illegal combination in date arithmetic"))) 1456 (math-reject-arg nil "*Invalid combination in date arithmetic")))
1432 (math-reject-arg a 'datep)))) 1457 (math-reject-arg a 'datep))))
1433 1458
1434 (defun calcFunc-holiday (a) 1459 (defun calcFunc-holiday (a)
1435 (if (cdr (math-to-business-day a)) 1 0)) 1460 (if (cdr (math-to-business-day a)) 1 0))
1436 1461
1503 (if hours 1528 (if hours
1504 (setq time (math-add (math-mul time (cdr hours)) (car hours))))) 1529 (setq time (math-add (math-mul time (cdr hours)) (car hours)))))
1505 (and (not (math-setup-holidays day)) 1530 (and (not (math-setup-holidays day))
1506 (list 'date (math-add day time)))))) 1531 (list 'date (math-add day time))))))
1507 1532
1533 ;; The variable math-sh-year is local to math-setup-holidays
1534 ;; and math-setup-year-holiday, but is used by math-setup-add-holidays,
1535 ;; which is called by math-setup-holidays and math-setup-year-holiday.
1536 (defvar math-sh-year)
1508 1537
1509 (defun math-setup-holidays (&optional date) 1538 (defun math-setup-holidays (&optional date)
1510 (or (eq (calc-var-value 'var-Holidays) math-holidays-cache-tag) 1539 (or (eq (calc-var-value 'var-Holidays) math-holidays-cache-tag)
1511 (let ((h (calc-var-value 'var-Holidays)) 1540 (let ((h (calc-var-value 'var-Holidays))
1512 (wdnames '( (sun . 0) (mon . 1) (tue . 2) (wed . 3) 1541 (wdnames '( (sun . 0) (mon . 1) (tue . 2) (wed . 3)
1577 (or (eq (car-safe date) 'date) (setq date (list 'date date))) 1606 (or (eq (car-safe date) 'date) (setq date (list 'date date)))
1578 (math-reject-arg date "*Date is outside valid range"))) 1607 (math-reject-arg date "*Date is outside valid range")))
1579 (unwind-protect 1608 (unwind-protect
1580 (let ((days (nth 6 math-holidays-cache))) 1609 (let ((days (nth 6 math-holidays-cache)))
1581 (if days 1610 (if days
1582 (let ((year nil)) ; see below 1611 (let ((math-sh-year nil)) ; see below
1583 (setcar (nthcdr 6 math-holidays-cache) nil) 1612 (setcar (nthcdr 6 math-holidays-cache) nil)
1584 (math-setup-add-holidays (cons 'vec (cdr days))) 1613 (math-setup-add-holidays (cons 'vec (cdr days)))
1585 (setcar (nthcdr 2 math-holidays-cache) (car days)))) 1614 (setcar (nthcdr 2 math-holidays-cache) (car days))))
1586 (cond ((not (nth 2 math-holidays-cache)) 1615 (cond ((not (nth 2 math-holidays-cache))
1587 (setq done t) 1616 (setq done t)
1609 (t 1638 (t
1610 (setq done t) 1639 (setq done t)
1611 nil))) 1640 nil)))
1612 (or done (setq math-holidays-cache-tag t)))))) 1641 (or done (setq math-holidays-cache-tag t))))))
1613 1642
1614 (defun math-setup-year-holidays (year) 1643 (defun math-setup-year-holidays (math-sh-year)
1615 (let ((exprs (nth 2 math-holidays-cache))) 1644 (let ((exprs (nth 2 math-holidays-cache)))
1616 (while exprs 1645 (while exprs
1617 (let* ((var-y year) 1646 (let* ((var-y math-sh-year)
1618 (var-m nil) 1647 (var-m nil)
1619 (expr (math-evaluate-expr (car exprs)))) 1648 (expr (math-evaluate-expr (car exprs))))
1620 (if (math-expr-contains expr '(var m var-m)) 1649 (if (math-expr-contains expr '(var m var-m))
1621 (let ((var-m 0)) 1650 (let ((var-m 0))
1622 (while (<= (setq var-m (1+ var-m)) 12) 1651 (while (<= (setq var-m (1+ var-m)) 12)
1623 (math-setup-add-holidays (math-evaluate-expr expr)))) 1652 (math-setup-add-holidays (math-evaluate-expr expr))))
1624 (math-setup-add-holidays expr))) 1653 (math-setup-add-holidays expr)))
1625 (setq exprs (cdr exprs))))) 1654 (setq exprs (cdr exprs)))))
1626 1655
1627 (defun math-setup-add-holidays (days) ; uses "year" 1656 (defun math-setup-add-holidays (days) ; uses "math-sh-year"
1628 (cond ((eq (car-safe days) 'vec) 1657 (cond ((eq (car-safe days) 'vec)
1629 (while (setq days (cdr days)) 1658 (while (setq days (cdr days))
1630 (math-setup-add-holidays (car days)))) 1659 (math-setup-add-holidays (car days))))
1631 ((eq (car-safe days) 'intv) 1660 ((eq (car-safe days) 'intv)
1632 (let ((day (math-ceiling (nth 2 days)))) 1661 (let ((day (math-ceiling (nth 2 days))))
1637 (setq day (math-add day 1))))) 1666 (setq day (math-add day 1)))))
1638 ((eq (car-safe days) 'date) 1667 ((eq (car-safe days) 'date)
1639 (math-setup-add-holidays (nth 1 days))) 1668 (math-setup-add-holidays (nth 1 days)))
1640 ((eq days 0)) 1669 ((eq days 0))
1641 ((integerp days) 1670 ((integerp days)
1642 (let ((b (math-to-business-day days year))) 1671 (let ((b (math-to-business-day days math-sh-year)))
1643 (or (cdr b) ; don't register holidays twice! 1672 (or (cdr b) ; don't register holidays twice!
1644 (let ((prev (car math-holidays-cache)) 1673 (let ((prev (car math-holidays-cache))
1645 (iprev (nth 1 math-holidays-cache))) 1674 (iprev (nth 1 math-holidays-cache)))
1646 (while (and (cdr prev) (< (nth 1 prev) days)) 1675 (while (and (cdr prev) (< (nth 1 prev) days))
1647 (setq prev (cdr prev) iprev (cdr iprev))) 1676 (setq prev (cdr prev) iprev (cdr iprev)))
1785 (memq (nth 1 a) '(0 2))) 1814 (memq (nth 1 a) '(0 2)))
1786 (math-make-intv (nth 1 a) m1 b)) 1815 (math-make-intv (nth 1 a) m1 b))
1787 (t 1816 (t
1788 (math-make-intv 2 0 b))))) 1817 (math-make-intv 2 0 b)))))
1789 1818
1819 ;; The variables math-exp-str and math-exp-pos are local to
1820 ;; math-read-exprs in math-aent.el, but are used by
1821 ;; math-read-angle-brackets, which is called (indirectly) by
1822 ;; math-read-exprs.
1823 (defvar math-exp-str)
1824 (defvar math-exp-pos)
1790 1825
1791 (defun math-read-angle-brackets () 1826 (defun math-read-angle-brackets ()
1792 (let* ((last (or (math-check-for-commas t) (length exp-str))) 1827 (let* ((last (or (math-check-for-commas t) (length math-exp-str)))
1793 (str (substring exp-str exp-pos last)) 1828 (str (substring math-exp-str math-exp-pos last))
1794 (res 1829 (res
1795 (if (string-match "\\` *\\([a-zA-Z#][a-zA-Z0-9#]* *,? *\\)*:" str) 1830 (if (string-match "\\` *\\([a-zA-Z#][a-zA-Z0-9#]* *,? *\\)*:" str)
1796 (let ((str1 (substring str 0 (1- (match-end 0)))) 1831 (let ((str1 (substring str 0 (1- (match-end 0))))
1797 (str2 (substring str (match-end 0))) 1832 (str2 (substring str (match-end 0)))
1798 (calc-hashes-used 0)) 1833 (calc-hashes-used 0))
1814 (math-parse-date str))))) 1849 (math-parse-date str)))))
1815 (if (stringp res) 1850 (if (stringp res)
1816 (throw 'syntax res)) 1851 (throw 'syntax res))
1817 (if (eq (car-safe res) 'error) 1852 (if (eq (car-safe res) 'error)
1818 (throw 'syntax (nth 2 res))) 1853 (throw 'syntax (nth 2 res)))
1819 (setq exp-pos (1+ last)) 1854 (setq math-exp-pos (1+ last))
1820 (math-read-token) 1855 (math-read-token)
1821 res)) 1856 res))
1822 1857
1858 (provide 'calc-forms)
1859
1860 ;;; arch-tag: a3d8f33b-9508-4043-8060-d02b8c9c750c
1823 ;;; calc-forms.el ends here 1861 ;;; calc-forms.el ends here