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