MSP430-FORTH/RTC.f

   1 \ -*- coding: utf-8 -*-
   2 \
   3 \ ==============================================================================
   4 \ routines RTC for MSP430FR5xxx
   5 \ your target must have a LF_XTAL 32768Hz
   6 \ ==============================================================================
   7 \
   8 \ to see kernel options, download FastForthSpecs.f
   9 \ FastForth kernel minimal addons: MSP430ASSEMBLER, CONDCOMP
  10 \
  11 \ TARGET SELECTION ( = the name of \INC\target.pat file without the extension)
  12 \ MSP_EXP430FR5739  MSP_EXP430FR5969    MSP_EXP430FR5994    MSP_EXP430FR6989
  13 \
  14 \ from scite editor : copy your target selection in (shift+F8) parameter 1:
  15 \
  16 \ or, from windows explorer:
  17 \ drag and drop this file onto SendSourceFileToTarget.bat
  18 \ then select your TARGET when asked.
  19 \
  20 \ ASSEMBLER REGISTERS USAGE
  21 \ R4 to R7 must be saved before use and restored after
  22 \ scratch registers Y to S are free for use
  23 \ under interrupt, IP is free for use
  24 \
  25 \ PUSHM order : PSP,TOS, IP,  S,  T,  W,  X,  Y, rEXIT,rDOVAR,rDOCON, rDODOES, R3, SR,RSP, PC
  26 \ PUSHM order : R15,R14,R13,R12,R11,R10, R9, R8,  R7  ,  R6  ,  R5  ,   R4   , R3, R2, R1, R0
  27 \
  28 \ example : PUSHM #6,IP pushes IP,S,T,W,X,Y registers to return stack
  29 \
  30 \ POPM  order :  PC,RSP, SR, R3, rDODOES,rDOCON,rDOVAR,rEXIT,  Y,  X,  W,  T,  S, IP,TOS,PSP
  31 \ POPM  order :  R0, R1, R2, R3,   R4   ,  R5  ,  R6  ,  R7 , R8, R9,R10,R11,R12,R13,R14,R15
  32 \
  33 \ example : POPM #6,IP   pop Y,X,W,T,S,IP registers from return stack
  34 \
  35 \
  36 \ FORTH conditionnals:  unary{ 0= 0< 0> }, binary{ = < > U< }
  37 \
  38 \ ASSEMBLER conditionnal usage with IF UNTIL WHILE  S<  S>=  U<   U>=  0=  0<>  0>=
  39 \ ASSEMBLER conditionnal usage with ?JMP ?GOTO      S<  S>=  U<   U>=  0=  0<>  0<
  40 \
  41 \
  42
  43     CODE ABORT_RTC
  44     SUB #4,PSP
  45     MOV TOS,2(PSP)
  46     MOV &KERNEL_ADDON,TOS
  47     BIT #BIT14,TOS
  48     0<> IF MOV #0,TOS THEN  \ if TOS <> 0 (FIXPOINT input), set TOS = 0
  49     MOV TOS,0(PSP)
  50     MOV &VERSION,TOS
  51     SUB #309,TOS        \                   FastForth V3.9
  52     COLON
  53     $0D EMIT            \ return to column 1 without CR
  54     ABORT" FastForth V3.9 please!"
  55     ABORT" target without LF_XTAL !"
  56     RST_RET             \ if no abort remove this word
  57     ;
  58
  59     ABORT_RTC
  60
  61 ; --------------------
  62 ; RTC.f
  63 ; --------------------
  64
  65 \ use :
  66 \ to set date, type : d m y DATE!
  67 \ to view date, type DATE?
  68 \ to set time, type : h m [s] TIME!
  69 \ to view time, type TIME?
  70 \
  71
  72     MARKER {RTC}
  73
  74 \ https://forth-standard.org/standard/core/OR
  75 \ C OR     x1 x2 -- x3           logical OR
  76     [UNDEFINED] OR
  77     [IF]
  78     CODE OR
  79     BIS @PSP+,TOS
  80     MOV @IP+,PC
  81     ENDCODE
  82     [THEN]
  83
  84 \ https://forth-standard.org/standard/core/CFetch
  85 \ C@     c-addr -- char   fetch char from memory
  86     [UNDEFINED] C@
  87     [IF]
  88     CODE C@
  89     MOV.B @TOS,TOS
  90     MOV @IP+,PC
  91     ENDCODE
  92     [THEN]
  93
  94 \ https://forth-standard.org/standard/core/CStore
  95 \ C!      char c-addr --    store char in memory
  96     [UNDEFINED] C!
  97     [IF]
  98     CODE C!
  99     MOV.B @PSP+,0(TOS)  \ 4
 100     ADD #1,PSP          \ 1
 101     MOV @PSP+,TOS       \ 2
 102     MOV @IP+,PC
 103     ENDCODE
 104     [THEN]
 105
 106 \ https://forth-standard.org/standard/core/SWAP
 107 \ SWAP     x1 x2 -- x2 x1    swap top two items
 108     [UNDEFINED] SWAP
 109     [IF]
 110     CODE SWAP
 111     MOV @PSP,W      \ 2
 112     MOV TOS,0(PSP)  \ 3
 113     MOV W,TOS       \ 1
 114     MOV @IP+,PC     \ 4
 115     ENDCODE
 116     [THEN]
 117
 118 \ https://forth-standard.org/standard/core/OVER
 119 \ OVER    x1 x2 -- x1 x2 x1
 120     [UNDEFINED] OVER
 121     [IF]
 122     CODE OVER
 123     MOV TOS,-2(PSP)     \ 3 -- x1 (x2) x2
 124     MOV @PSP,TOS        \ 2 -- x1 (x2) x1
 125     SUB #2,PSP          \ 1 -- x1 x2 x1
 126     MOV @IP+,PC
 127     ENDCODE
 128     [THEN]
 129
 130 \ https://forth-standard.org/standard/core/DUP
 131 \ DUP      x -- x x      duplicate top of stack
 132     [UNDEFINED] DUP
 133     [IF]    \define DUP and DUP?
 134     CODE DUP
 135 BW1 SUB #2,PSP      \ 2  push old TOS..
 136     MOV TOS,0(PSP)  \ 3  ..onto stack
 137     MOV @IP+,PC     \ 4
 138     ENDCODE
 139
 140 \ https://forth-standard.org/standard/core/qDUP
 141 \ ?DUP     x -- 0 | x x    DUP if nonzero
 142     CODE ?DUP
 143     CMP #0,TOS      \ 2  test for TOS nonzero
 144     0<> ?GOTO BW1   \ 2
 145     MOV @IP+,PC     \ 4
 146     ENDCODE
 147     [THEN]
 148
 149 \ https://forth-standard.org/standard/core/DROP
 150 \ DROP     x --          drop top of stack
 151     [UNDEFINED] DROP
 152     [IF]
 153     CODE DROP
 154     MOV @PSP+,TOS   \ 2
 155     MOV @IP+,PC     \ 4
 156     ENDCODE
 157     [THEN]
 158
 159 \ https://forth-standard.org/standard/core/DEPTH
 160 \ DEPTH    -- +n        number of items on stack, must leave 0 if stack empty
 161     [UNDEFINED] DEPTH
 162     [IF]
 163     CODE DEPTH
 164     MOV TOS,-2(PSP)
 165     MOV #PSTACK,TOS
 166     SUB PSP,TOS     \ PSP-S0--> TOS
 167     RRA TOS         \ TOS/2   --> TOS
 168     SUB #2,PSP      \ post decrement stack...
 169     MOV @IP+,PC
 170     ENDCODE
 171     [THEN]
 172
 173 \ https://forth-standard.org/standard/core/toR
 174 \ >R    x --   R: -- x   push to return stack
 175     [UNDEFINED] >R
 176     [IF]
 177     CODE >R
 178     PUSH TOS        \ 3
 179     MOV @PSP+,TOS   \ 2
 180     MOV @IP+,PC     \ 4
 181     ENDCODE
 182     [THEN]
 183
 184 \ https://forth-standard.org/standard/core/Rfrom
 185 \ R>    -- x    R: x --   pop from return stack ; CALL #RFROM performs DOVAR
 186     [UNDEFINED] R>
 187     [IF]
 188     CODE R>
 189     SUB #2,PSP      \ 1
 190     MOV TOS,0(PSP)  \ 3
 191     MOV @RSP+,TOS   \ 2
 192     MOV @IP+,PC     \ 4
 193     ENDCODE
 194     [THEN]
 195
 196 \ https://forth-standard.org/standard/core/OnePlus
 197 \ 1+      n1/u1 -- n2/u2       add 1 to TOS
 198     [UNDEFINED] 1+
 199     [IF]
 200     CODE 1+
 201     ADD #1,TOS
 202     MOV @IP+,PC
 203     ENDCODE
 204     [THEN]
 205
 206 \ https://forth-standard.org/standard/core/OneMinus
 207 \ 1-      n1/u1 -- n2/u2     subtract 1 from TOS
 208     [UNDEFINED] 1-
 209     [IF]
 210     CODE 1-
 211     SUB #1,TOS
 212     MOV @IP+,PC
 213     ENDCODE
 214     [THEN]
 215
 216     [UNDEFINED] U<
 217     [IF]
 218     CODE U<
 219     SUB @PSP+,TOS   \ 2 u2-u1
 220     0<> IF
 221         MOV #-1,TOS     \ 1
 222         U< IF           \ 2 flag
 223             AND #0,TOS  \ 1 flag Z = 1
 224         THEN
 225     THEN
 226     MOV @IP+,PC     \ 4
 227     ENDCODE
 228     [THEN]
 229
 230 \ https://forth-standard.org/standard/core/Equal
 231 \ =      x1 x2 -- flag         test x1=x2
 232     [UNDEFINED] =
 233     [IF]
 234     CODE =
 235     SUB @PSP+,TOS   \ 2
 236     0<> IF          \ 2
 237         AND #0,TOS  \ 1
 238         MOV @IP+,PC \ 4
 239     THEN
 240     XOR #-1,TOS     \ 1 flag Z = 1
 241     MOV @IP+,PC     \ 4
 242     ENDCODE
 243     [THEN]
 244
 245 \ https://forth-standard.org/standard/core/IF
 246 \ IF       -- IFadr    initialize conditional forward branch
 247     [UNDEFINED] IF
 248     [IF]     \ define IF THEN
 249     CODE IF       \ immediate
 250     SUB #2,PSP              \
 251     MOV TOS,0(PSP)          \
 252     MOV &DP,TOS             \ -- HERE
 253     ADD #4,&DP            \           compile one word, reserve one word
 254     MOV #QFBRAN,0(TOS)      \ -- HERE   compile QFBRAN
 255     ADD #2,TOS              \ -- HERE+2=IFadr
 256     MOV @IP+,PC
 257     ENDCODE IMMEDIATE
 258
 259 \ https://forth-standard.org/standard/core/THEN
 260 \ THEN     IFadr --                resolve forward branch
 261     CODE THEN               \ immediate
 262     MOV &DP,0(TOS)          \ -- IFadr
 263     MOV @PSP+,TOS           \ --
 264     MOV @IP+,PC
 265     ENDCODE IMMEDIATE
 266     [THEN]
 267
 268 \ https://forth-standard.org/standard/core/ELSE
 269 \ ELSE     IFadr -- ELSEadr        resolve forward IF branch, leave ELSEadr on stack
 270     [UNDEFINED] ELSE
 271     [IF]
 272     CODE ELSE     \ immediate
 273     ADD #4,&DP              \ make room to compile two words
 274     MOV &DP,W               \ W=HERE+4
 275     MOV #BRAN,-4(W)
 276     MOV W,0(TOS)            \ HERE+4 ==> [IFadr]
 277     SUB #2,W                \ HERE+2
 278     MOV W,TOS               \ -- ELSEadr
 279     MOV @IP+,PC
 280     ENDCODE IMMEDIATE
 281     [THEN]
 282
 283 \ https://forth-standard.org/standard/core/DO
 284 \ DO       -- DOadr   L: -- 0
 285     [UNDEFINED] DO
 286     [IF]                \ define DO LOOP +LOOP
 287     HDNCODE XDO         \ DO run time
 288     MOV #$8000,X        \ 2 compute 8000h-limit = "fudge factor"
 289     SUB @PSP+,X         \ 2
 290     MOV TOS,Y           \ 1 loop ctr = index+fudge
 291     ADD X,Y             \ 1 Y = INDEX
 292     PUSHM #2,X          \ 4 PUSHM X,Y, i.e. PUSHM LIMIT, INDEX
 293     MOV @PSP+,TOS       \ 2
 294     MOV @IP+,PC         \ 4
 295     ENDCODE
 296
 297     CODE DO
 298     SUB #2,PSP              \
 299     MOV TOS,0(PSP)          \
 300     ADD #2,&DP              \   make room to compile xdo
 301     MOV &DP,TOS             \ -- HERE+2
 302     MOV #XDO,-2(TOS)        \   compile xdo
 303     ADD #2,&LEAVEPTR        \ -- HERE+2     LEAVEPTR+2
 304     MOV &LEAVEPTR,W         \
 305     MOV #0,0(W)             \ -- HERE+2     L-- 0
 306     MOV @IP+,PC
 307     ENDCODE IMMEDIATE
 308
 309 \ https://forth-standard.org/standard/core/LOOP
 310 \ LOOP    DOadr --         L-- an an-1 .. a1 0
 311     HDNCODE XLOOP       \   LOOP run time
 312     ADD #1,0(RSP)       \ 4 increment INDEX
 313 BW1 BIT #$100,SR        \ 2 is overflow bit set?
 314     0= IF               \   branch if no overflow
 315         MOV @IP,IP
 316         MOV @IP+,PC
 317     THEN
 318     ADD #4,RSP          \ 1 empties RSP
 319     ADD #2,IP           \ 1 overflow = loop done, skip branch ofs
 320     MOV @IP+,PC         \ 4 14~ taken or not taken xloop/loop
 321     ENDCODE             \
 322
 323     CODE LOOP
 324     MOV #XLOOP,X
 325 BW2 ADD #4,&DP              \ make room to compile two words
 326     MOV &DP,W
 327     MOV X,-4(W)             \ xloop --> HERE
 328     MOV TOS,-2(W)           \ DOadr --> HERE+2
 329     BEGIN                   \ resolve all "leave" adr
 330         MOV &LEAVEPTR,TOS   \ -- Adr of top LeaveStack cell
 331         SUB #2,&LEAVEPTR    \ --
 332         MOV @TOS,TOS        \ -- first LeaveStack value
 333         CMP #0,TOS          \ -- = value left by DO ?
 334     0<> WHILE
 335         MOV W,0(TOS)        \ move adr after loop as UNLOOP adr
 336     REPEAT
 337     MOV @PSP+,TOS
 338     MOV @IP+,PC
 339     ENDCODE IMMEDIATE
 340
 341 \ https://forth-standard.org/standard/core/PlusLOOP
 342 \ +LOOP   adrs --   L-- an an-1 .. a1 0
 343     HDNCODE XPLOO   \   +LOOP run time
 344     ADD TOS,0(RSP)  \ 4 increment INDEX by TOS value
 345     MOV @PSP+,TOS   \ 2 get new TOS, doesn't change flags
 346     GOTO BW1        \ 2
 347     ENDCODE         \
 348
 349     CODE +LOOP
 350     MOV #XPLOO,X
 351     GOTO BW2        \ goto BW1 LOOP
 352     ENDCODE IMMEDIATE
 353     [THEN]
 354
 355 \ https://forth-standard.org/standard/core/BEGIN
 356 \ BEGIN    -- BEGINadr             initialize backward branch
 357     [UNDEFINED] BEGIN
 358     [IF]  \ define BEGIN UNTIL AGAIN WHILE REPEAT
 359
 360     CODE BEGIN
 361     MOV #HEREXEC,PC
 362     ENDCODE IMMEDIATE
 363
 364 \ https://forth-standard.org/standard/core/UNTIL
 365 \ UNTIL    BEGINadr --             resolve conditional backward branch
 366     CODE UNTIL
 367     MOV #QFBRAN,X
 368 BW1 ADD #4,&DP          \ compile two words
 369     MOV &DP,W           \ W = HERE
 370     MOV X,-4(W)         \ compile Bran or QFBRAN at HERE
 371     MOV TOS,-2(W)       \ compile bakcward adr at HERE+2
 372     MOV @PSP+,TOS
 373     MOV @IP+,PC
 374     ENDCODE IMMEDIATE
 375
 376 \ https://forth-standard.org/standard/core/AGAIN
 377 \ AGAIN    BEGINadr --             resolve uncondionnal backward branch
 378     CODE AGAIN
 379     MOV #BRAN,X
 380     GOTO BW1
 381     ENDCODE IMMEDIATE
 382
 383 \ https://forth-standard.org/standard/core/WHILE
 384 \ WHILE    BEGINadr -- WHILEadr BEGINadr
 385     : WHILE
 386     POSTPONE IF SWAP
 387     ; IMMEDIATE
 388
 389 \ https://forth-standard.org/standard/core/REPEAT
 390 \ REPEAT   WHILEadr BEGINadr --     resolve WHILE loop
 391     : REPEAT
 392     POSTPONE AGAIN POSTPONE THEN
 393     ; IMMEDIATE
 394     [THEN]
 395
 396 \ https://forth-standard.org/standard/core/CASE
 397     [UNDEFINED] CASE
 398     [IF]
 399     : CASE
 400     0
 401     ; IMMEDIATE \ -- #of-1
 402
 403 \ https://forth-standard.org/standard/core/OF
 404     : OF \ #of-1 -- orgOF #of
 405     1+                      \ count OFs
 406     >R                      \ move off the stack in case the control-flow stack is the data stack.
 407     POSTPONE OVER POSTPONE = \ copy and test case value
 408     POSTPONE IF             \ add orig to control flow stack
 409     POSTPONE DROP               \ discards case value if =
 410     R>                      \ we can bring count back now
 411     ; IMMEDIATE
 412
 413 \ https://forth-standard.org/standard/core/ENDOF
 414     : ENDOF \ orgOF #of -- orgENDOF #of
 415     >R                      \ move off the stack in case the control-flow stack is the data stack.
 416     POSTPONE ELSE
 417     R>                      \ we can bring count back now
 418     ; IMMEDIATE
 419
 420 \ https://forth-standard.org/standard/core/ENDCASE
 421     : ENDCASE \ orgENDOF1..orgENDOFn #of --
 422     POSTPONE DROP
 423     0 DO
 424         POSTPONE THEN
 425     LOOP
 426     ; IMMEDIATE
 427     [THEN]
 428
 429 \ https://forth-standard.org/standard/core/Plus
 430 \ +       n1/u1 n2/u2 -- n3/u3
 431     [UNDEFINED] +
 432     [IF]
 433     CODE +
 434     ADD @PSP+,TOS
 435     MOV @IP+,PC
 436     ENDCODE
 437     [THEN]
 438
 439 \ https://forth-standard.org/standard/core/Minus
 440 \ -      n1/u1 n2/u2 -- n3/u3     n3 = n1-n2
 441     [UNDEFINED] -
 442     [IF]
 443     CODE -
 444     SUB @PSP+,TOS   \ 2  -- n2-n1 ( = -n3)
 445     XOR #-1,TOS     \ 1
 446     ADD #1,TOS      \ 1  -- n3 = -(n2-n1) = n1-n2
 447     MOV @IP+,PC
 448     ENDCODE
 449     [THEN]
 450
 451     [UNDEFINED] MAX
 452     [IF]            \define MAX and MIN
 453     CODE MAX        \    n1 n2 -- n3       signed maximum
 454     CMP @PSP,TOS    \ n2-n1
 455     S<  ?GOTO FW1   \ n2<n1
 456 BW1 ADD #2,PSP
 457     MOV @IP+,PC
 458     ENDCODE
 459
 460     CODE MIN        \    n1 n2 -- n3       signed minimum
 461     CMP @PSP,TOS    \ n2-n1
 462     S<  ?GOTO BW1   \ n2<n1
 463 FW1 MOV @PSP+,TOS
 464     MOV @IP+,PC
 465     ENDCODE
 466
 467     [THEN]  \ MAX
 468
 469 \ https://forth-standard.org/standard/core/TwoTimes
 470 \ 2*      x1 -- x2         arithmetic left shift
 471     [UNDEFINED] 2*
 472     [IF]
 473     CODE 2*
 474     ADD TOS,TOS
 475     MOV @IP+,PC
 476     ENDCODE
 477     [THEN]
 478
 479 \ https://forth-standard.org/standard/core/UMTimes
 480 \ UM*     u1 u2 -- udlo udhi   unsigned 16x16->32 mult.
 481     [UNDEFINED] UM*
 482     [IF]    \ case of hardware_MPY
 483     CODE UM*
 484     MOV @PSP,&MPY       \ Load 1st operand for unsigned multiplication
 485 BW1 MOV TOS,&OP2        \ Load 2nd operand
 486     MOV &RES0,0(PSP)    \ low result on stack
 487     MOV &RES1,TOS       \ high result in TOS
 488     MOV @IP+,PC
 489     ENDCODE
 490
 491 \ https://forth-standard.org/standard/core/MTimes
 492 \ M*     n1 n2 -- dlo dhi  signed 16*16->32 multiply
 493     CODE M*
 494     MOV @PSP,&MPYS      \ Load 1st operand for signed multiplication
 495     GOTO BW1
 496     ENDCODE
 497     [THEN]
 498
 499 \ https://forth-standard.org/standard/core/UMDivMOD
 500 \ UM/MOD   udlo|udhi u1 -- ur uq   unsigned 32/16->r16 q16
 501     [UNDEFINED] UM/MOD
 502     [IF]
 503     CODE UM/MOD
 504     PUSH #DROP      \
 505     MOV #MUSMOD,PC  \ execute MUSMOD then return to DROP
 506     ENDCODE
 507     [THEN]
 508
 509 \ U*/     u1 u2 u3 -- uq        u1*u2/u3
 510     : U*/
 511     >R UM* R> UM/MOD SWAP DROP
 512     ;
 513
 514 \ U/MOD   u1 u2 -- ur uq     unsigned division
 515     : U/MOD
 516     0 SWAP UM/MOD
 517     ;
 518
 519 \ UMOD   u1 u2 -- ur        unsigned division
 520     : UMOD
 521     U/MOD DROP
 522     ;
 523
 524 \ https://forth-standard.org/standard/core/Div
 525 \ U/      u1 u2 -- uq       signed quotient
 526     : U/
 527     U/MOD SWAP DROP
 528     ;
 529
 530 \ https://forth-standard.org/standard/core/SPACES
 531 \ SPACES   n --            output n spaces
 532     [UNDEFINED] SPACES
 533     [IF]
 534     : SPACES
 535     BEGIN
 536         ?DUP
 537     WHILE
 538         'SP' EMIT
 539         1-
 540     REPEAT
 541     ;
 542     [THEN]
 543
 544     [UNDEFINED] U.R
 545     [IF]
 546     : U.R                       \ u n --           display u unsigned in n width (n >= 2)
 547     >R  <# 0 # #S #>
 548     R> OVER - 0 MAX SPACES TYPE
 549     ;
 550     [THEN]
 551
 552     CODE TIME?
 553     BEGIN
 554         BIT.B #RTCRDY,&RTCCTL1
 555     0<> UNTIL                   \ wait until RTCRDY high
 556     COLON
 557     RTCHOUR C@ 2 U.R ':' EMIT
 558     RTCMIN C@  2 U.R ':' EMIT
 559     RTCSEC C@  2 U.R
 560     ;
 561
 562     : TIME!
 563     2 DEPTH
 564     U< IF                   \ if 3 numbers on stack
 565         RTCSEC C!
 566         RTCMIN C!
 567         RTCHOUR C!
 568     THEN
 569     ." it is " TIME?
 570     ;
 571
 572     CODE DATE?                  \ display date
 573     BEGIN
 574         BIT.B #RTCRDY,&RTCCTL1
 575     0<> UNTIL                   \ wait until windows time RTC_ReaDY is high
 576     COLON
 577
 578 \     [THEN]
 579
 580 \ ==============================================================================
 581 \ end of RTC software|harware calendar
 582 \ ==============================================================================
 583 \ resume with common part of DATE? definition:
 584
 585     RTCDOW C@                   \ -- weekday    {0=Sat...6=Fri}
 586     CASE
 587     0 OF ." Sat"    ENDOF
 588     1 OF ." Sun"    ENDOF
 589     2 OF ." Mon"    ENDOF
 590     3 OF ." Tue"    ENDOF
 591     4 OF ." Wed"    ENDOF
 592     5 OF ." Thu"    ENDOF
 593     6 OF ." Fri"    ENDOF
 594     ENDCASE
 595     RTCYEAR @
 596     RTCMON C@
 597     RTCDAY C@                   \ -- year mon day
 598     $20 EMIT
 599     2 U.R '/' EMIT              \ -- year mon
 600     2 U.R '/' EMIT              \ -- year
 601     .                           \ --
 602     ;
 603
 604     : DATE!                         \ year mon day --
 605     2 DEPTH
 606     U< IF                   \ if 3 numbers on stack
 607         RTCYEAR !
 608         RTCMON C!
 609         RTCDAY C!
 610     THEN
 611     RTCDAY C@
 612     RTCMON C@
 613     RTCYEAR @               \ -- day mon year
 614 \ ------------------------------------------
 615 \ Zeller's congruence for gregorian calendar
 616 \ see https://www.rosettacode.org/wiki/Day_of_the_week#Forth
 617 \ : ZELLER \ day mon year -- weekday          {0=Sat, ..., 6=Fri}
 618 \ OVER 3 <                \
 619 \ IF 1- SWAP 12 + SWAP
 620 \ THEN                    \ -- d m' y'  with m' {3=March, ..., 14=february}
 621 \ 100 /MOD                \ -- d m' K J   with K = y' in century, J = century
 622 \ DUP 4 / SWAP 2* -       \ -- d m' K (J/4 - 2J)
 623 \ SWAP DUP 4 / + +        \ -- d m' ((J/4 - 2J) + (K + K/4))
 624 \ SWAP 1+  13 5 */ + +    \ -- (d + (((J/4 - 2J) + (K + K/4)) + (m+1)*13/5))
 625 \ 7 MOD                   \ -- weekday        = {0=Sat, ..., 6=Fri}
 626 \ ------------------------------------------
 627     OVER 3 U<               \
 628     IF 1 - SWAP 12 + SWAP
 629     THEN                    \ -- d m' y'  with m' {3=March, ..., 14=february}
 630     100 U/MOD               \ -- d m' K J   with K = y' in century, J = century
 631     DUP 4 U/ SWAP 2* -      \ -- d m' K (J/4 - 2J)
 632     SWAP DUP 4 U/ + +       \ -- d m' ((J/4 - 2J) + (K + K/4))
 633     SWAP 1+  13 5 U*/ + +   \ -- (d + (((J/4 - 2J) + (K + K/4)) + (m+1)*13/5))
 634     7 UMOD                  \ -- weekday        = {0=Sat, ..., 6=Fri}
 635 \ ------------------------------------------
 636     RTCDOW C!               \ --
 637     ." we are on " DATE?
 638     ;
 639
 640     RST_SET
 641
 642     [UNDEFINED] S_
 643     [IF]
 644     CODE S_             \           Squote alias with blank instead quote separator
 645     MOV #0,&CAPS        \           turn CAPS OFF
 646     COLON
 647     XSQUOTE ,           \           compile run-time code
 648     $20 WORD            \ -- c-addr (= HERE)
 649     HI2LO
 650     MOV.B @TOS,TOS      \ -- len    compile string
 651     ADD #1,TOS          \ -- len+1
 652     BIT #1,TOS          \           C = ~Z
 653     ADDC TOS,&DP        \           store aligned DP
 654     MOV @PSP+,TOS       \ --
 655     MOV @RSP+,IP        \           pop paired with push COLON
 656     MOV #$20,&CAPS      \           turn CAPS ON (default state)
 657     MOV @IP+,PC         \ NEXT
 658     ENDCODE IMMEDIATE
 659     [THEN]
 660
 661     [UNDEFINED] ESC
 662     [IF]
 663     CODE ESC
 664     CMP #0,&STATEADR
 665     0= IF MOV @IP+,PC   \ interpret time usage disallowed
 666     THEN
 667     COLON
 668     $1B                 \ -- char escape
 669     POSTPONE LITERAL    \ compile-time code : lit $1B
 670     POSTPONE EMIT       \ compile-time code : EMIT
 671     POSTPONE S_         \ compile-time code : S_ <escape_sequence>
 672     POSTPONE TYPE       \ compile-time code : TYPE
 673     ; IMMEDIATE
 674     [THEN]
 675
 676 \ https://forth-standard.org/standard/core/toBODY
 677 \ >BODY     -- addr      leave BODY of a CREATEd word\ also leave default ACTION-OF primary DEFERred word
 678     [UNDEFINED] >BODY
 679     [IF]
 680     CODE >BODY
 681     ADD #4,TOS
 682     MOV @IP+,PC
 683     ENDCODE
 684     [THEN]
 685
 686 \ https://forth-standard.org/standard/core/EXECUTE
 687 \ EXECUTE   i*x xt -- j*x   execute Forth word at 'xt'
 688     [UNDEFINED] EXECUTE
 689     [IF] \ "
 690     CODE EXECUTE
 691     PUSH TOS                \ 3 push xt
 692     MOV @PSP+,TOS           \ 2
 693     MOV @RSP+,PC            \ 4 xt --> PC
 694     ENDCODE
 695     [THEN]
 696
 697 \ https://forth-standard.org/standard/core/EVALUATE
 698 \ EVALUATE          \ i*x c-addr u -- j*x  interpret string
 699     [UNDEFINED] EVALUATE
 700     [IF]
 701     CODE EVALUATE
 702     MOV #SOURCE_LEN,X       \ 2
 703     MOV @X+,S               \ 2 S = SOURCE_LEN
 704     MOV @X+,T               \ 2 T = SOURCE_ORG
 705     MOV @X+,W               \ 2 W = TOIN
 706     PUSHM #4,IP             \ 6 PUSHM IP,S,T,W
 707     LO2HI
 708     [ ' \ 8 + , ]           \ compile INTERPRET = BACKSLASH + 8
 709     HI2LO
 710     MOV @RSP+,&TOIN         \ 4
 711     MOV @RSP+,&SOURCE_ORG   \ 4
 712     MOV @RSP+,&SOURCE_LEN   \ 4
 713     MOV @RSP+,IP
 714     MOV @IP+,PC
 715     ENDCODE
 716     [THEN]
 717
 718 \ https://forth-standard.org/standard/core/CR
 719 \ CR      --               send CR+LF to the output device
 720     [UNDEFINED] CR
 721     [IF]
 722
 723 \    DEFER CR       \ DEFERed definition, by default executes that of :NONAME
 724     CODE CR         \ create a DEFER definition of CR
 725     MOV #NEXT_ADR,PC
 726     ENDCODE
 727
 728     :NONAME     \ starts at BODY address of DEFERed CR
 729     'CR' EMIT 'LF' EMIT
 730     ; IS CR     \ CR executes :NONAME by default
 731     [THEN]
 732
 733     : SET_TIME
 734     ESC [8;40;80t       \ set terminal display 42L * 80C
 735     39 0 DO CR LOOP     \ to avoid erasing any line of source, create 42 empty lines
 736     ESC [H              \ then set cursor home
 737     CR ." DATE (DMY): "
 738     PAD_ORG DUP PAD_LEN
 739     ['] ACCEPT >BODY    \ find default part of deferred ACCEPT (terminal input)
 740     EXECUTE             \ wait human input for D M Y
 741     EVALUATE            \ interpret this input
 742     CR DATE!            \ set date
 743     CR ." TIME (HMS): "
 744     PAD_ORG DUP PAD_LEN
 745     ['] ACCEPT >BODY    \ find default part of deferred ACCEPT (terminal input)
 746     EXECUTE             \ wait human input for H M S
 747     EVALUATE            \ interpret this input
 748     CR TIME!            \ set time
 749     RST_RET             \ remove code beyond RST_HERE
 750     ;
 751
 752 ECHO
 753 SET_TIME