asm8086.f

   1 \ 8086/8 Assembler for hForth\r
   2 \\r
   3 \ This 8088 Assembler has been rewritten by Sheen Lee for hForth\r
   4 \\r
   5 \ ----------------------------------------------------------------------------\r
   6 \ This 8088 Assembler was originally written by Mike Perry and\r
   7 \ Steve Pollack.  It has been rewritten by Martin Tracy\r
   8 \ and rewritten again by Rick VanNorman (to adapt it to a\r
   9 \ 32-bit environment).\r
  10 \ Programmers who are familiar with the original F83 assembler\r
  11 \ will find the following major differences:\r
  12 \\r
  13 \ 1. the mode  #) is now simply )\r
  14 \ 2. the mode S#) has disappeared.\r
  15 \ 3. conditional macros have been replaced by local labels.\r
  16 \ 4. REPZ and REPNZ are now REPE and REPNE.\r
  17 \ 5. JZ  JNZ  JC  JNC  and more error checks have been added.\r
  18 \ 6. the JMP and CALL instructions now have an indirect mode:\r
  19 \\r
  20 \    MYLABEL  # JMP  means  JMP to this label, but\r
  21 \    MYVECTOR ) JMP  means  JMP indirectly through this address.\r
  22 \ ----------------------------------------------------------------------------\r
  23 \r
  24 \ Further modifications by Wonyong Koh\r
  25 \\r
  26 \ 1996. 11. 29.\r
  27 \       Revise ';CODE' for control-flow stack.\r
  28 \ 1996. 4. 15.\r
  29 \       ';CODE' is fixed. END-CODE is changed.\r
  30 \ 1995. 11. 27.\r
  31 \       ';CODE' is redefined following the change of 'DOES>' and 'doCREATE'.\r
  32 \\r
  33 \ o 'MOV', 'JMP', etc are renamed to 'MOV,', 'JMP,', etc. You can\r
  34 \   use Standard Forth words 'AND', 'OR', 'XOR' between 'CODE' and\r
  35 \   'END-CODE' with no confliction.\r
  36 \ o ANS Standard word ';CODE' is added.\r
  37 \ o The definition of '1MI' for hForth 8086 ROM Model is better to be\r
  38 \       : 1MI   RAM/ROM@ ROM CREATE C, RAM/ROM!  DOES> C@ xb, ;\r
  39 \   rather than\r
  40 \       : 1MI   CREATE  C,  DOES> C@ xb, ;\r
  41 \   However, I did not bother and simply put 'ROM' and 'RAM' in\r
  42 \   'ASM8086.F' since '1MI' won't be used in any other places.\r
  43 \r
  44 CHAR " PARSE CPU" ENVIRONMENT? DROP\r
  45 CHAR " PARSE 8086" COMPARE\r
  46 [IF] CR .( This assembler is for 8086 only.) ABORT [THEN]\r
  47 \r
  48 BASE @\r
  49 CHAR " PARSE model" ENVIRONMENT? DROP\r
  50 CHAR " PARSE ROM Model" COMPARE 0=\r
  51 [IF] RAM/ROM@ [THEN]\r
  52 GET-ORDER  GET-CURRENT\r
  53 \r
  54 WORDLIST WORDLIST-NAME ASSEMBLER-WORDLIST\r
  55 \r
  56 : ASSEMBLER\r
  57     GET-ORDER NIP ASSEMBLER-WORDLIST SWAP SET-ORDER ;\r
  58 ALSO ASSEMBLER DEFINITIONS\r
  59 \r
  60 HEX\r
  61 \r
  62 \ ----------------------------------------------------- System dependant words\r
  63 \r
  64 CHAR " PARSE model" ENVIRONMENT? DROP\r
  65 CHAR " PARSE ROM Model" COMPARE 0=\r
  66 [IF]\r
  67   : codeB!      C! ;\r
  68   : codeB,      xhere DUP 1+ TOxhere C! ;\r
  69   : code2B,     xhere DUP CELL+ TOxhere ! ;\r
  70   : code4B,     SWAP code2B, code2B, ;\r
  71 [THEN]\r
  72 CHAR " PARSE model" ENVIRONMENT? DROP\r
  73 CHAR " PARSE RAM Model" COMPARE 0=\r
  74 [IF]\r
  75   : codeB!      C! ;\r
  76   : codeB,      HERE DUP 1+    TO HERE C! ;\r
  77   : code2B,     HERE DUP CELL+ TO HERE ! ;\r
  78   : code4B,     SWAP code2B, code2B, ;\r
  79 [THEN]\r
  80 CHAR " PARSE model" ENVIRONMENT? DROP\r
  81 CHAR " PARSE EXE Model" COMPARE 0=\r
  82 [IF]\r
  83   : codeB,       xhere DUP 1+    TO xhere codeB! ;\r
  84   : code2B,      xhere DUP CELL+ TO xhere code! ;\r
  85   : code4B,      SWAP code2B, code2B, ;\r
  86 [THEN]\r
  87 \r
  88 \ ----------------------------------------------------------------- Predicates\r
  89 \r
  90 \ true if offset requires 2 bytes.\r
  91 : BIG? ( o - f)\r
  92     0080 +  FF00 AND  0= INVERT ;\r
  93 \r
  94 \ Error action of several words.\r
  95 : huh? ( w)\r
  96    INVERT IF ." ? " SOURCE TYPE ABORT THEN ;\r
  97 \r
  98 \ aborts if relative distance is too far.\r
  99 : ?FAR ( o )\r
 100     BIG? INVERT huh? ;\r
 101 \r
 102 \ --------------------------------------------------------------- Local labels\r
 103 \r
 104 DECIMAL 16  CONSTANT  MXL#  HEX\r
 105 \r
 106 \ unresolved fwd reference associative stack.  Emptied by INIT.\r
 107 \ Associate stacks can be "popped" from the middle, or wherever\r
 108 \ the key is found.\r
 109 \r
 110 CHAR " PARSE model" ENVIRONMENT? DROP\r
 111 CHAR " PARSE ROM Model" COMPARE 0=\r
 112 [IF]\r
 113   RAM\r
 114 [THEN]\r
 115 \r
 116 CREATE FWDS\r
 117     2 CELLS ALLOT           ( pointers)\r
 118     MXL# 2 * CELLS ALLOT    ( pairs)\r
 119 \r
 120 \ resolved label value array.  Cleared by INIT.\r
 121 CREATE BWDS\r
 122     MXL# CELLS ALLOT\r
 123 \r
 124 \ pushes unresolved reference.\r
 125 : LPUSH ( value=here' key=label#)\r
 126     FWDS 2@ = 0= huh? ( full?)  FWDS  @ 2!  2 CELLS FWDS +! ;\r
 127 \r
 128 \ pops any unresolved references.\r
 129 : LPOP  ( key=label# - value=addr true | key 0)\r
 130     >R  FWDS @  FWDS 2 CELLS +\r
 131     BEGIN  2DUP = 0= ( end start)  WHILE\r
 132         DUP @  R@ =  IF ( found!)\r
 133             DUP CELL+ @ ( addr) >R\r
 134             SWAP 2 CELLS -  DUP FWDS !  2@ ROT 2!  \ promote last pair\r
 135             R> R> ( addr key)  -1 OR  ( addr true)\r
 136             EXIT\r
 137         THEN\r
 138         2 CELLS +\r
 139     REPEAT\r
 140     2DROP R> 0 ;\r
 141 \r
 142 \ returns the address of the label n or 0 if unresolved.\r
 143 : L? ( n - a | 0)\r
 144     DUP MXL# U< huh?  CELLS  BWDS + @ ;\r
 145 \r
 146 \ assigns HERE to label n-1.  Resolves any forward references.\r
 147 \ Assumes 8-bit relative displacements.\r
 148 : L: ( n - a)\r
 149     DUP L? 0= huh? ( should be unknown)\r
 150     xhere  OVER CELLS BWDS + ! ( now known)\r
 151     BEGIN  DUP LPOP ( a -1 | n 0)  WHILE\r
 152         xhere OVER - 1-  SWAP OVER  ?FAR  codeB!  ( resolve ref)\r
 153     REPEAT\r
 154     2DROP ;\r
 155 \r
 156 : L# ( n - a )   \ retrieves the value of label n-1.\r
 157    DUP L?\r
 158    ?DUP 0=  IF  xhere 1+ 2DUP SWAP LPUSH  THEN\r
 159    NIP ;\r
 160 \r
 161 \ ------------------------------------------------------------------ Variables\r
 162 \r
 163 VARIABLE WORD=  \ WORD/BYTE switch  -- normally WORD.\r
 164 VARIABLE FAR=   \ NEAR/FAR  switch  -- normally NEAR.\r
 165 VARIABLE LOG=   \ holds op mask for logical opcodes.  See B/L?\r
 166 \r
 167 : WORD  TRUE  WORD= ! ;\r
 168 : BYTE  FALSE WORD= ! ;\r
 169 : FAR   TRUE  FAR=  ! ;\r
 170 \r
 171 \ ------------------------------------------------ base switches to octal here\r
 172 \r
 173 : OCTAL  [ DECIMAL ] 8 BASE ! ;\r
 174 \r
 175 OCTAL\r
 176 \r
 177 \ ------------------------------------------------------------------ Registers\r
 178 \r
 179 \ defines n register-id-modes used for building opcodes.\r
 180 : REGS ( n id )\r
 181     SWAP 0  DO\r
 182         DUP I  11 * SWAP 1000 * OR CONSTANT\r
 183     LOOP\r
 184     DROP ;\r
 185 \r
 186 10  1 REGS AL CL DL BL AH CH DH BH\r
 187 10  2 REGS AX CX DX BX SP BP SI DI\r
 188 10  4 REGS [BX+SI] [BX+DI] [BP+SI] [BP+DI] [SI] [DI] [BP] [BX]\r
 189  4  4 REGS [SI+BX] [DI+BX] [SI+BP] [DI+BP]\r
 190  4 10 REGS ES CS SS DS\r
 191  2 20 REGS  )  #\r
 192 \r
 193 \ ----------------------------------------------------------------- Mode tests\r
 194 \r
 195 CHAR " PARSE model" ENVIRONMENT? DROP\r
 196 CHAR " PARSE ROM Model" COMPARE 0=\r
 197 [IF]\r
 198   ROM\r
 199 [THEN]\r
 200 \r
 201 : MD   \ determines if a mode is a member of the given class.\r
 202     CREATE ( mode -  )  1000 * ,\r
 203     DOES>  ( mode - f)  @ AND 0= INVERT ;\r
 204 \r
 205  1 MD R8?  ( mode -    8-bit-register?)\r
 206  2 MD R16? ( mode -   16-bit-register?)\r
 207  3 MD REG? ( mode - 8/16-bit-register?)\r
 208  4 MD [x]? ( mode -  indirect/indexed?)\r
 209 10 MD SEG? ( mode -  segment-register?)\r
 210 \r
 211 : RLOW ( register-mode - r/m-mask )  07 AND ;\r
 212 : RMID ( register-mode - reg-mask )  70 AND ;\r
 213 \r
 214 \ --------------------------------------------------------- Special mode tests\r
 215 \r
 216 \ true if n takes two bytes or sign-extend is not permitted.\r
 217 : B/L? ( n - f)\r
 218     BIG?  LOG= @  OR ;\r
 219 \r
 220 \ true if mem -> acc\r
 221 : >ACC? ( mode reg - f)\r
 222     RLOW 0=  SWAP ) = AND ;\r
 223 \r
 224 : ?MAD ( f )     IF ." Mode? " SOURCE TYPE ABORT THEN ;\r
 225 : ?ACC ( mode )  DUP AX =  SWAP AL = OR INVERT ?MAD ;\r
 226 \r
 227 \ ----------------------------------------------------------- Opcode compilers\r
 228 \r
 229 :   OP, ( opcode mask | mask opcode ) OR codeB, ;\r
 230 \r
 231 :    W, ( opcode mode )  R16?    NEGATE  OP, ;\r
 232 : WORD, ( opcode      )  WORD= @ NEGATE  OP, ;\r
 233 \r
 234 : RR, ( register-mode1 register-mode2 )\r
 235     RMID  SWAP RLOW OR  300 OP, ;\r
 236 \r
 237 : ,/C, ( n 16-bit? )\r
 238     IF  code2B,  ELSE  codeB,  THEN ;\r
 239 \r
 240 \ ---------------------------------------------------------- Address compilers\r
 241 \r
 242 \ compiles memory->register operand.\r
 243 : MEM, ( a/o mode register-mode)\r
 244     RMID  OVER ) =  IF\r
 245         6 OP,  DROP  code2B,                    ( direct )\r
 246     ELSE\r
 247         OVER RLOW OR  ( reg:r/m field) ROT ROT  ( field addr mode)\r
 248         ( mode) [BP] =  OVER 0= AND  IF         ( 0 [BP] exception..)\r
 249             SWAP  100 OP, codeB,                ( ...requires offset)\r
 250         ELSE  SWAP OVER BIG?  IF\r
 251             200 OP,  ( 2-byte offset) code2B,\r
 252         ELSE  OVER  IF\r
 253             100 OP,  ( 1-byte offset) codeB,\r
 254         ELSE\r
 255             OP,  ( zero offset)\r
 256         THEN THEN THEN\r
 257     THEN  ;\r
 258 \r
 259 \ register-mode selects BYTE/WORD w-field.\r
 260 : WMEM, ( a/o mode register-mode opcode )\r
 261     OVER W,  MEM, ;\r
 262 \r
 263 \ selects between register->register and memory->register.\r
 264 : R/M,  ( [operand] mode register-mode )\r
 265     OVER REG?  IF  RR,  ELSE  MEM,  THEN ;\r
 266 \r
 267 \  R/M, but modifies opcode with BYTE/WORD.\r
 268 : WR/M, ( [operand] mode register-mode opcode )\r
 269     2 PICK  DUP REG?  IF\r
 270         W, RR,                  ( register->register)\r
 271     ELSE\r
 272         DROP  WORD, MEM,  WORD  ( memory  ->register)\r
 273     THEN ;\r
 274 \r
 275 \ ---------------------------------------------------------- Opcode generators\r
 276 \r
 277 \ one-byte opcodes with implied operands.\r
 278 : 1MI\r
 279     CREATE  C,\r
 280     DOES>   C@ codeB, ;\r
 281 \r
 282 \ two-byte opcodes with implied operands.\r
 283 : 2MI\r
 284     CREATE  C,\r
 285     DOES>   C@ codeB,  12 codeB, ;\r
 286 \r
 287 \ jump to a one-byte displacement.\r
 288 : 3MI\r
 289     CREATE  C,\r
 290     DOES>   C@  codeB, ( a ) xhere - 1-  DUP ?FAR  codeB, ;\r
 291 \r
 292 \ LDS LEA LES opcodes.\r
 293 : 4MI\r
 294     CREATE  C,\r
 295     DOES>   C@  codeB, ( mem reg) OVER REG? ?MAD  MEM, ;\r
 296 \r
 297 \ string opcodes.\r
 298 : 5MI\r
 299     CREATE  C,\r
 300     DOES>   C@ WORD,  WORD ;\r
 301 \r
 302 \ one-byte opcodes with single operands.\r
 303 : 7MI\r
 304     CREATE  C,\r
 305     DOES>   C@  366 WR/M, ;\r
 306 \r
 307 \ IN and OUT.  Syntax for both: port/DX AL/AX IN/OUT\r
 308 : 8MI\r
 309     CREATE  C,\r
 310     DOES>   C@  OVER ?ACC  ROT\r
 311             DUP # =  OVER DX =  OR INVERT ?MAD\r
 312             # =  IF\r
 313                 SWAP W,  codeB,\r
 314             ELSE\r
 315                 10 OR  SWAP W,\r
 316             THEN ;\r
 317 \r
 318 \ INC and DEC.  Syntax is: r/mem opcode.\r
 319 : 9MI\r
 320    CREATE  C,\r
 321    DOES>   C@  OVER SEG? ?MAD\r
 322            OVER R16?  IF\r
 323                100 OR  SWAP RLOW OP,\r
 324            ELSE\r
 325                376 WR/M,\r
 326            THEN ;\r
 327 \r
 328 \ shift and rotate group.  Syntax is: r/mem [ CL | 1 ] opcode.\r
 329 : 10MI\r
 330     CREATE  C,\r
 331     DOES>   C@  OVER CL =  IF\r
 332                 NIP 322\r
 333             ELSE\r
 334                 OVER 1 =  IF  NIP  THEN\r
 335                 320\r
 336             THEN\r
 337             WR/M, ;\r
 338 \r
 339 \ CALL and JMP.\r
 340 : 11MI\r
 341     CREATE  C, C,\r
 342     DOES>   >R  ( ... mode)  DUP REG? FAR= @ AND ?MAD  R>\r
 343             OVER  # =  ( [d]addr # ^opcode) IF\r
 344                 NIP  FAR= @ IF\r
 345                     1+ C@  codeB,  code4B,\r
 346                 ELSE\r
 347                     C@ SWAP xhere - 2 - SWAP OVER\r
 348                     BIG? INVERT OVER 1 AND ( JMP?)  AND  IF\r
 349                         2 OP, codeB,\r
 350                     ELSE\r
 351                         codeB, 1- code2B,\r
 352                     THEN\r
 353                 THEN\r
 354             ELSE ( r/mem ^opcode)\r
 355                 377 codeB,\r
 356                 1+ C@  FAR= @ INVERT 10 AND  XOR  R/M,\r
 357             THEN\r
 358             0 FAR= ! ;\r
 359 \r
 360 \ POP and PUSH.\r
 361 : 12MI\r
 362     CREATE  C, C, C,\r
 363     DOES>   OVER REG?  IF\r
 364                 C@  OVER  R8? ?MAD   SWAP RLOW  OP,\r
 365             ELSE  1+  OVER SEG?  IF\r
 366                 C@  OVER CS =  OVER 1 AND ( POP) AND  ?MAD\r
 367                 RLOW SWAP  RMID OP,\r
 368             ELSE\r
 369                 COUNT SWAP C@  codeB,  MEM,\r
 370             THEN THEN ;\r
 371 \r
 372 \ Note: BIG # AL is not detected as an error.\r
 373 : 13MA  ( operand reg opcode )\r
 374     >R  OVER REG?  IF\r
 375         R> OVER W, SWAP RR,                             ( reg->reg)\r
 376     ELSE  OVER  DUP [x]? SWAP  ) = OR  IF\r
 377         R> 2 OR WMEM,                                   ( mem->reg)\r
 378     ELSE\r
 379         SWAP # - ?MAD                                   ( #  ->reg)\r
 380         DUP RLOW 0= ( AL/AX?)  IF\r
 381             R> 4 OR  OVER W,  R16? ,/C,                 ( #  ->acc)\r
 382         ELSE                                            ( data reg)\r
 383             OVER B/L?  OVER R16?  2DUP AND  ROT ROT     ( data reg m m f)\r
 384             NEGATE  SWAP INVERT 2 AND  OR  200 OP,      ( data reg m)\r
 385             SWAP  RLOW 300  OR   R>  OP,  ,/C,\r
 386         THEN\r
 387     THEN THEN ;\r
 388 \r
 389 : 13MB  ( operand opcode )\r
 390     >R  ROT DUP REG?  IF\r
 391         R> WMEM,                                ( reg->mem)\r
 392     ELSE\r
 393         # - ?MAD                                ( #  ->mem) ( data mem)\r
 394         2 PICK B/L?  DUP INVERT 2 AND  200 OR  WORD,\r
 395         ROT ROT R> MEM,  WORD= @ AND ,/C,  WORD\r
 396     THEN ;\r
 397 \r
 398 \ adds, subtracts and logicals.\r
 399 : 13MI\r
 400     CREATE  C, C,\r
 401     DOES>   COUNT SWAP C@ LOG= !\r
 402             OVER REG?  IF  13MA  ELSE  13MB  THEN ;\r
 403 \r
 404 \ RET.\r
 405 : 14MI\r
 406     CREATE  C,\r
 407     DOES>   C@  FAR= @ 10 AND  OR  0 FAR= !     ( [offset] opcode)\r
 408             DUP  codeB,\r
 409             1 AND 0= IF  code2B,  THEN ;        (  offset  +RET  )\r
 410 \r
 411 \r
 412 \ Segment override prefices.\r
 413 \r
 414 : SEG ( seg )   RMID 46 OP, ;\r
 415 \r
 416 : CS:   CS SEG ;\r
 417 : DS:   DS SEG ;\r
 418 : ES:   ES SEG ;\r
 419 : SS:   SS SEG ;\r
 420 \r
 421 \ ------------------------------------------------------- Special opcode  TEST\r
 422 : TEST, ( source dest )\r
 423     DUP REG? IF\r
 424         OVER REG? IF\r
 425             204 OVER W,  SWAP RR,       ( reg->reg)\r
 426         ELSE\r
 427             SWAP  # - ?MAD              ( #  ->reg)\r
 428             DUP RLOW 0= ( AL/AX?) IF\r
 429                 250 OVER W,             ( #  ->acc)\r
 430             ELSE\r
 431                 366 OVER W,  DUP RLOW 300 OP,\r
 432             THEN\r
 433             R16? ,/C,\r
 434         THEN\r
 435     ELSE ( [offset] mode mem)\r
 436         ROT  DUP REG? IF\r
 437             204 WMEM,                   ( reg->mem)\r
 438         ELSE\r
 439             # - ?MAD                    ( #  ->mem)\r
 440             366 WORD,  0 MEM,  WORD= @ ,/C,  WORD\r
 441         THEN\r
 442     THEN ;\r
 443 \r
 444 \ -------------------------------------------------- base switches to hex here\r
 445 \r
 446 HEX\r
 447 \r
 448 \ --------------------------------------------------------- Special opcode MOV\r
 449 \r
 450 : MOV, ( source destination )\r
 451     DUP SEG? IF\r
 452         8E codeB, R/M,                                          ( mem->seg)\r
 453     ELSE DUP REG? IF\r
 454         2DUP >ACC? IF\r
 455             A0 SWAP W, DROP  code2B,                            ( mem->acc)\r
 456         ELSE OVER SEG? IF\r
 457             SWAP 8C codeB, RR,                                  ( seg->reg)\r
 458         ELSE OVER # = IF\r
 459             NIP DUP R16? SWAP RLOW OVER 8 AND OR B0 OP, ,/C,    ( #  ->reg)\r
 460         ELSE\r
 461             8A OVER W, R/M,                                     ( mem->reg)\r
 462         THEN THEN THEN\r
 463     ELSE ROT DUP SEG? IF\r
 464         8C codeB, MEM,                                          ( seg->mem)\r
 465     ELSE DUP # = IF\r
 466         DROP C6 WORD, 0 MEM,  WORD= @ ,/C,                      ( #  ->mem)\r
 467     ELSE 2DUP >ACC? IF\r
 468         A2 SWAP W,  DROP  code2B,                               ( acc->mem)\r
 469     ELSE\r
 470         88 OVER W,  R/M,                                        ( reg->mem)\r
 471     THEN THEN THEN THEN THEN\r
 472     WORD ;\r
 473 \r
 474 \ ----------------------------------------------- Special opcodes INT and XCHG\r
 475 \r
 476 : INT,  ( n )\r
 477     DUP 3 =  IF  DROP  CC codeB,  EXIT  THEN\r
 478     CD codeB,  codeB, ;\r
 479 \r
 480 : XCHG, ( mem reg)\r
 481     DUP REG? IF\r
 482         OVER REG? OVER AX = AND IF\r
 483             DROP RLOW 90 OP,    ( reg->AX )\r
 484         ELSE OVER AX =  IF\r
 485             NIP  RLOW 90 OP,    ( AX- >reg)\r
 486         ELSE\r
 487             86 WR/M,            ( mem->reg)\r
 488         THEN THEN\r
 489     ELSE\r
 490         ROT 86 WR/M,            ( reg->mem)\r
 491     THEN ;\r
 492 \r
 493 \ -------------------------------------------------------------------- Opcodes\r
 494 \r
 495    37  1MI AAA,      D5  2MI AAD,      D4  2MI AAM,      3F  1MI AAS,\r
 496 00 10 13MI ADC,   00 00 13MI ADD,   02 20 13MI AND,   9A E8 11MI CALL,\r
 497    98  1MI CBW,      F8  1MI CLC,      FC  1MI CLD,      FA  1MI CLI,\r
 498    F5  1MI CMC,   00 38 13MI CMP,      A6  5MI CMPS,     99  1MI CWD,\r
 499    27  1MI DAA,      2F  1MI DAS,      08  9MI DEC,      30  7MI DIV,\r
 500          ( ESC )     F4  1MI HLT,      38  7MI IDIV,     28  7MI IMUL,\r
 501    E4  8MI IN,       00  9MI INC,            ( INT )     CE  1MI INTO,\r
 502    CF  1MI IRET,\r
 503 \r
 504    9F  1MI LAHF,\r
 505    C5  4MI LDS,      8D  4MI LEA,      C4  4MI LES,      F0  1MI LOCK,\r
 506    AC  5MI LODS,     E2  3MI LOOP,     E1  3MI LOOPE,    E0  3MI LOOPNE,\r
 507          ( MOV, )    A4  5MI MOVS,     20  7MI MUL,      18  7MI NEG,\r
 508    90  1MI NOP,      10  7MI NOT,   02 08 13MI OR,       E6  8MI OUT,\r
 509                8F 07 58 12MI POP,      9D  1MI POPF,\r
 510                FF 36 50 12MI PUSH,     9C  1MI PUSHF,\r
 511    10 10MI RCL,      18 10MI RCR,\r
 512    F3  1MI REP,      F2  1MI REPNE,    F3  1MI REPE,\r
 513    C3 14MI RET,      00 10MI ROL,       8 10MI ROR,      9E  1MI SAHF,\r
 514    38 10MI SAR,   00 18 13MI SBB,      AE  5MI SCAS,           ( SEG )\r
 515    20 10MI SHL,      28 10MI SHR,      F9  1MI STC,      FD  1MI STD,\r
 516    FB  1MI STI,      AA  5MI STOS,  00 28 13MI SUB,            ( TEST, )\r
 517    9B  1MI WAIT,           ( XCHG )    D7  1MI XLAT,  02 30 13MI XOR,\r
 518    C2 14MI +RET,\r
 519 EA E9 11MI JMP,\r
 520 \r
 521    70  3MI JO,\r
 522    71  3MI JNO,\r
 523    72  3MI JB,       72  3MI JC,\r
 524    73  3MI JAE,      73  3MI JNC,\r
 525    74  3MI JE,       74  3MI JZ,\r
 526    75  3MI JNE,      75  3MI JNZ,\r
 527    76  3MI JBE,\r
 528    77  3MI JA,       77  3MI JNBE,\r
 529    78  3MI JS,\r
 530    79  3MI JNS,\r
 531    7A  3MI JPE,\r
 532    7B  3MI JPO,\r
 533    7C  3MI JL,       7C  3MI JNGE,\r
 534    7D  3MI JGE,      7D  3MI JNL,\r
 535    7E  3MI JLE,      7E  3MI JNG,\r
 536    7F  3MI JG,       7F  3MI JNLE,\r
 537    E3  3MI JCXZ,\r
 538    EB  3MI JU,\r
 539 \r
 540 \ ----------------------------------------------------------------------------\r
 541 \r
 542 : INIT-ASM   \ initializes local labels and switches.\r
 543     FWDS  2 CELLS +  DUP FWDS !\r
 544     MXL# 2* CELLS +  FWDS CELL+ !\r
 545     BWDS  MXL# CELLS  0 FILL\r
 546     0 FAR= !  WORD ;\r
 547 \r
 548 : END-CODE\r
 549     PREVIOUS  notNONAME? IF  linkLast  0 TO notNONAME?  THEN ;\r
 550 \r
 551 CHAR " PARSE model" ENVIRONMENT? DROP\r
 552 CHAR " PARSE ROM Model" COMPARE 0=\r
 553 CHAR " PARSE model" ENVIRONMENT? DROP\r
 554 CHAR " PARSE RAM Model" COMPARE 0= OR\r
 555 [IF]\r
 556   : NEXT, ( a macro)\r
 557       AD    codeB,      \ LODSW\r
 558       E0FF  code2B, ;   \ JMP AX\r
 559 [THEN]\r
 560 CHAR " PARSE model" ENVIRONMENT? DROP\r
 561 CHAR " PARSE EXE Model" COMPARE 0=\r
 562 [IF]\r
 563   : NEXT, ( a macro)\r
 564       2E    codeB,      \ CS:\r
 565       AD    codeB,      \ LODSW\r
 566       E0FF  code2B, ;   \ JMP AX\r
 567 [THEN]\r
 568 \r
 569 \ ----------------------------------------------------------------------------\r
 570 \r
 571 FORTH-WORDLIST SET-CURRENT      \ add the following word in FORTH-WORDLIST\r
 572 \r
 573 \   CODE        ( '<spaces>name' -- )           \ TOOLS EXT\r
 574 \               Skip leading space delimiters.  Parse name delimited by a\r
 575 \               space. Create a definition for name, called a\r
 576 \               'code definition,' with the execution semantics defined below.\r
 577 \               Process subsequent characters in the parse area in an\r
 578 \               implementation-defined manner, thus generating corresponding\r
 579 \               machine code. Those characters typically represent source code\r
 580 \               in a programming language, usually some form of assembly\r
 581 \               language.  The process continues, refilling the input buffer\r
 582 \               as needed, until an implementation-defined ending sequence is\r
 583 \               processed.\r
 584 \\r
 585 \               name Execution:( i*x --- j*x )\r
 586 \               Execute the machine code sequence that was generated\r
 587 \               following CODE.\r
 588 CHAR " PARSE model" ENVIRONMENT? DROP\r
 589 CHAR " PARSE ROM Model" COMPARE 0=\r
 590 [IF]\r
 591   : CODE ( "<spaces>name" -- )    \ TOOLS EXT\r
 592       -1 TO notNONAME?\r
 593       xhere ALIGNED DUP TOxhere   \ align code address\r
 594       head,                       \ register a word in dictionary\r
 595       ALSO ASSEMBLER\r
 596       INIT-ASM ;\r
 597 [THEN]\r
 598 CHAR " PARSE model" ENVIRONMENT? DROP\r
 599 CHAR " PARSE RAM Model" COMPARE 0=\r
 600 [IF]\r
 601   : CODE ( "<spaces>name" -- )    \ TOOLS EXT\r
 602       -1 TO notNONAME?\r
 603       ALIGN  head,                \ register a word in dictionary\r
 604       ALSO ASSEMBLER\r
 605       INIT-ASM ;\r
 606 [THEN]\r
 607 CHAR " PARSE model" ENVIRONMENT? DROP\r
 608 CHAR " PARSE EXE Model" COMPARE 0=\r
 609 [IF]\r
 610   : CODE ( "<spaces>name" -- )\r
 611       -1 TO notNONAME?\r
 612       xhere ALIGNED               \ align code address and reserve\r
 613       CELL+ DUP TO xhere          \ one cell for 'xt>name' pointer\r
 614       head,                       \ register a word in dictionary\r
 615       ALSO ASSEMBLER\r
 616       INIT-ASM ;\r
 617 [THEN]\r
 618 \r
 619 \   ;CODE       Compilation: ( C: colon-sys -- )        \ TOOLS EXT\r
 620 \               Interpretation: Interpretation semantics for this word\r
 621 \                               are undefined.\r
 622 \               Append the run-time semantics below to the current definition.\r
 623 \               End the current definition, allow it to be found in the\r
 624 \               dictionary, and enter interpretation state, consuming\r
 625 \               colon-sys. Process subsequent characters in the parse area in\r
 626 \               an implementation-defined manner, thus generating corresponding\r
 627 \               machine code. Those characters typically represent source code\r
 628 \               in a programming language, usually some form of assembly\r
 629 \               language.  The process continues, refilling the input buffer as\r
 630 \               needed, until an implementation-defined ending sequence is\r
 631 \               processed.\r
 632 \\r
 633 \               Run-time:( -- ) ( R: nest-sys -- )\r
 634 \               Replace the execution semantics of the most recent definition\r
 635 \               with the name execution semantics given below. Return control\r
 636 \               to the calling definition specified by nest-sys. An ambiguous\r
 637 \               condition exists if the most recen definition was not defined\r
 638 \               with CREATE or a user-defined word that calls CREATE.\r
 639 \\r
 640 \               name Execution:( i*x --- j*x )\r
 641 \               Perform the machine code sequence that was generated\r
 642 \               following ;CODE.\r
 643 CHAR " PARSE model" ENVIRONMENT? DROP\r
 644 CHAR " PARSE ROM Model" COMPARE 0=\r
 645 [IF]\r
 646 : ;CODE\r
 647     bal 1- IF -22 THROW THEN        \ control structure mismatch\r
 648     NIP 1+ IF -22 THROW THEN        \ colon-sys type is -1\r
 649     bal- POSTPONE [\r
 650     xhere 2 CELLS - TOxhere\r
 651     ALSO ASSEMBLER INIT-ASM\r
 652     ; COMPILE-ONLY IMMEDIATE\r
 653 [THEN]\r
 654 CHAR " PARSE model" ENVIRONMENT? DROP\r
 655 CHAR " PARSE RAM Model" COMPARE 0=\r
 656 [IF]\r
 657 : ;CODE\r
 658     bal 1- IF -22 THROW THEN        \ control structure mismatch\r
 659     NIP 1+ IF -22 THROW THEN        \ colon-sys type is -1\r
 660     bal- POSTPONE [\r
 661     HERE 2 CELLS - TO HERE\r
 662     ALSO ASSEMBLER INIT-ASM\r
 663     ; COMPILE-ONLY IMMEDIATE\r
 664 [THEN]\r
 665 CHAR " PARSE model" ENVIRONMENT? DROP\r
 666 CHAR " PARSE EXE Model" COMPARE 0=\r
 667 [IF]\r
 668 : ;CODE\r
 669     bal 1- IF -22 THROW THEN        \ control structure mismatch\r
 670     NIP 1+ IF -22 THROW THEN        \ colon-sys type is -1\r
 671     bal- POSTPONE [\r
 672     xhere 2 CELLS - TO xhere\r
 673     ALSO ASSEMBLER INIT-ASM\r
 674     ; COMPILE-ONLY IMMEDIATE\r
 675 [THEN]\r
 676 \r
 677 \ Define some useful non-Standard CODE definitions\r
 678 NONSTANDARD-WORDLIST SET-CURRENT\r
 679 \r
 680 CODE PC@  ( portAddr -- char )\r
 681     BX DX MOV,          \ MOV   DX,BX\r
 682     DX AL IN,           \ IN    AL,DX\r
 683     BX BX XOR,          \ XOR   BX,BX\r
 684     AL BL MOV,          \ MOV   BL,AL\r
 685     NEXT,\r
 686 END-CODE\r
 687 \r
 688 CODE PC!  ( char portAddr -- )\r
 689     BX DX MOV,         \ MOV   DX,BX\r
 690     AX POP,            \ POP   AX\r
 691     DX AL OUT,         \ OUT   DX,AL\r
 692     BX POP,            \ POP   BX\r
 693     NEXT,\r
 694 END-CODE\r
 695 \r
 696 CODE L@  ( segment offset -- x )\r
 697    DS DX MOV,           \ MOV   DX,DS\r
 698    DS POP,              \ POP   DS\r
 699    0 [BX] BX MOV,       \ MOV   BX,[BX]\r
 700    DX DS MOV,           \ MOV   DS,DX\r
 701    NEXT,\r
 702 END-CODE\r
 703 \r
 704 CODE LC@  ( segment offset -- char )\r
 705    DS DX MOV,           \ MOV   DX,DS\r
 706    DS POP,              \ POP   DS\r
 707    0 [BX] BL MOV,       \ MOV   BL,[BX]\r
 708    BH BH XOR,           \ XOR   BH,BH\r
 709    DX DS MOV,           \ MOV   DS,DX\r
 710    NEXT,\r
 711 END-CODE\r
 712 \r
 713 CODE L!  ( x segment offset -- )\r
 714    DS DX MOV,           \ MOV   DX,DS\r
 715    DS POP,              \ POP   DS\r
 716    0 [BX] POP,          \ POP   [BX]\r
 717    DX DS MOV,           \ MOV   DS,DX\r
 718    BX POP,              \ POP   BX\r
 719    NEXT,\r
 720 END-CODE\r
 721 \r
 722 CODE LC!  ( char segment offset -- )\r
 723    DS DX MOV,           \ MOV   DX,DS\r
 724    DS POP,              \ POP   DS\r
 725    AX POP,              \ POP   AX\r
 726    AL 0 [BX] MOV,       \ MOV   [BX],AL\r
 727    DX DS MOV,           \ MOV   DS,DX\r
 728    BX POP,              \ POP   BX\r
 729    NEXT,\r
 730 END-CODE\r
 731 \r
 732 DECIMAL\r
 733 : LDUMP  ( segment offset u -- )\r
 734     ?DUP\r
 735     IF   BASE @ >R HEX          \ segment offset u  R: BASE@\r
 736          1- 16 / 1+\r
 737          0 DO CR OVER 4 U.R [CHAR] : EMIT DUP 4 U.R SPACE 2DUP\r
 738               16 0 DO 2DUP LC@ 3 U.R CHAR+ LOOP\r
 739               2SWAP SPACE SPACE\r
 740               16 0 DO   2DUP LC@ 127 AND DUP 0 BL WITHIN\r
 741                         OVER 127 = OR\r
 742                         IF DROP [CHAR] _ THEN\r
 743                         EMIT CHAR+\r
 744                    LOOP 2DROP\r
 745               enough? IF LEAVE THEN\r
 746          LOOP\r
 747          R> BASE !\r
 748     THEN 2DROP ;\r
 749 \r
 750 CODE DS@  ( -- data_segment_addr )\r
 751   BX PUSH,\r
 752   DS BX MOV,\r
 753   NEXT,\r
 754 END-CODE\r
 755 \r
 756 CODE CS@  ( -- code_segment_addr )\r
 757   BX PUSH,\r
 758   CS BX MOV,\r
 759   NEXT,\r
 760 END-CODE\r
 761 \r
 762 envQList SET-CURRENT\r
 763 -1 CONSTANT ASM8086\r
 764 \r
 765 SET-CURRENT  SET-ORDER\r
 766 \r
 767 CHAR " PARSE model" ENVIRONMENT? DROP\r
 768 CHAR " PARSE ROM Model" COMPARE 0=\r
 769 [IF] RAM/ROM! [THEN]\r
 770 BASE !\r
 771 \r
 772 CHAR " PARSE FILE" ENVIRONMENT?\r
 773 [IF]\r
 774   0= [IF] << CON [THEN]\r
 775 [ELSE] << CON\r
 776 [THEN]\r