coreext.f

   1 \\r
   2 \ COREEXT.F\r
   3 \ More Core Extention wordset words for hForth - code definitions\r
   4 \\r
   5 \ COREEXT.F can be loaded as following order:\r
   6 \\r
   7 \       << OPTIONAL.F\r
   8 \       << ASM8086.F\r
   9 \       << COREEXT.F\r
  10 \\r
  11 \ 1996. 2. 9.\r
  12 \ Wonyong Koh\r
  13 \\r
  14 \ 1997. 6. 5.\r
  15 \       Fix colon definition of do?DO.\r
  16 \ 1997. 2. 28.\r
  17 \       Facelift to be used with other CPUs.\r
  18 \ 1996. 11. 29.\r
  19 \       Provide CODE definition of ROLL.\r
  20 \       Revise '?DO' for control-flow stack.\r
  21 \       Revise 'C"' to catch exception -24 'parsed string overflow'.\r
  22 \r
  23 BASE @\r
  24 CHAR " PARSE model" ENVIRONMENT? DROP\r
  25 CHAR " PARSE ROM Model" COMPARE 0=\r
  26 [IF] RAM/ROM@ [THEN]\r
  27 GET-ORDER  GET-CURRENT\r
  28 \r
  29 FORTH-WORDLIST SET-CURRENT\r
  30 \r
  31 \   <>          ( x1 x2 -- flag )               \ CORE EXT\r
  32 \               Return false if x1 is the same as x2.\r
  33 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
  34 [IF]\r
  35   : <>   = 0= ;\r
  36 [ELSE] DROP\r
  37   CODE <>\r
  38       AX POP,\r
  39       AX BX CMP,\r
  40       -1 # BX MOV,\r
  41       1 L# JNE,\r
  42       BX INC,\r
  43   1 L:\r
  44       NEXT,\r
  45   END-CODE\r
  46 [THEN]\r
  47 \r
  48 \   0<>         ( x -- flag )                   \ CORE EXT\r
  49 \               flag is true if and only if x is not equal to zero.\r
  50 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
  51 [IF]\r
  52   : 0<>   0 <> ;\r
  53 [ELSE] DROP\r
  54   CODE 0<>\r
  55       BX BX OR,\r
  56       -1 # BX MOV,\r
  57       1 L# JNZ,\r
  58       BX INC,\r
  59   1 L:\r
  60       NEXT,\r
  61   END-CODE\r
  62 [THEN]\r
  63 \r
  64 \   0>          ( n -- flag )                   \ CORE EXT\r
  65 \               flag is true if and only if n is greater than zero.\r
  66 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
  67 [IF]\r
  68   : 0>   0 > ;\r
  69 [ELSE] DROP\r
  70   CODE 0>\r
  71       BX AX MOV,\r
  72       AX DEC,\r
  73       CWD,\r
  74       DX NOT,\r
  75       DX BX MOV,\r
  76       NEXT,\r
  77   END-CODE\r
  78 [THEN]\r
  79 \r
  80 \   2>R         ( x1 x2 -- ) ( R: -- x1 x2 )    \ CORE EXT\r
  81 \               Transfer cell pair to the return stack.\r
  82 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
  83 [IF]\r
  84   : 2>R   SWAP R> SWAP >R SWAP >R >R ;\r
  85 [ELSE] DROP\r
  86   CODE 2>R\r
  87       AX POP,\r
  88       2 CELLS # BP SUB,\r
  89       AX 1 CELLS [BP] MOV,\r
  90       BX 0 [BP] MOV,\r
  91       BX POP,\r
  92       NEXT,\r
  93   END-CODE COMPILE-ONLY\r
  94 [THEN]\r
  95 \r
  96 \   2R>         ( -- x1 x2 ) ( R: x1 x2 -- )    \ CORE EXT\r
  97 \               Transfer cell pair from the return stack.\r
  98 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
  99 [IF]\r
 100   : 2R>   R> R> SWAP R> SWAP >R SWAP ;\r
 101 [ELSE] DROP\r
 102   CODE 2R>\r
 103       BX PUSH,\r
 104       1 CELLS [BP] AX MOV,\r
 105       0 [BP] BX MOV,\r
 106       AX PUSH,\r
 107       2 CELLS # BP ADD,\r
 108       NEXT,\r
 109   END-CODE COMPILE-ONLY\r
 110 [THEN]\r
 111 \r
 112 \   2R@         ( -- x1 x2 ) ( R: x1 x2 -- x1 x2 )      \ CORE EXT\r
 113 \               Copy cell pair from the return stack.\r
 114 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 115 [IF]\r
 116   : 2R@   R> R> R> 2DUP >R >R SWAP ROT >R ;\r
 117 [ELSE] DROP\r
 118   CODE 2R@\r
 119       BX PUSH,\r
 120       1 CELLS [BP] AX MOV,\r
 121       0 [BP] BX MOV,\r
 122       AX PUSH,\r
 123       NEXT,\r
 124   END-CODE COMPILE-ONLY\r
 125 [THEN]\r
 126 \r
 127 HEX\r
 128 NONSTANDARD-WORDLIST SET-CURRENT\r
 129 \r
 130 \   do?DO       ( n1|u1 n2|u2 -- ) ( R: -- n1 n2-n1-max_negative )\r
 131 \               Run-time funtion of ?DO.\r
 132 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 133 [IF]\r
 134   CHAR " PARSE model" ENVIRONMENT? DROP\r
 135   CHAR " PARSE ROM Model" COMPARE 0=\r
 136   CHAR " PARSE model" ENVIRONMENT? DROP\r
 137   CHAR " PARSE RAM Model" COMPARE 0= OR\r
 138   [IF]\r
 139     : do?DO\r
 140         2DUP = IF 2DROP R> @ >R EXIT THEN\r
 141         >R\r
 142         \ get max-negative\r
 143         [ -1 BL PARSE MAX-N ENVIRONMENT? DROP - ] LITERAL\r
 144         + R> OVER - SWAP R> SWAP >R SWAP >R CELL+ >R ; COMPILE-ONLY\r
 145   [THEN]\r
 146   CHAR " PARSE model" ENVIRONMENT? DROP\r
 147   CHAR " PARSE EXE Model" COMPARE 0=\r
 148   [IF]\r
 149     : do?DO\r
 150         2DUP = IF 2DROP R> code@ >R EXIT THEN\r
 151         >R\r
 152         \ get max-negative\r
 153         [ -1 BL PARSE MAX-N ENVIRONMENT? DROP - ] LITERAL\r
 154         + R> OVER - SWAP R> SWAP >R SWAP >R CELL+ >R ; COMPILE-ONLY\r
 155   [THEN]\r
 156 [ELSE] DROP\r
 157   CODE do?DO\r
 158       AX POP,\r
 159       AX BX CMP,\r
 160       1 L# JE,\r
 161       1 CELLS # SI ADD,\r
 162       2 CELLS # BP SUB,\r
 163       8000 # AX ADD,\r
 164       AX 1 CELLS [BP] MOV,\r
 165       AX BX SUB,\r
 166       BX 0 [BP] MOV,\r
 167       BX POP,\r
 168       NEXT,\r
 169   1 L:\r
 170       BX POP,\r
 171       CS:\r
 172       0 [SI] SI MOV,\r
 173       NEXT,\r
 174   END-CODE COMPILE-ONLY\r
 175 [THEN]\r
 176 \r
 177 FORTH-WORDLIST SET-CURRENT\r
 178 \r
 179 \   ?DO         ( C: -- do-sys )                \ CORE EXT\r
 180 \               Run-time: ( n1|u1 n2|u2 -- ) ( R: -- | loop-sys )\r
 181 \               Start a ?DO ... LOOP structure in a colon definition.\r
 182 \               On execution do as DO only if n1|u1 is not equal to n2|u2.\r
 183 : ?DO\r
 184     0 rakeVar !\r
 185     POSTPONE do?DO xhere 0 code,        \ leave ?DO-orig\r
 186     xhere  bal+                         \ leave DO-dest\r
 187     ; COMPILE-ONLY IMMEDIATE\r
 188 \r
 189 CHAR " PARSE model" ENVIRONMENT? DROP\r
 190 CHAR " PARSE ROM Model" COMPARE 0=\r
 191 CHAR " PARSE model" ENVIRONMENT? DROP\r
 192 CHAR " PARSE RAM Model" COMPARE 0= OR\r
 193 [IF]\r
 194   NONSTANDARD-WORDLIST SET-CURRENT\r
 195   : doC" ( -- c-addr )   R> DUP COUNT + ALIGNED >R ; COMPILE-ONLY\r
 196   FORTH-WORDLIST SET-CURRENT\r
 197 [THEN]\r
 198 \r
 199 \   C"          ( "ccc<">" -- )\r
 200 \               Run-time: ( -- c-addr )\r
 201 \               Parse ccc delimetered by " . Return the counted string, c-addr.\r
 202 CHAR " PARSE model" ENVIRONMENT? DROP\r
 203 CHAR " PARSE ROM Model" COMPARE 0=\r
 204 [IF]\r
 205   : C"   [CHAR] " PARSE\r
 206          DUP [ BL PARSE /COUNTED-STRING ENVIRONMENT? DROP ] LITERAL\r
 207          > IF -18 THROW THEN    \ parsed string overflow\r
 208          POSTPONE doC" xhere pack" TOxhere ; COMPILE-ONLY IMMEDIATE\r
 209 [THEN]\r
 210 CHAR " PARSE model" ENVIRONMENT? DROP\r
 211 CHAR " PARSE RAM Model" COMPARE 0=\r
 212 [IF]\r
 213   : C"   [CHAR] " PARSE\r
 214          DUP [ BL PARSE /COUNTED-STRING ENVIRONMENT? DROP ] LITERAL\r
 215          > IF -18 THROW THEN    \ parsed string overflow\r
 216          POSTPONE doC" HERE pack" TO HERE ; COMPILE-ONLY IMMEDIATE\r
 217 [THEN]\r
 218 CHAR " PARSE model" ENVIRONMENT? DROP\r
 219 CHAR " PARSE EXE Model" COMPARE 0=\r
 220 [IF]\r
 221   : C"   [CHAR] " PARSE\r
 222          DUP [ BL PARSE /COUNTED-STRING ENVIRONMENT? DROP ] LITERAL\r
 223          > IF -18 THROW THEN    \ parsed string overflow\r
 224          ALIGN HERE DUP POSTPONE LITERAL\r
 225          pack" ALIGNED TO HERE ; COMPILE-ONLY IMMEDIATE\r
 226 [THEN]\r
 227 \r
 228 \   ERASE       ( addr u -- )                   \ CORE EXT\r
 229 \               If u is greater than zero, clear all bits in each of u\r
 230 \               consecutive address units of memory beginning at addr .\r
 231 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 232 [IF]\r
 233   CR .( ERASE need to be CODE defined.) CR\r
 234   .( No ANS Standard word except MOVE and ERASE can access address unit directly.)\r
 235 \  ABORT\r
 236 [ELSE] DROP\r
 237   CODE ERASE\r
 238       DI POP,\r
 239       BX BX OR,\r
 240       1 L# JZ,\r
 241       DS AX MOV,\r
 242       AX ES MOV,          \ set ES same as DS\r
 243       SI DX MOV,          \ save SI\r
 244       DI SI MOV,\r
 245       AL AL XOR,\r
 246       AL 0 [SI] MOV,\r
 247       BX CX MOV,\r
 248       DI INC,\r
 249       CX DEC,\r
 250       REP, BYTE MOVS,\r
 251       DX SI MOV,\r
 252   1 L:\r
 253       BX POP,\r
 254       NEXT,\r
 255   END-CODE\r
 256 [THEN]\r
 257 \r
 258 \   ROLL        ( xu xu-1 ... x0 u -- xu-1 ... x0 xu )          \ CORE EXT\r
 259 \               Remove u.  Rotate u+1 items on the top of the stack.  An\r
 260 \               ambiguous condition exists if there are less than u+2 items\r
 261 \               on the stack before ROLL is executed.\r
 262 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 263 [IF]\r
 264   : ROLL\r
 265       DEPTH DUP 2 < IF -4 THROW THEN    \ stack underflow\r
 266       2 - OVER U< IF -4 THROW THEN\r
 267       DUP 1+ PICK >R >R           \ x_u ... x1 x0  R: x_u u\r
 268       sp@ DUP CELL+ R> CELLS MOVE DROP R> ;\r
 269 [ELSE] DROP\r
 270   CODE ROLL\r
 271       userP ) DI MOV,\r
 272       1 CELLS [DI] DI MOV,        \ sp0\r
 273       SP DI SUB,\r
 274       DI 1 SAR,                   \ depth-1 in DI\r
 275       DI DEC,\r
 276       1 L# JS,\r
 277       BX DI CMP,\r
 278       1 L# JB,\r
 279       SI DX MOV,\r
 280       BX CX MOV,\r
 281       BX 1 SHL,\r
 282       SP BX ADD,\r
 283       BX DI MOV,\r
 284       DI SI MOV,\r
 285       1 CELLS # SI SUB,\r
 286       0 [BX] BX MOV,\r
 287       STD,\r
 288       REP, WORD MOVS,\r
 289       CLD,\r
 290       AX POP,\r
 291       DX SI MOV,\r
 292       NEXT,\r
 293   1 L:\r
 294       -4 # BX MOV,\r
 295       ' THROW # JMP,\r
 296   END-CODE\r
 297 [THEN]\r
 298 \r
 299 \   TUCK        ( x1 x2 -- x2 x1 x2 )           \ CORE EXT\r
 300 \               Copy the first (top) stack item below the second stack item.\r
 301 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 302 [IF]\r
 303   : TUCK   SWAP OVER ;\r
 304 [ELSE] DROP\r
 305   CODE TUCK\r
 306       AX POP,\r
 307       BX PUSH,\r
 308       AX PUSH,\r
 309       NEXT,\r
 310   END-CODE\r
 311 [THEN]\r
 312 \r
 313 \   U>          ( u1 u2 -- flag )               \ CORE EXT\r
 314 \               flag is true if and only if u1 is greater than u2.\r
 315 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 316 [IF]\r
 317   : U>   SWAP U< ;\r
 318 [ELSE] DROP\r
 319 CODE U>\r
 320       AX POP,\r
 321       AX BX CMP,\r
 322       -1 # BX MOV,\r
 323       1 L# JB,\r
 324       BX INC,\r
 325   1 L:\r
 326       NEXT,\r
 327   END-CODE\r
 328 [THEN]\r
 329 \r
 330 \   CS-PICK                                     \ TOOLS EXT\r
 331 \    Execution: ( C: destu ... orig0|dest0 -- destu ... orig0|dest0 destu )\r
 332 \               ( S: u -- )\r
 333 \  Interpretation: Interpretation semantics for this word are undefined.\r
 334 \\r
 335 \               Remove u.  Copy destu to the top of the control-flow\r
 336 \               stack.  An ambiguous condition exists if there are\r
 337 \               less than u+1 items, each of which shall be an orig\r
 338 \               or dest, on the control-flow stack before CS-PICK is\r
 339 \               executed.\r
 340 \\r
 341 \               If the control-flow stack is implemented using the\r
 342 \               data stack, u shall be the topmost item on the data\r
 343 \               stack.\r
 344 : CS-PICK  ( destu ... orig0|dest0 u -- destu ... orig0|dest0 destu )\r
 345     DUP 2* 1+ PICK              \ check destu; dest type is 0\r
 346     IF -22 THROW THEN           \ control structure mismatch\r
 347     DUP >R  0 SWAP              \ destu ... orig0|dest0 0 u  R: u\r
 348     1+ 0 DO I 2* 1+ PICK OR LOOP        \ dest type is 0; orig type is 1\r
 349     1 INVERT AND IF -22 THROW THEN      \ ORed types should be 0\r
 350     R> 2* 1+ PICK 0\r
 351     bal 1+ TO bal ; COMPILE-ONLY\r
 352 \r
 353 \   CS-ROLL                                     \ TOOLS EXT\r
 354 \    Execution: ( C: origu|destu origu-1|destu-1 ... orig0|dest0 --\r
 355 \                               origu-1|destu-1 ... orig0|dest0 origu|destu )\r
 356 \               ( S: u -- )\r
 357 \  Interpretation: Interpretation semantics for this word are undefined.\r
 358 \\r
 359 \               Remove u.  Rotate u+1 elements on top of the\r
 360 \               control-flow stack so that origu|destu is on top of\r
 361 \               the control-flow stack.  An ambiguous condition\r
 362 \               exists if there are less than u+1 items, each of\r
 363 \               which shall be an orig or dest, on the control-flow\r
 364 \               stack before CS-ROLL is executed.\r
 365 \\r
 366 \               If the control-flow stack is implemented using the\r
 367 \               data stack, u shall be the topmost item on the data\r
 368 \               stack.\r
 369 : CS-ROLL  ( origu|destu origu-1|destu-1 ... orig0|dest0 u --\r
 370                 \       origu-1|destu-1 ... orig0|dest0 origu|destu )\r
 371     DUP >R  0 SWAP              \ destu ... orig0|dest0 0 u  R: u\r
 372     1+ 0 DO I 2* 1+ PICK OR LOOP        \ dest type is 0; orig type is 1\r
 373     1 INVERT AND IF -22 THROW THEN      \ ORed types should be 0\r
 374     R@ 2* 1+ ROLL\r
 375     R> 2* 1+ ROLL ; COMPILE-ONLY\r
 376 \r
 377 SET-CURRENT  SET-ORDER\r
 378 \r
 379 CHAR " PARSE model" ENVIRONMENT? DROP\r
 380 CHAR " PARSE ROM Model" COMPARE 0=\r
 381 [IF] RAM/ROM! [THEN]\r
 382 BASE !\r
 383 \r
 384 CHAR " PARSE FILE" ENVIRONMENT?\r
 385 [IF]\r
 386   0= [IF] << CON [THEN]\r
 387 [ELSE] << CON\r
 388 [THEN]\r