ADDON/UTILITY.asm

   1 ; -*- coding: utf-8 -*-
   2
   3             FORTHWORD "{UTILITY}"
   4             MOV @IP+,PC
   5
   6     .IFNDEF TOR
   7 ; https://forth-standard.org/standard/core/toR
   8 ; >R    x --   R: -- x   push to return stack
   9             FORTHWORD ">R"
  10 TOR         PUSH TOS
  11             MOV @PSP+,TOS
  12             MOV @IP+,PC
  13     .ENDIF
  14
  15         .IFNDEF ANDD
  16 ;https://forth-standard.org/standard/core/AND
  17 ;C AND    x1 x2 -- x3           logical AND
  18             FORTHWORD "AND"
  19 ANDD        AND     @PSP+,TOS
  20             MOV @IP+,PC
  21         .ENDIF
  22
  23         .IFNDEF CFETCH
  24 ;https://forth-standard.org/standard/core/CFetch
  25 ;C C@     c-addr -- char   fetch char from memory
  26             FORTHWORD "C@"
  27 CFETCH      MOV.B @TOS,TOS      ;2
  28             MOV @IP+,PC         ;4
  29         .ENDIF
  30
  31         .IFNDEF ULESS
  32 ; https://forth-standard.org/standard/core/Uless
  33 ; U<    u1 u2 -- flag       test u1<u2, unsigned
  34             FORTHWORD "U<"
  35 ULESS       SUB @PSP+,TOS   ; 2 u2-u1
  36             JNC UTOSFALSE
  37             JZ  ULESSEND
  38 UTOSTRUE    MOV #-1,TOS     ;1 flag Z = 0
  39 ULESSEND    MOV @IP+,PC     ;4
  40
  41 ; https://forth-standard.org/standard/core/Umore
  42 ; U>     n1 n2 -- flag
  43             FORTHWORD "U>"
  44             SUB @PSP+,TOS   ; 2
  45             JNC UTOSTRUE    ; 2 flag = true, Z = 0
  46 UTOSFALSE   AND #0,TOS      ;1 flag Z = 1
  47             MOV @IP+,PC     ;4
  48         .ENDIF
  49
  50         .IFNDEF SPACE
  51 ;https://forth-standard.org/standard/core/SPACE
  52 ;C SPACE   --               output a space
  53             FORTHWORD "SPACE"
  54 SPACE       SUB #2,PSP              ;1
  55             MOV TOS,0(PSP)          ;3
  56             MOV #20h,TOS            ;2
  57             MOV #EMIT,PC            ;17~  23~
  58
  59 ;https://forth-standard.org/standard/core/SPACES
  60 ;C SPACES   n --            output n spaces
  61             FORTHWORD "SPACES"
  62 SPACES      CMP #0,TOS
  63             JZ SPACESNEXT2
  64             PUSH IP
  65             MOV #SPACESNEXT,IP
  66             JMP SPACE               ;25~
  67 SPACESNEXT  .word   $+2
  68             SUB #2,IP               ;1
  69             SUB #1,TOS              ;1
  70             JNZ SPACE               ;25~ ==> 27~ by space ==> 2.963 MBds @ 8 MHz
  71             MOV @RSP+,IP            ;
  72 SPACESNEXT2 MOV @PSP+,TOS           ; --         drop n
  73             MOV @IP+,PC                   ;
  74
  75         .ENDIF
  76
  77     .IFNDEF TWODUP
  78 ; https://forth-standard.org/standard/core/TwoDUP
  79 ; 2DUP   x1 x2 -- x1 x2 x1 x2   dup top 2 cells
  80             FORTHWORD "2DUP"
  81 TWODUP      MOV TOS,-2(PSP)     ; 3
  82             MOV @PSP,-4(PSP)    ; 4
  83             SUB #4,PSP          ; 1
  84             MOV @IP+,PC         ; 4
  85     .ENDIF
  86
  87     .IFNDEF XDO
  88 ; Primitive XDO; compiled by DO
  89 ;Z (do)    n1|u1 n2|u2 --  R: -- sys1 sys2      run-time code for DO
  90 ;                                               n1|u1=limit, n2|u2=index
  91 XDO         MOV #8000h,X    ;2 compute 8000h-limit = "fudge factor"
  92             SUB @PSP+,X     ;2
  93             MOV TOS,Y       ;1 loop ctr = index+fudge
  94             ADD X,Y         ;1 Y = INDEX
  95             PUSHM #2,X      ;4 PUSHM X,Y, i.e. PUSHM LIMIT, INDEX
  96             MOV @PSP+,TOS   ;2
  97             MOV @IP+,PC     ;4
  98
  99             FORTHWORDIMM "DO"       ; immediate
 100 ; https://forth-standard.org/standard/core/DO
 101 ; DO       -- DOadr   L: -- 0
 102 DO          SUB #2,PSP              ;
 103             MOV TOS,0(PSP)          ;
 104             ADD #2,&DP             ;   make room to compile xdo
 105             MOV &DP,TOS            ; -- HERE+2
 106             MOV #XDO,-2(TOS)        ;   compile xdo
 107             ADD #2,&LEAVEPTR        ; -- HERE+2     LEAVEPTR+2
 108             MOV &LEAVEPTR,W         ;
 109             MOV #0,0(W)             ; -- HERE+2     L-- 0
 110             MOV @IP+,PC
 111
 112 ; Primitive XLOOP; compiled by LOOP
 113 ;Z (loop)   R: sys1 sys2 --  | sys1 sys2
 114 ;                        run-time code for LOOP
 115 ; Add 1 to the loop index.  If loop terminates, clean up the
 116 ; return stack and skip the branch.  Else take the inline branch.
 117 ; Note that LOOP terminates when index=8000h.
 118 XLOOP       ADD #1,0(RSP)   ;4 increment INDEX
 119 XLOOPNEXT   BIT #100h,SR    ;2 is overflow bit set?
 120             JZ XLOOPDO      ;2 no overflow = loop
 121             ADD #4,RSP      ;1 empties RSP
 122             ADD #2,IP       ;1 overflow = loop done, skip branch ofs
 123             MOV @IP+,PC     ;4 14~ taken or not taken xloop/loop
 124 XLOOPDO     MOV @IP,IP
 125             MOV @IP+,PC     ;4 14~ taken or not taken xloop/loop
 126
 127             FORTHWORDIMM "LOOP"     ; immediate
 128 ; https://forth-standard.org/standard/core/LOOP
 129 ; LOOP    DOadr --         L-- an an-1 .. a1 0
 130 LOO         MOV #XLOOP,X
 131 LOOPNEXT    ADD #4,&DP             ; make room to compile two words
 132             MOV &DP,W
 133             MOV X,-4(W)             ; xloop --> HERE
 134             MOV TOS,-2(W)           ; DOadr --> HERE+2
 135 ; resolve all "leave" adr
 136 LEAVELOOP   MOV &LEAVEPTR,TOS       ; -- Adr of top LeaveStack cell
 137             SUB #2,&LEAVEPTR        ; --
 138             MOV @TOS,TOS            ; -- first LeaveStack value
 139             CMP #0,TOS              ; -- = value left by DO ?
 140             JZ LOOPEND
 141             MOV W,0(TOS)            ; move adr after loop as UNLOOP adr
 142             JMP LEAVELOOP
 143 LOOPEND     MOV @PSP+,TOS
 144             MOV @IP+,PC
 145
 146 ; Primitive XPLOOP; compiled by +LOOP
 147 ;Z (+loop)   n --   R: sys1 sys2 --  | sys1 sys2
 148 ;                        run-time code for +LOOP
 149 ; Add n to the loop index.  If loop terminates, clean up the
 150 ; return stack and skip the branch. Else take the inline branch.
 151 XPLOO       ADD TOS,0(RSP)  ;4 increment INDEX by TOS value
 152             MOV @PSP+,TOS   ;2 get new TOS, doesn't change flags
 153             JMP XLOOPNEXT   ;2
 154
 155             FORTHWORDIMM "+LOOP"    ; immediate
 156 ; https://forth-standard.org/standard/core/PlusLOOP
 157 ; +LOOP   adrs --   L-- an an-1 .. a1 0
 158 PLUSLOOP    MOV #XPLOO,X
 159             JMP LOOPNEXT
 160     .ENDIF
 161
 162     .IFNDEF II
 163 ; https://forth-standard.org/standard/core/I
 164 ; I        -- n   R: sys1 sys2 -- sys1 sys2
 165 ;                  get the innermost loop index
 166             FORTHWORD "I"
 167 II          SUB #2,PSP              ;1 make room in TOS
 168             MOV TOS,0(PSP)          ;3
 169             MOV @RSP,TOS            ;2 index = loopctr - fudge
 170             SUB 2(RSP),TOS          ;3
 171             MOV @IP+,PC             ;4 13~
 172     .ENDIF
 173
 174 ;https://forth-standard.org/standard/tools/DotS
 175             FORTHWORD ".S"      ; --            print <depth> of Param Stack and stack contents if not empty
 176 DOTS        MOV TOS,-2(PSP)     ; -- TOS ( tos x x )
 177             MOV PSP,TOS
 178             SUB #2,TOS          ; to take count that TOS is first cell
 179             MOV TOS,-6(PSP)     ; -- TOS ( tos x  PSP )
 180             MOV #PSTACK,TOS     ; -- P0  ( tos x  PSP )
 181             SUB #2,TOS          ; to take count that TOS is first cell
 182 DOTS1       MOV TOS,-4(PSP)     ; -- S0  ( tos S0 SP )
 183             SUB #6,PSP          ; -- S0 SP S0
 184             SUB @PSP,TOS        ; -- S0 SP S0-SP
 185             RRA TOS             ; -- S0 SP #cells
 186             mDOCOL
 187             .word   lit,'<',EMIT
 188             .word   DOT                 ; display #cells
 189             .word   lit,08h,EMIT        ; backspace
 190             .word   lit,'>',EMIT,SPACE
 191             .word   TWODUP,ONEPLUS,ULESS
 192             .word   QFBRAN,STKDISPL1
 193             .word   DROP,DROP,EXIT
 194 STKDISPL1   .word   xdo
 195 STKDISPL2   .word   II,FETCH,UDOT
 196             .word   lit,2,xploo,STKDISPL2
 197             .word   EXIT
 198
 199
 200             FORTHWORD ".RS"     ; --           print <depth> of Return Stack and stack contents if not empty
 201 DOTRS       MOV TOS,-2(PSP)     ; -- TOS ( tos x x )
 202             MOV RSP,-6(PSP)     ; -- TOS ( tos x  RSP )
 203             MOV #RSTACK,TOS     ; -- R0  ( tos x  RSP )
 204             JMP DOTS1
 205
 206 ;https://forth-standard.org/standard/tools/q
 207 ;Z  ?       adr --             display the content of adr
 208             FORTHWORD "?"
 209 QUESTION    MOV @TOS,TOS
 210             MOV #UDOT,PC
 211
 212         .IFNDEF QDUP
 213 ; https://forth-standard.org/standard/core/DUP
 214 ; DUP      x -- x x      duplicate top of stack
 215             FORTHWORD "DUP"
 216 QDUPNEXT    SUB #2,PSP      ; 2  push old TOS..
 217             MOV TOS,0(PSP)  ; 3  ..onto stack
 218 QDUPEND     MOV @IP+,PC     ; 4
 219
 220 ; https://forth-standard.org/standard/core/qDUP
 221 ; ?DUP     x -- 0 | x x    DUP if nonzero
 222             FORTHWORD "?DUP"
 223 QDUP        CMP #0,TOS
 224             JZ QDUPEND
 225             JNZ QDUPNEXT
 226         .ENDIF
 227
 228         .IFNDEF CR
 229             FORTHWORD "CR"
 230 ; https://forth-standard.org/standard/core/CR
 231 ; CR      --               send CR to the output device
 232 CR          MOV @PC+,PC
 233             .word BODYCR
 234 BODYCR      mDOCOL                  ;  send CR+LF to the default output device
 235             .word   XSQUOTE
 236             .byte   2,0Dh,0Ah
 237             .word   TYPE,EXIT
 238         .ENDIF
 239
 240     .IFNDEF TWODIV
 241 ;https://forth-standard.org/standard/core/TwoDiv
 242 ;C 2/      x1 -- x2        arithmetic right shift
 243             FORTHWORD "2/"
 244 TWODIV      RRA TOS
 245             MOV @IP+,PC
 246     .ENDIF
 247
 248     .SWITCH THREADS
 249     .CASE   1
 250
 251 ;https://forth-standard.org/standard/tools/WORDS
 252 ;X WORDS        --      list all words in first vocabulary in CONTEXT. 38 words
 253             FORTHWORD "WORDS"
 254 WORDS       mDOCOL
 255             .word   CR
 256             .word   LIT,CONTEXT,FETCH   ; -- VOC_BODY
 257 WORDS1      .word   FETCH               ; -- NFA
 258             .word   QDUP                ; -- 0 | -- NFA NFA
 259             .word   QFBRAN,WORDS2        ; -- NFA
 260             .word   DUP,DUP,COUNT       ; -- NFA NFA addr count
 261             .word   TWODIV,ANDD,TYPE    ; -- NFA NFA
 262             .word   CFETCH,TWODIV
 263             .word   lit,0Fh,ANDD
 264             .word   lit,10h,SWAP,MINUS
 265             .word   SPACES
 266             .word   lit,2,MINUS         ; NFA -- LFA
 267             .word   BRAN,WORDS1
 268 WORDS2      .word   EXIT                ; --
 269
 270     .ELSECASE
 271
 272         .IFNDEF PAD
 273 ;https://forth-standard.org/standard/core/PAD
 274 ; PAD           --  pad address
 275             FORTHWORD "PAD"
 276 PAD         CALL rDOCON
 277             .WORD PAD_ORG
 278         .ENDIF
 279
 280         .IFNDEF ROT
 281 ;https://forth-standard.org/standard/core/ROT
 282 ;C ROT    x1 x2 x3 -- x2 x3 x1
 283             FORTHWORD "ROT"
 284 ROT         MOV @PSP,W          ; 2 fetch x2
 285             MOV TOS,0(PSP)      ; 3 store x3
 286             MOV 2(PSP),TOS      ; 3 fetch x1
 287             MOV W,2(PSP)        ; 3 store x2
 288             MOV @IP+,PC               ; 4
 289         .ENDIF
 290
 291             .IFNDEF MOVE
 292 ; https://forth-standard.org/standard/core/MOVE
 293 ; MOVE    addr1 addr2 u --     smart move
 294 ;             VERSION FOR 1 ADDRESS UNIT = 1 CHAR
 295             FORTHWORD "MOVE"
 296 MOVE        MOV TOS,W           ; W = cnt
 297             MOV @PSP+,Y         ; Y = addr2 = dst
 298             MOV @PSP+,X         ; X = addr1 = src
 299             MOV @PSP+,TOS       ; pop new TOS
 300             CMP #0,W            ; count = 0 ?
 301             JZ MOVEND           ; if 0, already done !
 302             CMP X,Y             ; dst = src ?
 303             JZ MOVEND           ; already done !
 304             JC MOVEDOWN         ; U< if src > dst
 305 MOVEUPLOOP  MOV.B @X+,0(Y)      ; copy W bytes
 306             ADD #1,Y
 307             SUB #1,W
 308             JNZ MOVEUPLOOP
 309             MOV @IP+,PC         ; out 1 of MOVE ====>
 310 MOVEDOWN    ADD W,Y             ; copy W bytes beginning with the end
 311             ADD W,X
 312 MOVEDOWNLOO SUB #1,X
 313             SUB #1,Y
 314             MOV.B @X,0(Y)
 315             SUB #1,W
 316             JNZ MOVEDOWNLOO
 317 MOVEND      MOV @IP+,PC ; out 2 of MOVE ====>
 318             .ENDIF
 319
 320 ;https://forth-standard.org/standard/tools/WORDS
 321 ;X WORDS        --      list all words in first vocabulary in CONTEXT. 38 words
 322             FORTHWORD "WORDS"
 323 WORDS       mDOCOL
 324             .word   CR
 325             .word   LIT,CONTEXT,FETCH
 326             .word   PAD,LIT,THREADS,DUP,PLUS
 327             .word   MOVE
 328                                             ; BEGIN
 329 WORDS2      .word   LIT,0,DUP
 330             .word   LIT,THREADS,DUP,PLUS    ;   I = ptr = thread*2
 331             .word   LIT,0
 332             .word   xdo                     ;   DO
 333 WORDS3      .word   DUP,II,PAD,PLUS,FETCH   ;   old MAX NFA U< NFA ?
 334             .word   ULESS,QFBRAN,WORDS4      ;   no
 335             .word   TWODROP,II              ;   yes, replace old MAX of NFA by new MAX of NFA
 336             .word   DUP,PAD,PLUS,FETCH      ;
 337 WORDS4      .word   LIT,2,xploo,WORDS3      ;   2 +LOOP
 338             .word   QDUP                    ;   MAX of NFA = 0 ?
 339             .word   QFBRAN,WORDS5            ; WHILE
 340             .word   DUP,LIT,2,MINUS,FETCH   ;   replace NFA MAX by its [LFA]
 341             .word   ROT,PAD,PLUS,STORE
 342             .word   DUP,COUNT,TWODIV,TYPE   ;   display NFA MAX in 10 chars format
 343             .word   CFETCH,TWODIV
 344             .word   lit,0Fh,ANDD
 345             .word   lit,10h,SWAP,MINUS
 346             .word   SPACES
 347             .word   BRAN,WORDS2             ; REPEAT
 348 WORDS5      .word   DROP
 349             .word   EXIT
 350
 351     .ENDCASE
 352
 353
 354     .IFNDEF MAX
 355
 356 ;https://forth-standard.org/standard/core/MAX
 357 ;C MAX    n1 n2 -- n3       signed maximum
 358             FORTHWORD "MAX"
 359 MAX         CMP @PSP,TOS        ; n2-n1
 360             JL SELn1            ; n2<n1
 361 SELn2       ADD #2,PSP
 362             MOV @IP+,PC
 363
 364 ;https://forth-standard.org/standard/core/MIN
 365 ;C MIN    n1 n2 -- n3       signed minimum
 366             FORTHWORD "MIN"
 367 MIN         CMP @PSP,TOS        ; n2-n1
 368             JL SELn2            ; n2<n1
 369 SELn1       MOV @PSP+,TOS
 370             MOV @IP+,PC
 371
 372     .ENDIF
 373
 374     .IFNDEF PLUS
 375 ;https://forth-standard.org/standard/core/Plus
 376 ;C +       n1/u1 n2/u2 -- n3/u3     add n1+n2
 377             FORTHWORD "+"
 378 PLUS        ADD @PSP+,TOS
 379             MOV @IP+,PC
 380     .ENDIF
 381
 382         .IFNDEF OVER
 383 ;https://forth-standard.org/standard/core/OVER
 384 ;C OVER    x1 x2 -- x1 x2 x1
 385             FORTHWORD "OVER"
 386 OVER        MOV TOS,-2(PSP)     ; 3 -- x1 (x2) x2
 387             MOV @PSP,TOS        ; 2 -- x1 (x2) x1
 388             SUB #2,PSP          ; 1 -- x1 x2 x1
 389             MOV @IP+,PC               ; 4
 390         .ENDIF
 391
 392     .IFNDEF UDOTR
 393 ;https://forth-standard.org/standard/core/UDotR
 394 ;X U.R      u n --      display u unsigned in n width
 395             FORTHWORD "U.R"
 396 UDOTR       mDOCOL
 397             .word   TOR,LESSNUM,lit,0,NUM,NUMS,NUMGREATER
 398             .word   RFROM,OVER,MINUS,lit,0,MAX,SPACES,TYPE
 399             .word   EXIT
 400     .ENDIF
 401
 402     .IFNDEF HERE
 403 ; https://forth-standard.org/standard/core/HERE
 404 ; HERE    -- addr      returns memory ptr
 405 HERE       FORTHWORD "HERE"
 406             MOV #HEREXEC,PC
 407     .ENDIF
 408
 409 ;https://forth-standard.org/standard/tools/DUMP
 410             FORTHWORD "DUMP"
 411 DUMP        PUSH IP
 412             PUSH &BASEADR                   ; save current base
 413             MOV #10h,&BASEADR               ; HEX base
 414             ADD @PSP,TOS                    ; -- ORG END
 415             mASM2FORTH
 416             .word   SWAP                    ; -- END ORG
 417             .word   xdo                     ; --
 418 DUMP1       .word   CR
 419             .word   II,lit,4,UDOTR,SPACE    ; generate address
 420
 421             .word   II,lit,8,PLUS,II,xdo    ; display first 8 bytes
 422 DUMP2       .word   II,CFETCH,lit,3,UDOTR
 423             .word   xloop,DUMP2             ; bytes display loop
 424             .word   SPACE
 425             .word   II,lit,10h,PLUS,II,lit,8,PLUS,xdo    ; display last 8 bytes
 426 DUMP3       .word   II,CFETCH,lit,3,UDOTR
 427             .word   xloop,DUMP3             ; bytes display loop
 428             .word   SPACE,SPACE
 429             .word   II,lit,10h,PLUS,II,xdo  ; display 16 chars
 430 DUMP4       .word   II,CFETCH
 431             .word   lit,7Eh,MIN,BL,MAX,EMIT
 432             .word   xloop,DUMP4             ; chars display loop
 433             .word   lit,10h,xploo,DUMP1     ; line loop
 434             .word   RFROM,lit,BASEADR,STORE ; restore current base
 435             .word   EXIT
 436