mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-15 10:30:25 -08:00
* lisp/calc/calc-forms.el (math-absolute-from-iso-dt)
(math-date-to-iso-dt, math-parse-iso-date-validate) (math-iso-dt-to-date): New functions. (math-fd-iso-dt, math-fd-isoyear, math-fd-isoweek) (math-fd-isoweekday): New variables. (calc-date-notation, math-parse-standard-date, math-format-date) (math-format-date-part): Add support for more formatting codes.
This commit is contained in:
Jay Belanger
parent
2dd2e62273
commit
682ceaf895
2 changed files with 138 additions and 19 deletions
|
|
@ -95,7 +95,7 @@
|
|||
(let ((case-fold-search nil))
|
||||
(and (not (string-match "<.*>" fmt))
|
||||
;; Find time part to put in <...>
|
||||
(string-match "\\`[^hHspP]*\\([^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*\\(bs\\|bm\\|bh\\|BS\\|BH\\|[hHmpPsS]\\)+[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*\\)[^hHspP]*\\'" fmt)
|
||||
(string-match "\\`[^hHspPT]*\\([^ac-gi-lnoqrt-zAC-GI-OQRU-Z]*\\(bs\\|bm\\|bh\\|BS\\|BH\\|[hHmpPsST]\\)+[^ac-gi-lnoqrt-zAC-GI-OQRU-Z]*\\)[^hHspPT]*\\'" fmt)
|
||||
(string-match (concat "[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*"
|
||||
(regexp-quote (math-match-substring fmt 1))
|
||||
"[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*") fmt)
|
||||
|
|
@ -126,7 +126,7 @@
|
|||
lfmt nil))
|
||||
(setq time nil))
|
||||
(t
|
||||
(if (string-match "\\`[^a-zA-Z]*[bB][a-zA-Z]" fmt)
|
||||
(if (string-match "\\`[^a-zA-Z]*[bBZI][a-zA-Z]" fmt)
|
||||
(setq pos2 (1+ pos2)))
|
||||
(while (and (< pos2 (length fmt))
|
||||
(= (upcase (aref fmt pos2))
|
||||
|
|
@ -134,6 +134,7 @@
|
|||
(setq pos2 (1+ pos2)))
|
||||
(setq sym (intern (substring fmt pos pos2)))
|
||||
(or (memq sym '(Y YY BY YYY YYYY
|
||||
ZYYY IYYY Iww w
|
||||
aa AA aaa AAA aaaa AAAA
|
||||
bb BB bbb BBB bbbb BBBB
|
||||
M MM BM mmm Mmm Mmmm MMM MMMM
|
||||
|
|
@ -142,7 +143,7 @@
|
|||
h hh bh H HH BH
|
||||
p P pp PP pppp PPPP
|
||||
m mm bm s ss bs SS BS C
|
||||
N n J j U b))
|
||||
N n J j U b T))
|
||||
(and (eq sym 'X) (not lfmt) (not fullfmt))
|
||||
(error "Bad format code: %s" sym))
|
||||
(and (memq sym '(bb BB bbb BBB bbbb BBBB))
|
||||
|
|
@ -455,6 +456,26 @@ in the Gregorian calendar and the remaining part determines the time."
|
|||
(% (/ time 60) 60)
|
||||
(math-add (% time 60) (nth 2 parts)))))))
|
||||
|
||||
(defun math-date-to-iso-dt (date)
|
||||
"Return the ISO8601 date (year week day) of DATE."
|
||||
(unless (Math-integerp date)
|
||||
(setq date (math-floor date)))
|
||||
(let* ((approx (nth 0 (math-date-to-gregorian-dt (math-sub date 3))))
|
||||
(year (math-add approx
|
||||
(let ((y approx)
|
||||
(sum 0))
|
||||
(while (>= (math-compare date
|
||||
(math-iso-dt-to-absolute (setq y (math-add y 1)) 1 1)) 0)
|
||||
(setq sum (+ sum 1)))
|
||||
sum))))
|
||||
(list
|
||||
year
|
||||
(math-add (car (math-idivmod
|
||||
(math-sub date (math-iso-dt-to-absolute year 1 1))
|
||||
7))
|
||||
1)
|
||||
(cdr (math-idivmod date 7)))))
|
||||
|
||||
(defun math-dt-to-date (dt)
|
||||
(or (integerp (nth 1 dt))
|
||||
(math-reject-arg (nth 1 dt) 'fixnump))
|
||||
|
|
@ -473,6 +494,16 @@ in the Gregorian calendar and the remaining part determines the time."
|
|||
'(float 864 2)))
|
||||
date)))
|
||||
|
||||
(defun math-iso-dt-to-date (dt)
|
||||
(let ((date (math-absolute-from-iso-dt (car dt) (nth 1 dt) (nth 2 dt))))
|
||||
(if (nth 3 dt)
|
||||
(math-add (math-float date)
|
||||
(math-div (math-add (+ (* (nth 3 dt) 3600)
|
||||
(* (nth 4 dt) 60))
|
||||
(nth 5 dt))
|
||||
'(float 864 2)))
|
||||
date)))
|
||||
|
||||
(defun math-date-parts (value &optional offset)
|
||||
(let* ((date (math-floor value))
|
||||
(time (math-round (math-mul (math-sub value (or offset date)) 86400)
|
||||
|
|
@ -594,6 +625,14 @@ in the Gregorian calendar."
|
|||
;; calc-gregorian-switch is a customizable variable defined in calc.el
|
||||
(defvar calc-gregorian-switch)
|
||||
|
||||
(defun math-absolute-from-iso-dt (year week day)
|
||||
"Return the DATE of the day given by the iso8601 day YEAR WEEK DAY."
|
||||
(let* ((janfour (math-absolute-from-gregorian-dt year 1 4))
|
||||
(prevmon (math-sub janfour
|
||||
(cdr (math-idivmod (math-sub janfour 1) 7)))))
|
||||
(math-add
|
||||
(math-add prevmon (* (1- week) 7))
|
||||
(if (zerop day) 6 (1- day)))))
|
||||
|
||||
(defun math-absolute-from-dt (year month day)
|
||||
"Return the DATE of the day given by the day YEAR MONTH DAY.
|
||||
|
|
@ -638,6 +677,10 @@ in the Gregorian calendar."
|
|||
(defvar math-fd-minute)
|
||||
(defvar math-fd-second)
|
||||
(defvar math-fd-bc-flag)
|
||||
(defvar math-fd-iso-dt)
|
||||
(defvar math-fd-isoyear)
|
||||
(defvar math-fd-isoweek)
|
||||
(defvar math-fd-isoweekday)
|
||||
|
||||
(defun math-format-date (math-fd-date)
|
||||
(if (eq (car-safe math-fd-date) 'date)
|
||||
|
|
@ -645,12 +688,14 @@ in the Gregorian calendar."
|
|||
(let ((entry (list math-fd-date calc-internal-prec calc-date-format)))
|
||||
(or (cdr (assoc entry math-format-date-cache))
|
||||
(let* ((math-fd-dt nil)
|
||||
(math-fd-iso-dt nil)
|
||||
(calc-group-digits nil)
|
||||
(calc-leading-zeros nil)
|
||||
(calc-number-radix 10)
|
||||
(calc-twos-complement-mode nil)
|
||||
math-fd-year math-fd-month math-fd-day math-fd-weekday
|
||||
math-fd-hour math-fd-minute math-fd-second
|
||||
math-fd-isoyear math-fd-isoweek math-fd-isoweekday
|
||||
(math-fd-bc-flag nil)
|
||||
(fmt (apply 'concat (mapcar 'math-format-date-part
|
||||
calc-date-format))))
|
||||
|
|
@ -690,6 +735,25 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)."
|
|||
math-julian-date-beginning-int)))
|
||||
((eq x 'U)
|
||||
(math-format-number (nth 1 (math-date-parts math-fd-date 719164))))
|
||||
((memq x '(IYYY Iww w))
|
||||
(progn
|
||||
(or math-fd-iso-dt
|
||||
(setq math-fd-iso-dt (math-date-to-iso-dt math-fd-date)
|
||||
jpb math-fd-date
|
||||
jpbb math-fd-iso-dt
|
||||
math-fd-isoyear (car math-fd-iso-dt)
|
||||
math-fd-isoweek (nth 1 math-fd-iso-dt)
|
||||
math-fd-isoweekday (nth 2 math-fd-iso-dt)))
|
||||
(cond ((eq x 'IYYY)
|
||||
(let* ((neg (Math-negp math-fd-isoyear))
|
||||
(pyear (calcFunc-abs math-fd-isoyear)))
|
||||
(if (and (natnump pyear) (< pyear 10000))
|
||||
(concat (if neg "-" "") (format "%04d" pyear))
|
||||
(concat (if neg "-" "+") (math-format-number pyear)))))
|
||||
((eq x 'Iww)
|
||||
(concat "W" (format "%02d" math-fd-isoweek)))
|
||||
((eq x 'w)
|
||||
(format "%d" math-fd-isoweekday)))))
|
||||
((progn
|
||||
(or math-fd-dt
|
||||
(progn
|
||||
|
|
@ -720,6 +784,15 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)."
|
|||
(if (and (natnump math-fd-year) (< math-fd-year 100))
|
||||
(format "+%d" math-fd-year)
|
||||
(math-format-number math-fd-year)))
|
||||
((eq x 'ZYYY)
|
||||
(let* ((year (if (Math-negp math-fd-year)
|
||||
(math-add math-fd-year 1)
|
||||
math-fd-year))
|
||||
(neg (Math-negp year))
|
||||
(pyear (calcFunc-abs year)))
|
||||
(if (and (natnump pyear) (< pyear 10000))
|
||||
(concat (if neg "-" "") (format "%04d" pyear))
|
||||
(concat (if neg "-" "+") (math-format-number pyear)))))
|
||||
((eq x 'b) "")
|
||||
((eq x 'aa)
|
||||
(and (not math-fd-bc-flag) "ad"))
|
||||
|
|
@ -745,6 +818,7 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)."
|
|||
(and math-fd-bc-flag "b.c."))
|
||||
((eq x 'BBBB)
|
||||
(and math-fd-bc-flag "B.C."))
|
||||
((eq x 'T) "T")
|
||||
((eq x 'M)
|
||||
(format "%d" math-fd-month))
|
||||
((eq x 'MM)
|
||||
|
|
@ -1009,6 +1083,20 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)."
|
|||
(list 'date (math-dt-to-date (append (list year month day)
|
||||
(and hour (list hour minute second))))))
|
||||
|
||||
(defun math-parse-iso-date-validate (isoyear isoweek isoweekday hour minute second)
|
||||
(if (or (< isoweek 1) (> isoweek 53))
|
||||
(throw 'syntax "Week value is out of range"))
|
||||
(and hour
|
||||
(progn
|
||||
(if (or (< hour 0) (> hour 23))
|
||||
(throw 'syntax "Hour value is out of range"))
|
||||
(if (or (< minute 0) (> minute 59))
|
||||
(throw 'syntax "Minute value is out of range"))
|
||||
(if (or (math-negp second) (not (Math-lessp second 60)))
|
||||
(throw 'syntax "Seconds value is out of range"))))
|
||||
(list 'date (math-iso-dt-to-date (append (list isoyear isoweek isoweekday)
|
||||
(and hour (list hour minute second))))))
|
||||
|
||||
(defun math-parse-date-word (names &optional front)
|
||||
(let ((n 1))
|
||||
(while (and names (not (string-match (if (equal (car names) "Sep")
|
||||
|
|
@ -1029,6 +1117,7 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)."
|
|||
(let ((case-fold-search t)
|
||||
(okay t) num
|
||||
(fmt calc-date-format) this next (gnext nil)
|
||||
(isoyear nil) (isoweek nil) (isoweekday nil)
|
||||
(year nil) (month nil) (day nil) (bigyear nil) (yearday nil)
|
||||
(hour nil) (minute nil) (second nil) (bc-flag nil))
|
||||
(while (and fmt okay)
|
||||
|
|
@ -1105,19 +1194,35 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)."
|
|||
(if (string-match "\\`pm\\|p\\.m\\." math-pd-str)
|
||||
(setq hour (if (= hour 12) 12 (% (+ hour 12) 24))
|
||||
math-pd-str (substring math-pd-str (match-end 0))))))
|
||||
((memq this '(Y YY BY YYY YYYY))
|
||||
((memq this '(Y YY BY YYY YYYY ZYYY))
|
||||
(and (if (memq next '(MM DD ddd hh HH mm ss SS))
|
||||
(if (memq this '(Y YY BYY))
|
||||
(string-match "\\` *[0-9][0-9]" math-pd-str)
|
||||
(string-match "\\`[0-9][0-9][0-9][0-9]" math-pd-str))
|
||||
(string-match "\\`[-+]?[0-9]+" math-pd-str))
|
||||
(setq year (math-match-substring math-pd-str 0)
|
||||
bigyear (or (eq this 'YYY)
|
||||
bigyear (or (eq this 'YYY)
|
||||
(memq (aref math-pd-str 0) '(?\+ ?\-)))
|
||||
math-pd-str (substring math-pd-str (match-end 0))
|
||||
year (math-read-number year))))
|
||||
year (math-read-number year))
|
||||
(if (and (eq this 'ZYYY) (eq year 0))
|
||||
(setq year (math-sub year 1)
|
||||
bigyear t)
|
||||
t)))
|
||||
((eq this 'IYYY)
|
||||
(if (string-match "\\`[-+]?[0-9]+" math-pd-str)
|
||||
(setq isoyear (string-to-number (math-match-substring math-pd-str 0))
|
||||
math-pd-str (substring math-pd-str (match-end 0)))))
|
||||
((eq this 'Iww)
|
||||
(if (string-match "W\\([0-9][0-9]\\)" math-pd-str)
|
||||
(setq isoweek (string-to-number (math-match-substring math-pd-str 1))
|
||||
math-pd-str (substring math-pd-str 3))))
|
||||
((eq this 'b)
|
||||
t)
|
||||
((eq this 'T)
|
||||
(if (eq (aref math-pd-str 0) ?T)
|
||||
(setq math-pd-str (substring math-pd-str 1))
|
||||
t))
|
||||
((memq this '(aa AA aaaa AAAA))
|
||||
(if (string-match "\\` *\\(ad\\|a\\.d\\.\\)" math-pd-str)
|
||||
(setq math-pd-str (substring math-pd-str (match-end 0)))))
|
||||
|
|
@ -1152,7 +1257,9 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)."
|
|||
nil))
|
||||
nil)
|
||||
((eq this 'W)
|
||||
(and (>= num 0) (< num 7)))
|
||||
(and (>= num 0) (< num 7)))
|
||||
((eq this 'w)
|
||||
(setq isoweekday num))
|
||||
((memq this '(d ddd bdd))
|
||||
(setq yearday num))
|
||||
((memq this '(M MM BM))
|
||||
|
|
@ -1169,18 +1276,20 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)."
|
|||
(setq yearday nil)
|
||||
(setq month 1 day 1)))
|
||||
(if (and okay (equal math-pd-str ""))
|
||||
(and month day (or (not (or hour minute second))
|
||||
(and hour minute))
|
||||
(progn
|
||||
(or year (setq year (math-this-year)))
|
||||
(or second (setq second 0))
|
||||
(if bc-flag
|
||||
(setq year (math-neg (math-abs year))))
|
||||
(setq day (math-parse-date-validate year bigyear month day
|
||||
hour minute second))
|
||||
(if yearday
|
||||
(setq day (math-add day (1- yearday))))
|
||||
day)))))
|
||||
(if isoyear
|
||||
(math-parse-iso-date-validate isoyear isoweek isoweekday hour minute second)
|
||||
(and month day (or (not (or hour minute second))
|
||||
(and hour minute))
|
||||
(progn
|
||||
(or year (setq year (math-this-year)))
|
||||
(or second (setq second 0))
|
||||
(if bc-flag
|
||||
(setq year (math-neg (math-abs year))))
|
||||
(setq day (math-parse-date-validate year bigyear month day
|
||||
hour minute second))
|
||||
(if yearday
|
||||
(setq day (math-add day (1- yearday))))
|
||||
day))))))
|
||||
|
||||
|
||||
(defun calcFunc-now (&optional zone)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue