mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-07-26 16:28:59 +00:00
229 lines
3.4 KiB
Forth
229 lines
3.4 KiB
Forth
|
|
\ *** Block No. 0, Hexblock 0
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 1, Hexblock 1
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 2, Hexblock 2
|
|
|
|
\ CASE OF ENDOF END-CASE BREAK jrg 30mai89
|
|
|
|
: CASE ( n -- n n ) dup ; restrict
|
|
|
|
: OF [compile] IF compile drop ; immediate restrict
|
|
|
|
: ENDOF [compile] ELSE 4+ ; immediate restrict
|
|
|
|
: ENDCASE compile drop
|
|
BEGIN
|
|
3 case?
|
|
WHILE
|
|
>resolve
|
|
REPEAT ; immediate restrict
|
|
|
|
: BREAK compile exit [compile] THEN ; immediate restrict
|
|
|
|
\ *** Block No. 3, Hexblock 3
|
|
|
|
\ =or jrg 06okt88
|
|
|
|
code =or ( n1 f1 n2 -- n1 f2 )
|
|
A D xchg D pop
|
|
S W mov
|
|
W ) A cmp
|
|
0= ?[ -1 # D mov ]?
|
|
next
|
|
end-code
|
|
|
|
\ : =or ( n1 f1 n2 -- n1 f2 ) 2 pick = or ;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 4, Hexblock 4
|
|
|
|
\ leapyear? nach Wil Baden VD 2/87 S.42 jrg 30mai89
|
|
|
|
| : leapyear? ( year# -- f : true falls Jahr = Schaltjahr )
|
|
CASE 400 mod 0= OF true BREAK
|
|
CASE 100 mod 0= OF false BREAK
|
|
CASE 4 mod 0= OF true BREAK
|
|
drop false ;
|
|
|
|
\\ nach Kaiser, Grundlegende Elemente ... S.160, Birkhäuser
|
|
|
|
: leapyear? ( year# -- f : true falls Jahr = Schaltjahr )
|
|
dup 4 mod 0= ( y# f)
|
|
swap dup 100 mod 0<> ( f1 y# f2 )
|
|
rot and ( y# f3 )
|
|
swap 400 mod 0= or ;
|
|
|
|
|
|
\ *** Block No. 5, Hexblock 5
|
|
|
|
\ Monatsnamen jrg 30mai89
|
|
| 1 Constant jan
|
|
| 2 Constant feb
|
|
| 3 Constant mär
|
|
| 4 Constant apr
|
|
| 5 Constant mai
|
|
| 6 Constant jun
|
|
| 7 Constant jul
|
|
| 8 Constant aug
|
|
| 9 Constant sep
|
|
| 10 Constant okt
|
|
| 11 Constant nov
|
|
| 12 Constant dez
|
|
|
|
\\
|
|
| Create months ," janfebmäraprmaijunjulaugsepoktnovdez"
|
|
|
|
\ *** Block No. 6, Hexblock 6
|
|
|
|
\ Tage im Monat jrg 30mai89
|
|
|
|
: #days ( month# -- days-in-month )
|
|
CASE jan = apr =or jun =or nov =or OF 30 BREAK
|
|
CASE feb = not OF 31 BREAK
|
|
drop leapyear? IF 29 ELSE 28 THEN ;
|
|
|
|
: .all
|
|
12 1+ 1
|
|
DO cr
|
|
I .
|
|
I >months type ." hat "
|
|
I #days . ." Tage."
|
|
LOOP ;
|
|
|
|
|
|
|
|
\ *** Block No. 7, Hexblock 7
|
|
|
|
% Schaltjahr ? jrg 30mai89
|
|
|
|
Bei der Entscheidung, ob eine Jahreszahl ein Schaltjahr be-
|
|
zeichnet, werden zunächst die ohne Rest durch 4 teilbaren Jahre
|
|
durch
|
|
JAHR MOD 4 = 0
|
|
erkannt. Die ohne Rest durch 100 teilbaren Jahre werden durch
|
|
|
|
(JAHR MOD 4 = 0) AND (JAHR MOD 100 <> 0)
|
|
|
|
"entfernt".
|
|
Dazu werden die ohne Rest durch 400 teilbaren Jahreszahlen hin-
|
|
zugefügt:
|
|
|
|
((JAHR MOD 4 = 0) AND (JAHR MOD 100 <> 0)) OR (JAHR MOD 400 = 0)
|
|
|
|
|
|
\ *** Block No. 8, Hexblock 8
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 9, Hexblock 9
|
|
|
|
% Schaltjahr ? jrg 30mai89
|
|
|
|
Bei der Entscheidung, ob eine Jahreszahl ein Schaltjahr be-
|
|
zeichnet, werden zunächst die ohne Rest durch 4 teilbaren Jahre
|
|
durch
|
|
JAHR MOD 4 = 0
|
|
erkannt. Die ohne Rest durch 100 teilbaren Jahre werden durch
|
|
|
|
(JAHR MOD 4 = 0) AND (JAHR MOD 100 <> 0)
|
|
|
|
"entfernt".
|
|
Dazu werden die ohne Rest durch 400 teilbaren Jahreszahlen hin-
|
|
zugefügt:
|
|
|
|
((JAHR MOD 4 = 0) AND (JAHR MOD 100 <> 0)) OR (JAHR MOD 400 = 0)
|
|
|
|
|
|
\ *** Block No. 10, Hexblock a
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 11, Hexblock b
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|