155 lines
2.7 KiB
Tal
155 lines
2.7 KiB
Tal
|10 @Console &vector $2 &read $1 &pad $4 &type $1 &write $1 &error $1
|
|
|c0 @DateTime &year $2 &month $1 &day $1 &hour $1 &minute $1 &second $1 &dotw $1 &doty $2 &isdst $1
|
|
|
|
|0000 @buf
|
|
|
|
|0100 ( -> )
|
|
.Console/type DEI ?on-params
|
|
( today )
|
|
.DateTime/doty DEI2 .DateTime/year DEI2 emit-arv #0a18 DEO
|
|
#800f DEO
|
|
BRK
|
|
|
|
(
|
|
@|vectors )
|
|
|
|
@on-params ( -> )
|
|
;on-console .Console/vector DEO2
|
|
BRK
|
|
|
|
@on-console ( -> )
|
|
.Console/read DEI
|
|
DUP #21 LTH ?&validate
|
|
.buf zput
|
|
BRK
|
|
|
|
&validate ( c -> )
|
|
POP
|
|
.buf parse
|
|
BRK
|
|
|
|
(
|
|
@|core )
|
|
|
|
@parse ( ztr -- )
|
|
DUP zlen #05 EQU ?&on-arvgre
|
|
DUP zlen #0a EQU ?&on-grearv
|
|
;&err &w LDAk #19 DEO INC2 LDAk ?&w POP2
|
|
#010f DEO
|
|
JMP2r
|
|
|
|
&on-arvgre ( ztr -- )
|
|
( m ) INCk INC LDZk LIT "A SUB #00 SWP #000e MUL2 STH2
|
|
( d ) INC bytedec STH2r ADD2 INC2
|
|
( y ) ROT bytedec #07d6 ADD2
|
|
emit-gre
|
|
#0a18 DEO
|
|
#800f DEO
|
|
JMP2r
|
|
|
|
&on-grearv ( ztr -- )
|
|
( y ) STHk shortdec LIT2r 0005 ADD2r
|
|
DUP2
|
|
( m ) STHkr bytedec INCr INCr INCr
|
|
( d ) STHr bytedec #0001 SUB2 doty
|
|
SWP2
|
|
emit-arv
|
|
#0a18 DEO
|
|
#800f DEO
|
|
JMP2r
|
|
&err "usage: 20 "arvelie.rom 20 "YYYY-MM-DD 0a $1
|
|
|
|
@emit-gre ( doty* year* -- )
|
|
DUP2 emit-dec2 [ LIT2 "- 18 ] DEO
|
|
,&y STR2
|
|
STH2
|
|
#0c00
|
|
&l
|
|
DUP [ LIT2 &y $2 ] ROT diam #00 SWP
|
|
DUP2 STH2kr GTH2 ?&skip
|
|
STH2k SUB2r !&continue
|
|
&skip
|
|
POP2 !&end
|
|
&continue
|
|
POP2
|
|
INC GTHk ?&l
|
|
&end
|
|
NIP INC emit-dec [ LIT2 "- 18 ] DEO
|
|
STHr POPr
|
|
!emit-dec
|
|
|
|
@emit-arv ( doty* year* -- )
|
|
#07d6 SUB2 NIP
|
|
( year ) emit-dec
|
|
( month ) DUP2 #000e DIV2 NIP #11 ADD emit-num
|
|
( digit3 ) #000e [ DIV2k MUL2 SUB2 ] NIP
|
|
!emit-dec
|
|
|
|
@emit-dec2 ( short* -- )
|
|
#0064 DIV2k DUP emit-dec
|
|
MUL2 SUB2 NIP
|
|
@emit-dec ( byte -- )
|
|
DUP #0a DIV emit-num
|
|
#0a DIVk MUL SUB
|
|
@emit-num ( num -- )
|
|
LIT "0 ADD #18 DEO
|
|
JMP2r
|
|
|
|
(
|
|
@|utils )
|
|
|
|
@doty ( year* month* day* -- doty* )
|
|
ROT2 ,&y STR2
|
|
LIT2r 0000
|
|
SWP2 NIP #01 SUB #00
|
|
&l
|
|
#00 OVR [ LIT2 &y $2 ] ROT diam STH2 ADD2r
|
|
INC GTHk ?&l
|
|
POP2
|
|
STH2r ADD2
|
|
JMP2r
|
|
|
|
@diam ( year* month -- days )
|
|
#00 OVR ;&m ADD2 LDA
|
|
SWP #01 NEQ ?&no-feb
|
|
STH DUP2 is-leap-year STHr ADD
|
|
&no-feb
|
|
NIP NIP
|
|
JMP2r
|
|
&m [ 1f 1c 1f 1e 1f 1e 1f 1f 1e 1f 1e 1f ]
|
|
|
|
@is-leap-year ( year* -- bool )
|
|
( leap year if perfectly divisible by 400 )
|
|
DUP2 #0190 ( MOD2 ) DIV2k MUL2 SUB2 #0000 EQU2 ?&leap
|
|
( not a leap year if divisible by 100, but not divisible by 400 )
|
|
DUP2 #0064 ( MOD2 ) DIV2k MUL2 SUB2 #0000 EQU2 ?¬-leap
|
|
( leap year if not divisible by 100, but divisible by 4 )
|
|
#0003 AND2 #0000 EQU2
|
|
JMP2r
|
|
¬-leap
|
|
POP2 #00
|
|
JMP2r
|
|
&leap
|
|
POP2 #01
|
|
JMP2r
|
|
|
|
@shortdec ( zp -- dec* )
|
|
DUP bytedec #0064 MUL2
|
|
ROT INC INC bytedec ADD2
|
|
JMP2r
|
|
|
|
@bytedec ( zp -- dec* )
|
|
LDZ2
|
|
LIT "0 SUB
|
|
SWP LIT "0 SUB #0a MUL ADD
|
|
#00 SWP
|
|
JMP2r
|
|
|
|
(
|
|
@|stdlib )
|
|
|
|
@zlen ( ztr -- len ) DUP zcap SWP SUB JMP2r
|
|
@zcap ( ztr -- end ) LDZk ?&w JMP2r &w INC LDZk ?&w JMP2r
|
|
@zput ( c ztr -- ) zcap STZ JMP2r
|
|
|