Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
emacs
emacs
Commits
ff35f3b8
Commit
ff35f3b8
authored
Apr 02, 2008
by
Glenn Morris
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
(calendar-time-zone-daylight-rules): Simplify.
parent
2d354894
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
35 additions
and
43 deletions
+35
-43
lisp/calendar/cal-dst.el
lisp/calendar/cal-dst.el
+35
-43
No files found.
lisp/calendar/cal-dst.el
View file @
ff35f3b8
...
...
@@ -193,62 +193,54 @@ The result has the proper form for `calendar-daylight-savings-starts'."
(
d
(
extract-calendar-day
date
))
(
y
(
extract-calendar-year
date
))
(
last
(
calendar-last-day-of-month
m
y
))
(
candidate-rules
j
rlist
(
candidate-rules
; these return Gregorian dates
(
append
;; Day D of month M.
(
list
(
list
'list
m
d
'
year
))
`
((
list
,
m
,
d
year
))
;; The first WEEKDAY of month M.
(
if
(
<
d
8
)
(
list
(
list
'
calendar-nth-named-day
1
weekday
m
'
year
)))
`
((
calendar-nth-named-day
1
,
weekday
,
m
year
)))
;; The last WEEKDAY of month M.
(
if
(
>
d
(
-
last
7
))
(
list
(
list
'calendar-nth-named-day
-1
weekday
m
'year
)))
;; The first WEEKDAY after day J of month M, for D-6 < J <= D.
(
let
(
l
)
(
calendar-for-loop
j
from
(
max
2
(
-
d
6
))
to
(
min
d
(
-
last
8
))
do
(
setq
l
(
cons
(
list
'calendar-nth-named-day
1
weekday
m
'year
j
)
l
)))
l
)
`
((
calendar-nth-named-day
-1
,
weekday
,
m
year
)))
(
progn
;; The first WEEKDAY after day J of month M, for D-6 < J <= D.
(
setq
j
(
1-
(
max
2
(
-
d
6
))))
(
while
(
<=
(
setq
j
(
1+
j
))
(
min
d
(
-
last
8
)))
(
push
`
(
calendar-nth-named-day
1
,
weekday
,
m
year
,
j
)
rlist
))
rlist
)
;; 01-01 and 07-01 for this year's Persian calendar.
;; FIXME what does the Persian calendar have to do with this?
(
if
(
and
(
=
m
3
)
(
<=
20
d
)
(
<=
d
21
))
'
((
calendar-gregorian-from-absolute
(
calendar-absolute-from-persian
(
list
1
1
(
-
year
621
))))))
(
calendar-absolute-from-persian
`
(
1
1
,
(
-
year
621
))))))
(
if
(
and
(
=
m
9
)
(
<=
22
d
)
(
<=
d
23
))
'
((
calendar-gregorian-from-absolute
(
calendar-absolute-from-persian
(
list
7
1
(
-
year
621
))))))))
(
calendar-absolute-from-persian
`
(
7
1
,
(
-
year
621
))))))))
(
prevday-sec
(
-
-1
utc-diff
))
; last sec of previous local day
(
year
(
1+
y
)))
(
year
(
1+
y
))
new-rules
)
;; Scan through the next few years until only one rule remains.
(
while
(
let
((
rules
candidate-rules
)
new-rules
)
(
dolist
(
rule
rules
)
(
let
((
date
;; The following is much faster than
;; (calendar-absolute-from-gregorian (eval rule)).
(
cond
((
eq
(
car
rule
)
'calendar-nth-named-day
)
(
eval
(
cons
'calendar-nth-named-absday
(
cdr
rule
))))
((
eq
(
car
rule
)
'calendar-gregorian-from-absolute
)
(
eval
(
cadr
rule
)))
(
t
(
calendar-absolute-from-gregorian
(
eval
rule
))))))
(
or
(
equal
(
current-time-zone
(
calendar-time-from-absolute
date
prevday-sec
))
(
current-time-zone
(
calendar-time-from-absolute
(
1+
date
)
prevday-sec
)))
(
setq
new-rules
(
cons
rule
new-rules
)))))
;; If no rules remain, just use the first candidate rule;
;; it's wrong in general, but it's right for at least one year.
(
setq
candidate-rules
(
if
new-rules
(
nreverse
new-rules
)
(
list
(
car
candidate-rules
)))
year
(
1+
year
))
(
cdr
candidate-rules
)))
(
while
(
cdr
candidate-rules
)
(
dolist
(
rule
candidate-rules
)
;; The rule we return should give a Gregorian date, but here
;; we require an absolute date. The following is for efficiency.
(
setq
date
(
cond
((
eq
(
car
rule
)
'calendar-nth-named-day
)
(
eval
(
cons
'calendar-nth-named-absday
(
cdr
rule
))))
((
eq
(
car
rule
)
'calendar-gregorian-from-absolute
)
(
eval
(
cdr
rule
)))
(
t
(
calendar-absolute-from-gregorian
(
eval
rule
)))))
(
or
(
equal
(
current-time-zone
(
calendar-time-from-absolute
date
prevday-sec
))
(
current-time-zone
(
calendar-time-from-absolute
(
1+
date
)
prevday-sec
)))
(
setq
new-rules
(
cons
rule
new-rules
))))
;; If no rules remain, just use the first candidate rule;
;; it's wrong in general, but it's right for at least one year.
(
setq
candidate-rules
(
if
new-rules
(
nreverse
new-rules
)
(
list
(
car
candidate-rules
)))
year
(
1+
year
)))
(
car
candidate-rules
)))
;; TODO it might be better to extract this information directly from
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment