Subversion Repositories Kolibri OS

Rev

Blame | Last modification | View Log | Download | RSS feed

  1. ( 486 AND PENTIUM ASSEMBLER FOR WINDOWS 32BIT FORTH, VERSION 1.26 )
  2. ( COPYRIGHT [C] 1994, 1995, BY JIM SCHNEIDER )
  3.  
  4. (    THIS PROGRAM IS FREE SOFTWARE; YOU CAN REDISTRIBUTE IT AND/OR MODIFY )
  5. (    IT UNDER THE TERMS OF THE GNU GENERAL PUBLIC LICENSE AS PUBLISHED BY )
  6. (    THE FREE SOFTWARE FOUNDATION; EITHER VERSION 2 OF THE LICENSE, OR    )
  7. (    <AT YOUR OPTION> ANY LATER VERSION.                                  )
  8. (                                                                         )
  9. (    THIS PROGRAM IS DISTRIBUTED IN THE HOPE THAT IT WILL BE USEFUL,      )
  10. (    BUT WITHOUT ANY WARRANTY; WITHOUT EVEN THE IMPLIED WARRANTY OF       )
  11. (    MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.  SEE THE        )
  12. (    GNU GENERAL PUBLIC LICENSE FOR MORE DETAILS.                         )
  13. (                                                                         )
  14. (    YOU SHOULD HAVE RECEIVED A COPY OF THE GNU GENERAL PUBLIC LICENSE    )
  15. (    ALONG WITH THIS PROGRAM; IF NOT, WRITE TO THE FREE SOFTWARE          )
  16. (    FOUNDATION, INC., 675 MASS AVE, CAMBRIDGE, MA 02139, USA.            )
  17.  
  18. ( DECLARE THE VOCABULARIES NEEDED )
  19. ONLY FORTH DEFINITIONS ( VOCABULARY ASSEMBLER ) ALSO ASSEMBLER DEFINITIONS
  20. VOCABULARY ASM-HIDDEN ALSO ASM-HIDDEN DEFINITIONS ALSO ASSEMBLER
  21. ( THE ALSO ASSEMBLER IS STRICTLY TO TURN OFF STACK WARNINGS )
  22.  
  23. ( WORDS TO MANIPULATE THE VOCABULARY SEARCH ORDER )
  24. : IN-ASM ( ALL LATER WORDS ARE DEFINED IN THE ASSEMBLER VOCABULARY )
  25.         ONLY FORTH ALSO ASM-HIDDEN ALSO ASSEMBLER DEFINITIONS ;
  26. : IN-HIDDEN ( ALL LATER WORDS ARE DEFINED IN THE HIDDEN VOCABULARY )
  27.         ONLY FORTH ALSO ASM-HIDDEN DEFINITIONS ALSO ASSEMBLER ;
  28. : IN-FORTH ( ALL LATER WORDS ARE DEFINED IN THE FORTH VOCABULARY )
  29.         ONLY FORTH DEFINITIONS ALSO ASM-HIDDEN ALSO ASSEMBLER ;
  30. IN-HIDDEN
  31.  
  32. ( MISCELLANEOUS HOUSEKEEPING )
  33. BASE @ DECIMAL ( SAVE THE BASE BECAUSE I HATE GRATUITOUS BASE BASHING )
  34. : CELL- [ 1 CELLS ] LITERAL - ;
  35. : CELL/ [ 1 CELLS ] LITERAL / ;
  36. : 8* 8 * ;
  37. : 8/ 8 / ;
  38. : 8+ 8 + ;
  39. : 8- 8 - ;
  40. : 4+ 4 + ;
  41. : 2+ 2 + ;
  42. : 2- 2 - ;
  43. : 8*+ 8* + ;
  44. : 16*+ 16 * + ;
  45. : 16/MOD 16 /MOD ;
  46. HEX
  47. : C0-8* 0C0 - 8* ;
  48. : C0+ 0C0 + ;
  49. : C0- 0C0 - ;
  50.  
  51. ( DEFER SOME WORDS FOR EASE IN PORTING TO A CROSS ASSEMBLER )
  52. DEFER     CODE-C, '     C, IS     CODE-C, ( X -- )
  53. DEFER     CODE-W, '     W, IS     CODE-W, ( X -- )
  54. DEFER     CODE-D, '      , IS     CODE-D, ( X -- )
  55. DEFER      DATA-, '      , IS      DATA-, ( X -- )
  56. DEFER     CODE-C! '     C! IS     CODE-C! ( X \ A -- )
  57. DEFER     CODE-W! '     W! IS     CODE-W! ( X \ A -- )
  58. DEFER     CODE-D! '      ! IS     CODE-D! ( X \ A -- )
  59. DEFER      DATA-! '      ! IS      DATA-! ( X \ A -- )
  60. DEFER     DATA-+! '     +! IS     DATA-+! ( X \ A -- )
  61. DEFER     CODE-C@ '     C@ IS     CODE-C@ ( A -- X )
  62. DEFER     CODE-W@ '     W@ IS     CODE-W@ ( A -- X )
  63. DEFER     CODE-D@ '      @ IS     CODE-D@ ( A -- X )
  64. DEFER      DATA-@ '      @ IS      DATA-@ ( A -- X )
  65. DEFER   DATA-HERE '   HERE IS   DATA-HERE ( -- A )
  66. DEFER   CODE-HERE '   HERE IS   CODE-HERE ( -- A )
  67. DEFER  CODE-ALIGN '  ALIGN IS  CODE-ALIGN ( -- )
  68. DEFER CODE-HEADER ' HEADER IS CODE-HEADER ( -- )
  69.  
  70. ( REGISTER OUT OF SCOPE FORWARD REFERENCES, FOR USE BY A CROSS-COMPILER )
  71. DEFER REGISTER-REF ' DROP IS REGISTER-REF ( ADDRESS \ TYPE -- ADDRESS )
  72. ( REGISTER ACTUAL CODE CREATION, FOR USE IN OPTOMIZERS, DEBUGGERS, ETC. )
  73. DEFER REGISTER-ASM ' NOOP IS REGISTER-ASM ( DATA \ XT -- DATA \ XT )
  74.  
  75. IN-FORTH
  76. ( SET UP THE REGISTRATION CALLBACK FUNCTIONS )
  77. : SET-REGISTER-REF IS REGISTER-REF ;
  78. : SET-REGISTER-ASM IS REGISTER-ASM ;
  79. IN-HIDDEN
  80.  
  81. ( CONSTANTS FOR THE TYPE ARGUMENT )
  82. 1 CONSTANT  8B-ABS      (  8 BIT ABSOLUTE ADDRESSING )
  83. 2 CONSTANT 16B-ABS      ( 16 BIT ABSOLUTE ADDRESSING )
  84. 3 CONSTANT 32B-ABS      ( 32 BIT ABSOLUTE ADDRESSING )
  85. 5 CONSTANT  8B-REL      (  8 BIT RELATIVE ADDRESSING )
  86. 6 CONSTANT 16B-REL      ( 16 BIT RELATIVE ADDRESSING )
  87. 7 CONSTANT 32B-REL      ( 32 BIT RELATIVE ADDRESSING )
  88.  
  89. ( DEFER THE ERROR HANDLER WORDS SO THEY CAN BE INDIVIDUALLY TURNED OFF )
  90. ( DEFER THEM HERE SO THEY CAN BE USED BEFORE THEY ARE ACTUALLY DEFINED )
  91. : DEF-ERR-HAND ( THE DEFAULT ERROR HANDLER FOR UNINITIALIZED ERROR HANDLERS )
  92.         ( X*I -- X*J )
  93.         -1 ABORT" NO ERROR HANDLER INSTALLED" ;
  94. ' DEF-ERR-HAND CONSTANT DEH-XT
  95.  
  96. DEFER ?PARAMS DEH-XT IS ?PARAMS ( -- ) \ ARE THERE PARAMETERS?
  97. DEFER ?SEG DEH-XT IS ?SEG ( -- ) \ IS THERE A SEG OVERRIDE?
  98. DEFER ?LOCK DEH-XT IS ?LOCK ( -- ) \ IS THERE A LOCK PREFIX?
  99. DEFER ?REP DEH-XT IS ?REP ( -- ) \ IS THERE A REP TYPE PREFIX?
  100. DEFER ?INST-PRE DEH-XT IS ?INST-PRE ( -- ) \ IS THERE AN INST PREFIX?
  101. DEFER ?OPERANDS DEH-XT IS ?OPERANDS ( -- ) \ ARE THERE OPERANDS?
  102. DEFER ?OPSIZE DEH-XT IS ?OPSIZE ( N -- ) \ IS THE OPERAND SIZE MISMATCHED?
  103. DEFER ?ADSIZE DEH-XT IS ?ADSIZE ( N -- ) \ IS THE ADDRESS SIZE MISMATCHED?
  104. DEFER ?SHORT DEH-XT IS ?SHORT ( -- ) \ IS THERE AN ILLEGAL SHORT?
  105. DEFER ?TOOFAR DEH-XT IS ?TOOFAR ( FLAG -- ) \ IS THE DEST OF A BRANCH TO BIG?
  106. DEFER ?UNRES DEH-XT IS ?UNRES ( -- ) \ IS THERE AN UNRESOLVED FORWARD REFERENCE?
  107. DEFER ?NOADSIZE DEH-XT IS ?NOADSIZE ( -- ) \ IS THE FWD REF ADDR SIZE UNKNOWN?
  108. DEFER ?TOOMANYOPS DEH-XT IS ?TOOMANYOPS ( N -- ) \ ARE THERE TOO MANY OPERANDS?
  109. DEFER ?NOFAR DEH-XT IS ?NOFAR ( -- ) \ IS THERE A FAR REFERENCE?
  110. DEFER ?MATCH DEH-XT IS ?MATCH ( X1 \ X2 -- ) \ ERROR IF X1==X2
  111. DEFER ?NOMATCH DEH-XT IS ?NOMATCH ( X1 \ X2 -- ) \ ERROR IF X1!=X2
  112. DEFER ?FINISHED DEH-XT IS ?FINISHED ( -- ) \ ARE THERE OPERANDS LEFT OVER?
  113. DEFER ?BADTYPE DEH-XT IS ?BADTYPE ( MAX TYPE VAL -- ) \ IS THE TYPE UNALLOWED?
  114. DEFER ?BADCOMBINE DEH-XT IS ?BADCOMBINE ( FLAG -- ) \ CAN THE TYPES BE COMBINED?
  115. DEFER ?NOTENOUGH DEH-XT IS ?NOTENOUGH ( N -- ) \ ARE THERE TOO FEW OPERANDS?
  116. DEFER ?NOIMMED DEH-XT IS ?NOIMMED ( -- ) \ IS THERE AN ILLEGAL IMMEDIATE OP?
  117. DEFER ?BADMODE DEH-XT IS ?BADMODE ( FLAG -- ) \ IS THE ADDRESS MODE ILLEGAL?
  118. DEFER ?REG,R/M DEH-XT IS ?REG,R/M ( -- ) \ IS THE DEST A REG?
  119. DEFER ?R/M,REG DEH-XT IS ?R/M,REG ( -- ) \ IS THE SOURCE A REG?
  120. DEFER ?MEM DEH-XT IS ?MEM ( -- ) \ DO WE HAVE AN ILLEGAL REGISTER OPERAND?
  121. DEFER ?REG DEH-XT IS ?REG ( -- ) \ DO WE HAVE AN ILLEGAL MEMORY OPERAND?
  122.  
  123. ( DEFER THE WORD THAT CALLS THE WORDS THAT CREATE THE CODE )
  124. ( IT COMES IN TWO FLAVORS -- PREFIX AND POSTFIX )
  125. ( IT'S DEFERRED HERE SO I CAN USE IT NOW )
  126. : NO-OPCODE-HANDLER -1 ABORT" NO OPCODE CREATOR INSTALLED" ;
  127. DEFER DO-OPCODE ' NO-OPCODE-HANDLER IS DO-OPCODE ( X? \ X? \ 0|ADDR -- )
  128.        \ POSTFIX MODE: THIS ACTUALLY SAVES THE CURRENT INSTRUCTION AND
  129.        \ DOES THE PREVIOUS ONE.
  130.  
  131. IN-ASM
  132. : A; ( FINISH THE ASSEMBLY OF THE PREVIOUS INSTRUCTION )
  133.        ( -- )
  134.        0 DO-OPCODE ;
  135.  
  136. ( ADDRESS AND DATA SIZES )
  137. IN-HIDDEN
  138. 0 CONSTANT UNKNOWN              ( ALSO, OPERAND TYPE AND NUMBER )
  139. 1 CONSTANT 8BIT
  140. 2 CONSTANT 16BIT
  141. 3 CONSTANT 32BIT
  142. 4 CONSTANT 64BIT
  143. 5 CONSTANT 80BIT
  144.  
  145. ( DETERMINE WHAT SIZE CODE TO GENERATE )
  146. 32BIT VALUE DEFAULT-SIZE   ( THE DEFAULT USE SIZE )
  147. : !DEFAULT-SIZE ( NOT THE DEFAULT SIZE, EG. CHANGE 16BIT TO 32BIT )
  148.        ( -- SIZE )
  149.        DEFAULT-SIZE 16BIT = IF 32BIT ELSE 16BIT THEN ;
  150. IN-ASM
  151. : USE16 ( GENERATE 16 BIT CODE BY DEFAULT )
  152.        16BIT TO DEFAULT-SIZE ;
  153. : USE32 ( GENERATE 32 BIT CODE BY DEFAULT )
  154.        32BIT TO DEFAULT-SIZE ;
  155.  
  156. ( CREATE A STACK FOR OPERANDS )
  157. IN-HIDDEN
  158. 7 CONSTANT MAX-OPERANDS         ( MAXIMUM NUMBER OF OPERANDS ON THE OPSTACK )
  159. CREATE OPSTACK MAX-OPERANDS 1+ CELLS ALLOT HERE CONSTANT OPSTACK-END
  160. : CLR-OPSTACK OPSTACK DUP CELL+ SWAP DATA-! ;
  161. CLR-OPSTACK ( INITIALIZE THE OPSTACK )
  162. : ?CLR-OPSTACK ( CLEAR THE OPERAND STACK WHEN THE FLAG IS NON-ZERO )
  163.        ( F -- )
  164.        IF CLR-OPSTACK THEN ;
  165. IN-ASM
  166. : PUSH-OP ( MOVE A PARAMETER STACK ITEM TO THE OPSTACK )
  167.        ( X -- )
  168.        OPSTACK DATA-@ OPSTACK-END = DUP ?CLR-OPSTACK
  169.        ABORT" OPSTACK OVERFLOW" OPSTACK DUP DATA-@ DUP CELL+ ROT DATA-!
  170.        DATA-! ;
  171. : POP-OP ( MOVE AN ITEM FROM THE OPERAND STACK TO THE PARAMETER STACK )
  172.        ( -- X )
  173.        OPSTACK DUP DATA-@ SWAP CELL+ = DUP ?CLR-OPSTACK
  174.        ABORT" OPSTACK UNDERFLOW" OPSTACK DUP DATA-@ CELL- DUP ROT
  175.        DATA-! DATA-@ ;
  176. IN-HIDDEN
  177. : OP-DEPTH ( CHECK THE DEPTH OF THE OPERAND STACK )
  178.        OPSTACK DUP DATA-@ SWAP - CELL- CELL/ ;
  179.  
  180. ( WORDS TO SUPPORT FORWARD REFERENCED LOCAL LABELS )
  181. 100 CONSTANT FRMAX      ( MAX NUMBER OF UNRESOLVED FORWARD REFERENCES )
  182. 140 CONSTANT LBMAX      ( MAX NUMBER OF LOCAL LABELS )
  183. CREATE FRTABLE FRMAX 2* CELLS ALLOT ( HOLDS UNRESOLVED FORWARD REFERENCES )
  184. CREATE LBTABLE LBMAX CELLS ALLOT ( HOLDS LOCAL LABEL BINDINGS )
  185. : ADDREF ( ADD A FORWARD REFERENCE AT CODE-HERE )
  186.        ( REF# -- REF# )
  187.        FRTABLE [ FRMAX 1+ ] LITERAL 0 DO
  188.                FRMAX I = DUP ?CLR-OPSTACK
  189.                ABORT" TOO MANY UNRESOLVED FORWARD REFERENCES"
  190.                DUP DATA-@ IF
  191.                        CELL+ CELL+ ELSE 2DUP DATA-! CODE-HERE OVER CELL+
  192.                        DATA-! LEAVE
  193.                THEN
  194.        LOOP DROP ;
  195. : BACKPATCH ( BACKPATCH A FORWARD REFERENCE TO HERE )
  196.        ( ADDRESS \ SIZE -- )
  197.        CASE   8BIT OF
  198.                CODE-HERE OVER 1+ - DUP ABS 7F > ?TOOFAR SWAP CODE-C!
  199.        ENDOF 16BIT OF
  200.                CODE-HERE OVER 2+ - DUP ABS 7FFF > ?TOOFAR SWAP CODE-W!
  201.        ENDOF 32BIT OF
  202.                CODE-HERE OVER 4+ - SWAP CODE-D!
  203.        ENDOF ?NOADSIZE DROP ENDCASE ;
  204. : REFSIZE ( DETERMINE THE SIZE OF A BOUND REFERENCE )
  205.        ( ADDR OF INSTR -- ADDR OF OPERAND \ SIZE )
  206.        DUP CODE-C@ 67 ( ADDR SIZE OVERRIDE PREFIX ) = IF
  207.                1+ !DEFAULT-SIZE
  208.        ELSE
  209.                DEFAULT-SIZE
  210.        THEN
  211.        ( STACK: ADDRESS OF ACTUAL INSTRUCTION \ PROVISIONAL SIZE )
  212.        >R DUP CODE-C@ CASE
  213.        0F OF ( A NEAR CONDITIONAL BRANCH )
  214.                1+ ( ADJUST FOR THE FIRST BYTE OF THE OPCODE )
  215.        ENDOF 0E9 OF ( A JMP NEAR, DON'T NEED TO DO ANYTHING )
  216.         ENDOF 0E8 OF ( A NEAR CALL, DON'T NEED TO DO ANYTHING )
  217.        ENDOF ( IF WE GET TO HERE, IT MUST BE 8 BIT )
  218.                R> DROP 8BIT >R
  219.        ENDCASE 1+ R> ;
  220. : RESOLVE ( RESOLVE A FORWARD REFERENCE TO CODE-HERE )
  221.        ( REF# -- REF# )
  222.        FRTABLE FRMAX 0 DO
  223.                2DUP DATA-@ = IF
  224.                        DUP CELL+ DATA-@ REFSIZE BACKPATCH 0 OVER DATA-!
  225.                THEN
  226.                CELL+ CELL+
  227.        LOOP
  228.        DROP ;
  229. : !LABEL ( BIND A LABEL TO CODE-HERE )
  230.        ( REF# -- )
  231.        RESOLVE CODE-HERE SWAP CELLS LBTABLE + DATA-! ;
  232. : @LABEL ( FETCH THE BINDING OF A LABEL, OR RETURN A PSEUDO ADDRESS IF NOT )
  233.        ( YET BOUND TO AN ADDRESS )
  234.        ( REF# -- ADDR )
  235.        DUP CELLS LBTABLE + DATA-@ ?DUP IF SWAP DROP ELSE ADDREF DROP
  236.        CODE-HERE THEN ;
  237. : CREATE-REF ( CREATE WORDS TO REFERENCE LOCAL LABELS )
  238.        ( C:: INDEX -- )
  239.        ( R:: -- ADDR )
  240.        CREATE DATA-, DOES> DATA-@ @LABEL ;
  241. : CREATE-BIND ( CREATE WORDS TO BIND LOCAL LABELS )
  242.        ( C:: INDEX -- )
  243.        ( R:: -- )
  244.        CREATE DATA-, DOES> >R A; R> DATA-@ !LABEL ;
  245.  
  246. ( THESE REFERENCES AND BINDINGS ARE NAMED FOR GENERAL USE.  DO NOT USE THEM )
  247. ( IN MACROS )
  248. IN-ASM
  249. 1 CREATE-REF @@1  1 CREATE-BIND @@1:
  250. 2 CREATE-REF @@2  2 CREATE-BIND @@2:
  251. 3 CREATE-REF @@3  3 CREATE-BIND @@3:
  252. 4 CREATE-REF @@4  4 CREATE-BIND @@4:
  253. 5 CREATE-REF @@5  5 CREATE-BIND @@5:
  254. 6 CREATE-REF @@6  6 CREATE-BIND @@6:
  255. 7 CREATE-REF @@7  7 CREATE-BIND @@7:
  256. 8 CREATE-REF @@8  8 CREATE-BIND @@8:
  257. 9 CREATE-REF @@9  9 CREATE-BIND @@9:
  258.  
  259. IN-HIDDEN
  260. 0 VALUE IN-MACRO? ( A SEMAPHORE TO TELL IF WE'RE IN EXECUTION OF A MACRO )
  261. 0A VALUE MACRO-LABELS ( THE FIRST LABEL USED FOR MACROS )
  262. VARIABLE MACRO-LABEL-LEVEL ( FOR LABELS TO USE IN MACROS )
  263. : IN-MACRO ( FLAG THE FACT THAT WE ARE IN A MACRO )
  264.         ( -- )
  265.         1 +TO IN-MACRO? ;
  266. : !IN-MACRO ( FLAG THE FACT THAT WE'VE LEFT A MACRO )
  267.         ( -- )
  268.         -1 +TO IN-MACRO? ;
  269. : +MACRO ( GET AN INDEX INTO THE LABEL TABLE FROM AN OFFSET )
  270.         ( OFFSET -- INDEX )
  271.         MACRO-LABEL-LEVEL DATA-@ + DUP LBMAX >
  272.         ABORT" TOO MANY LOCAL LABELS IN MACROS" ;
  273. : +MACRO-REF ( REFERENCE A LABEL OFFSET FROM THE MACRO LEVEL )
  274.         ( OFFSET -- ADDR )
  275.         +MACRO @LABEL ;
  276. : +MACRO-BIND ( BIND A LABEL OFFSET FROM THE MACRO LEVEL )
  277.         ( OFFSET -- )
  278.         +MACRO !LABEL ;
  279. : ENTER-MACRO ( SET UP MACRO RELATIVE LOCAL LABELS )
  280.         ( -- )
  281.         MACRO-LABELS MACRO-LABEL-LEVEL DUP DATA-@ ROT + DUP ROT DATA-! CELLS
  282.         LBTABLE + MACRO-LABELS CELLS ERASE IN-MACRO ;
  283. : LEAVE-MACRO ( GO BACK TO THE OLD REGIME )
  284.         ( OLD MACRO LABEL LEVEL -- )
  285.         MACRO-LABELS MACRO-LABEL-LEVEL DUP DATA-@ ROT - SWAP DATA-! !IN-MACRO ;
  286. : CREATE-MACRO-REF ( CREATE MACRO-SAFE LOCAL LABEL REFERENCES )
  287.         ( C:: LABEL OFFSET -- )
  288.         ( R:: -- ADDR )
  289.         CREATE DATA-, DOES> DATA-@ +MACRO-REF ;
  290. : CREATE-MACRO-BIND ( CREATE MACRO-SAFE LOCAL LABEL BINDINGS )
  291.         ( C:: LABEL OFFSET -- )
  292.         ( R:: -- )
  293.         CREATE DATA-, DOES> >R A; R> DATA-@ +MACRO-BIND ;
  294. : LOC-INIT ( INITIALIZE THE TABLES AND VARIABLES )
  295.         ( -- )
  296.         FRTABLE [ FRMAX 2* CELLS ] LITERAL ERASE LBTABLE [ LBMAX CELLS ]
  297.         LITERAL ERASE MACRO-LABELS MACRO-LABEL-LEVEL DATA-! ;
  298.  
  299. ( MACRO SAFE LOCAL LABELS )
  300. IN-ASM
  301. 0 CREATE-MACRO-REF @@M0 0 CREATE-MACRO-BIND @@M0:
  302. 1 CREATE-MACRO-REF @@M1 1 CREATE-MACRO-BIND @@M1:
  303. 2 CREATE-MACRO-REF @@M2 2 CREATE-MACRO-BIND @@M2:
  304. 3 CREATE-MACRO-REF @@M3 3 CREATE-MACRO-BIND @@M3:
  305. 4 CREATE-MACRO-REF @@M4 4 CREATE-MACRO-BIND @@M4:
  306. 5 CREATE-MACRO-REF @@M5 5 CREATE-MACRO-BIND @@M5:
  307. 6 CREATE-MACRO-REF @@M6 6 CREATE-MACRO-BIND @@M6:
  308. 7 CREATE-MACRO-REF @@M7 7 CREATE-MACRO-BIND @@M7:
  309. 8 CREATE-MACRO-REF @@M8 8 CREATE-MACRO-BIND @@M8:
  310. 9 CREATE-MACRO-REF @@M9 9 CREATE-MACRO-BIND @@M9:
  311. ( CREATE ALTERNATIVE LABEL REFERENCE AND BINDING NAMES FOR TOM )
  312. 0 CREATE-MACRO-REF L$0  0 CREATE-MACRO-BIND L$0:
  313. 1 CREATE-MACRO-REF L$1  1 CREATE-MACRO-BIND L$1:
  314. 2 CREATE-MACRO-REF L$2  2 CREATE-MACRO-BIND L$2:
  315. 3 CREATE-MACRO-REF L$3  3 CREATE-MACRO-BIND L$3:
  316. 4 CREATE-MACRO-REF L$4  4 CREATE-MACRO-BIND L$4:
  317. 5 CREATE-MACRO-REF L$5  5 CREATE-MACRO-BIND L$5:
  318. 6 CREATE-MACRO-REF L$6  6 CREATE-MACRO-BIND L$6:
  319. 7 CREATE-MACRO-REF L$7  7 CREATE-MACRO-BIND L$7:
  320. 8 CREATE-MACRO-REF L$8  8 CREATE-MACRO-BIND L$8:
  321. 9 CREATE-MACRO-REF L$9  9 CREATE-MACRO-BIND L$9:
  322.  
  323. ( CONSTANTS FOR OPERAND TYPING )
  324. ( OPERAND TYPES )
  325. IN-HIDDEN
  326.  1 CONSTANT INDIRECT    ( 16 BIT REGISTER INDIRECT )
  327.  2 CONSTANT BASED       ( 32 BIT REGISTER INDIRECT OR SCALED INDEX/BASE )
  328.  3 CONSTANT INDEX       ( 32 BIT SCALED INDEX )
  329.  4 CONSTANT IMMEDIATE   ( AN IMMEDIATE OPERAND )
  330.  5 CONSTANT REGISTER    ( A GENERAL PURPOSE MACHINE REGISTER )
  331.  6 CONSTANT SREG        ( A SEGMENT REGISTER )
  332.  7 CONSTANT CREG        ( A CONTROL REGISTER )
  333.  8 CONSTANT DREG        ( A DEBUG REGISTER )
  334.  9 CONSTANT TREG        ( A TEST REGISTER )
  335. 0A CONSTANT FREG        ( A FLOATING POINT REGISTER )
  336.  
  337. ( ENCODE AND DECODE REGISTER REPRESENTATIONS )
  338. ( REGISTER ENCODING: )
  339.         ( BITS  USE )
  340.         ( 0-3   DATA SIZE )
  341.         ( 4-7   ADDRESS SIZE )
  342.         ( 8-11  TYPE )
  343.         ( 12-13 R/M OR S-I-B )
  344. : <ENC-REG> ( ENCODE THE SINGLE CELL OPERAND REPRESENTATION FROM THE VALUES )
  345.         ( ON THE STACK )
  346.         ( DATA SIZE \ ADDR SIZE \ TYPE \ R/M OR S-I-B -- REG VAL )
  347.         16*+ 16*+ 16*+ ;
  348. : <DEC-REG> ( DECODE THE SINGLE CELL OPERAND REPRESENTATION TO ITS )
  349.         ( CONSTITUENT PARTS )
  350.         ( REG VAL -- DATA SIZE \ ADDR SIZE \ TYPE \ R/M OR S-I-B )
  351.         16/MOD 16/MOD 16/MOD ;
  352. : ASM-OP ( CREATE THE ASSEMBLER OPERANDS FROM OPERAND DESCRIPTIONS )
  353.         ( C:: DATA SIZE \ ADDR SIZE \ TYPE \ R/M OR S-I-B -- )
  354.         ( R:: -- )
  355.         ( R::OS: -- X )
  356.         CREATE <ENC-REG> DATA-, DOES> DATA-@ PUSH-OP ;
  357.  
  358. ( THE ASSEMBLER OPERANDS )
  359. IN-ASM
  360.    8BIT UNKNOWN  REGISTER       0 ASM-OP       AL
  361.    8BIT UNKNOWN  REGISTER       1 ASM-OP       CL
  362.    8BIT UNKNOWN  REGISTER       2 ASM-OP       DL
  363.    8BIT UNKNOWN  REGISTER       3 ASM-OP       BL
  364.    8BIT UNKNOWN  REGISTER       4 ASM-OP       AH
  365.    8BIT UNKNOWN  REGISTER       5 ASM-OP       CH
  366.    8BIT UNKNOWN  REGISTER       6 ASM-OP       DH
  367.    8BIT UNKNOWN  REGISTER       7 ASM-OP       BH
  368.   16BIT UNKNOWN  REGISTER       0 ASM-OP       AX
  369.   16BIT UNKNOWN  REGISTER       1 ASM-OP       CX
  370.   16BIT UNKNOWN  REGISTER       2 ASM-OP       DX
  371.   16BIT UNKNOWN  REGISTER       3 ASM-OP       BX
  372.   16BIT UNKNOWN  REGISTER       4 ASM-OP       SP
  373.   16BIT UNKNOWN  REGISTER       5 ASM-OP       BP
  374.   16BIT UNKNOWN  REGISTER       6 ASM-OP       SI
  375.   16BIT UNKNOWN  REGISTER       7 ASM-OP       DI
  376.   32BIT UNKNOWN  REGISTER       0 ASM-OP      EAX
  377.   32BIT UNKNOWN  REGISTER       1 ASM-OP      ECX
  378.   32BIT UNKNOWN  REGISTER       2 ASM-OP      EDX
  379.   32BIT UNKNOWN  REGISTER       3 ASM-OP      EBX
  380.   32BIT UNKNOWN  REGISTER       4 ASM-OP      ESP
  381.   32BIT UNKNOWN  REGISTER       5 ASM-OP      EBP
  382.   32BIT UNKNOWN  REGISTER       6 ASM-OP      ESI
  383.   32BIT UNKNOWN  REGISTER       7 ASM-OP      EDI
  384. UNKNOWN   16BIT  INDIRECT       0 ASM-OP  [BX+SI]
  385. UNKNOWN   16BIT  INDIRECT       1 ASM-OP  [BX+DI]
  386. UNKNOWN   16BIT  INDIRECT       2 ASM-OP  [BP+SI]
  387. UNKNOWN   16BIT  INDIRECT       3 ASM-OP  [BP+DI]
  388. UNKNOWN   16BIT  INDIRECT       4 ASM-OP     [SI]
  389. UNKNOWN   16BIT  INDIRECT       5 ASM-OP     [DI]
  390. UNKNOWN   16BIT  INDIRECT       6 ASM-OP     [BP]
  391. UNKNOWN   16BIT  INDIRECT       7 ASM-OP     [BX]
  392. UNKNOWN   32BIT     BASED       0 ASM-OP    [EAX]
  393. UNKNOWN   32BIT     BASED       1 ASM-OP    [ECX]
  394. UNKNOWN   32BIT     BASED       2 ASM-OP    [EDX]
  395. UNKNOWN   32BIT     BASED       3 ASM-OP    [EBX]
  396. UNKNOWN   32BIT     BASED       4 ASM-OP    [ESP]
  397. UNKNOWN   32BIT     BASED       5 ASM-OP    [EBP]
  398. UNKNOWN   32BIT     BASED       6 ASM-OP    [ESI]
  399. UNKNOWN   32BIT     BASED       7 ASM-OP    [EDI]
  400. UNKNOWN   32BIT     INDEX       8 ASM-OP  [EAX*2]
  401. UNKNOWN   32BIT     INDEX       9 ASM-OP  [ECX*2]
  402. UNKNOWN   32BIT     INDEX      0A ASM-OP  [EDX*2]
  403. UNKNOWN   32BIT     INDEX      0B ASM-OP  [EBX*2]
  404. UNKNOWN   32BIT     INDEX      0D ASM-OP  [EBP*2]
  405. UNKNOWN   32BIT     INDEX      0E ASM-OP  [ESI*2]
  406. UNKNOWN   32BIT     INDEX      0F ASM-OP  [EDI*2]
  407. UNKNOWN   32BIT     INDEX      10 ASM-OP  [EAX*4]
  408. UNKNOWN   32BIT     INDEX      11 ASM-OP  [ECX*4]
  409. UNKNOWN   32BIT     INDEX      12 ASM-OP  [EDX*4]
  410. UNKNOWN   32BIT     INDEX      13 ASM-OP  [EBX*4]
  411. UNKNOWN   32BIT     INDEX      15 ASM-OP  [EBP*4]
  412. UNKNOWN   32BIT     INDEX      16 ASM-OP  [ESI*4]
  413. UNKNOWN   32BIT     INDEX      17 ASM-OP  [EDI*4]
  414. UNKNOWN   32BIT     INDEX      18 ASM-OP  [EAX*8]
  415. UNKNOWN   32BIT     INDEX      19 ASM-OP  [ECX*8]
  416. UNKNOWN   32BIT     INDEX      1A ASM-OP  [EDX*8]
  417. UNKNOWN   32BIT     INDEX      1B ASM-OP  [EBX*8]
  418. UNKNOWN   32BIT     INDEX      1D ASM-OP  [EBP*8]
  419. UNKNOWN   32BIT     INDEX      1E ASM-OP  [ESI*8]
  420. UNKNOWN   32BIT     INDEX      1F ASM-OP  [EDI*8]
  421.   16BIT UNKNOWN      SREG       0 ASM-OP       ES
  422.   16BIT UNKNOWN      SREG       1 ASM-OP       CS
  423.   16BIT UNKNOWN      SREG       2 ASM-OP       SS
  424.   16BIT UNKNOWN      SREG       3 ASM-OP       DS
  425.   16BIT UNKNOWN      SREG       4 ASM-OP       FS
  426.   16BIT UNKNOWN      SREG       5 ASM-OP       GS
  427.   32BIT UNKNOWN      CREG       0 ASM-OP      CR0
  428.   32BIT UNKNOWN      CREG       2 ASM-OP      CR2
  429.   32BIT UNKNOWN      CREG       3 ASM-OP      CR3
  430.   32BIT UNKNOWN      CREG       4 ASM-OP      CR4
  431.   32BIT UNKNOWN      DREG       0 ASM-OP      DR0
  432.   32BIT UNKNOWN      DREG       1 ASM-OP      DR1
  433.   32BIT UNKNOWN      DREG       2 ASM-OP      DR2
  434.   32BIT UNKNOWN      DREG       3 ASM-OP      DR3
  435.   32BIT UNKNOWN      DREG       6 ASM-OP      DR6
  436.   32BIT UNKNOWN      DREG       7 ASM-OP      DR7
  437.   32BIT UNKNOWN      TREG       3 ASM-OP      TR3
  438.   32BIT UNKNOWN      TREG       4 ASM-OP      TR4
  439.   32BIT UNKNOWN      TREG       5 ASM-OP      TR5
  440.   32BIT UNKNOWN      TREG       6 ASM-OP      TR6
  441.   32BIT UNKNOWN      TREG       7 ASM-OP      TR7
  442. UNKNOWN UNKNOWN      FREG       0 ASM-OP       ST
  443. UNKNOWN UNKNOWN      FREG       0 ASM-OP    ST(0)
  444. UNKNOWN UNKNOWN      FREG       1 ASM-OP    ST(1)
  445. UNKNOWN UNKNOWN      FREG       2 ASM-OP    ST(2)
  446. UNKNOWN UNKNOWN      FREG       3 ASM-OP    ST(3)
  447. UNKNOWN UNKNOWN      FREG       4 ASM-OP    ST(4)
  448. UNKNOWN UNKNOWN      FREG       5 ASM-OP    ST(5)
  449. UNKNOWN UNKNOWN      FREG       6 ASM-OP    ST(6)
  450. UNKNOWN UNKNOWN      FREG       7 ASM-OP    ST(7)
  451.    8BIT UNKNOWN   UNKNOWN UNKNOWN ASM-OP     BYTE
  452.   16BIT UNKNOWN   UNKNOWN UNKNOWN ASM-OP     WORD
  453.   32BIT UNKNOWN   UNKNOWN UNKNOWN ASM-OP    DWORD
  454.   64BIT UNKNOWN   UNKNOWN UNKNOWN ASM-OP    QWORD
  455.   32BIT UNKNOWN   UNKNOWN UNKNOWN ASM-OP    FLOAT
  456.   64BIT UNKNOWN   UNKNOWN UNKNOWN ASM-OP   DOUBLE
  457.   80BIT UNKNOWN   UNKNOWN UNKNOWN ASM-OP     LONG
  458.   80BIT UNKNOWN   UNKNOWN UNKNOWN ASM-OP EXTENDED
  459.   80BIT UNKNOWN   UNKNOWN UNKNOWN ASM-OP    TBYTE
  460. UNKNOWN    8BIT   UNKNOWN UNKNOWN ASM-OP    SHORT
  461. UNKNOWN   16BIT   UNKNOWN UNKNOWN ASM-OP     NEAR
  462. UNKNOWN   32BIT   UNKNOWN UNKNOWN ASM-OP      FAR
  463. UNKNOWN UNKNOWN IMMEDIATE UNKNOWN ASM-OP        #
  464. UNKNOWN UNKNOWN   UNKNOWN UNKNOWN ASM-OP        ,
  465.  
  466. ( VARIABLES USED FOR INSTRUCTION CODING )
  467. IN-HIDDEN
  468. VARIABLE INST-PREFIX    ( INSTRUCTION PREFIXES )
  469. VARIABLE ADDR-PREFIX    ( ADDRESS SIZE PREFIX )
  470. VARIABLE DATA-PREFIX    ( DATA SIZE PREFIX )
  471. VARIABLE SEG-PREFIX     ( SEGMENT OVERRIDE PREFIX )
  472. VARIABLE SV-INST-PREFIX ( THE SAVED INSTRUCTION PREFIX )
  473. VARIABLE INST-SAVE      ( THE PREVIOUSLY EXECUTED INSTRUCTION )
  474. VARIABLE SP-SAVE        ( THE STACK POINTER )
  475. VARIABLE OFFSET-SV      ( SAVE THE OFFSET PART )
  476. VARIABLE IMMED-SV       ( SAVE THE IMMEDIATE PART )
  477. VARIABLE DT-SIZE        ( DATA ITEM SIZE )
  478. VARIABLE AD-SIZE        ( ADDRESS SIZE )
  479. VARIABLE RTYPE          ( THE WORKING REGISTER TYPE )
  480. VARIABLE MAXTYPE        ( THE MAXIMUM NUMERICAL TYPE VALUE ENCOUNTERED )
  481. VARIABLE MOD-R/M        ( THE WORKING AREA FOR THE MOD-R/M BYTE )
  482. VARIABLE S-I-B          ( THE WORKING AREA FOR THE S-I-B BYTE )
  483. VARIABLE ADDMODE        ( ADDRESSING MODE FLAGS )
  484.  
  485. : RESET-VARS ( STORE 0 INTO ALL INSTRUCTION CODING VARIABLES )
  486.         0 INST-PREFIX DATA-! 0 ADDR-PREFIX DATA-! 0 DATA-PREFIX DATA-!
  487.         0 SEG-PREFIX DATA-! 0 SV-INST-PREFIX DATA-! 0 INST-SAVE DATA-!
  488.         0 SP-SAVE DATA-! 0 OFFSET-SV DATA-! 0 IMMED-SV DATA-! 0 DT-SIZE DATA-!
  489.         0 AD-SIZE DATA-! 0 RTYPE DATA-! 0 MAXTYPE DATA-! 0 MOD-R/M DATA-!
  490.         0 S-I-B DATA-! 0 ADDMODE DATA-! ;
  491.  
  492. : RESET-FOR-NEXT-INSTR ( STORE A 0 INTO INTERMEDIATE CODING VARIABLES )
  493.         0 OFFSET-SV DATA-! 0 IMMED-SV DATA-! 0 DT-SIZE DATA-!
  494.         0 AD-SIZE DATA-! 0 RTYPE DATA-! 0 MAXTYPE DATA-! 0 MOD-R/M DATA-!
  495.         0 S-I-B DATA-! 0 ADDMODE DATA-! ;
  496.  
  497. ( SET/RESET MODE BITS )
  498.   1 CONSTANT IMMED-BIT           ( FLAG AN IMMEDIATE OPERAND )
  499.   2 CONSTANT DIRECT-BIT          ( FLAG THE DIRECTION )
  500.   4 CONSTANT MOD-R/M-BIT         ( FLAG THAT WE'VE STARTED THE MOD-R/M )
  501.  8 CONSTANT S-I-B-BIT           ( FLAG THE BEGINNING OF S-I-B CREATION )
  502. 10 CONSTANT FULL-OFF-BIT        ( FLAG A FULL OFFSET )
  503. 20 CONSTANT BASED-BIT           ( FLAG THAT WE'VE SEEN A BASE )
  504.  40 CONSTANT OFFSET-BIT          ( FLAG AN OFFSET )
  505.  80 CONSTANT SHORT-BIT           ( FLAG SHORT )
  506. 100 CONSTANT NEAR-BIT            ( FLAG NEAR )
  507. 200 CONSTANT FAR-BIT             ( FLAG FAR )
  508. 400 CONSTANT DO-1OP-BIT          ( FLAG WE'VE BEEN THROUGH DO-1OP ONCE )
  509. 800 CONSTANT MAYBE-OFFSET-BIT    ( FLAG THAT MAYBE WE'VE GOT AN OFFSET )
  510. IMMED-BIT
  511. DIRECT-BIT OR
  512. MOD-R/M-BIT OR
  513. S-I-B-BIT OR
  514. FULL-OFF-BIT OR
  515. BASED-BIT OR
  516. OFFSET-BIT OR
  517. SHORT-BIT OR
  518. NEAR-BIT OR
  519. FAR-BIT OR
  520. DO-1OP-BIT OR
  521. MAYBE-OFFSET-BIT OR
  522. CONSTANT MODE-MASK      ( ALL MODE BITS SET )
  523.  
  524. : 1MODE-BIT! ( SET A MODE BIT )
  525.         ( BIT CONSTANT -- )
  526.         ADDMODE SWAP OVER DATA-@ OR SWAP DATA-! ;
  527. : 0MODE-BIT! ( CLEAR A MODE BIT )
  528.         ( BIT CONSTANT -- )
  529.         MODE-MASK XOR ADDMODE SWAP OVER DATA-@ AND SWAP DATA-! ;
  530. : MODE-BIT@ ( FETCH A MODE BIT )
  531.         ( BIT MASK -- FLAG )
  532.         ADDMODE DATA-@ AND 0<> ;
  533. : HAS-IMMED ( FLAG AN IMMEDIATE OPERAND )
  534.         ( -- )
  535.         IMMED-BIT 1MODE-BIT! ;
  536. : HAS-IMMED? ( DO WE HAVE AN IMMEDIATE OPERAND? )
  537.         ( -- FLAG )
  538.         IMMED-BIT MODE-BIT@ ;
  539. : HAS-MOD-R/M ( WE'VE SEEN AT LEAST ONE OPERAND )
  540.        ( -- )
  541.        MOD-R/M-BIT 1MODE-BIT! ;
  542. : HAS-MOD-R/M? ( HAVE WE SEEN AN OPERAND? )
  543.        ( -- FLAG )
  544.        MOD-R/M-BIT MODE-BIT@ ;
  545. : HAS-S-I-B ( WE'VE STARTED WORK ON THE S-I-B )
  546.         ( -- )
  547.         S-I-B-BIT 1MODE-BIT! ;
  548. : HAS-S-I-B? ( HAVE WE STARTED WORK ON THE S-I-B )
  549.         ( -- FLAG )
  550.         S-I-B-BIT MODE-BIT@ ;
  551. : REG,R/M ( ADDRESSING MODE IS REGISTER, REGISTER/MEMORY )
  552.         ( -- )
  553.         DIRECT-BIT 1MODE-BIT! ;
  554. : R/M,REG ( ADDRESSING MODE IS REGISTER/MEMORY, REGISTER )
  555.         ( -- )
  556.         DIRECT-BIT 0MODE-BIT! ;
  557. : DIRECTION? ( IS THE DESTINATION A REGISTER? )
  558.         ( -- FLAG )
  559.         DIRECT-BIT MODE-BIT@ ;
  560. : HAS-FULL-OFF ( MUST GENERATE A FULL OFFSET )
  561.         ( -- )
  562.         FULL-OFF-BIT 1MODE-BIT! ;
  563. : HAS-FULL-OFF? ( DO WE NEED A FULL OFFSET? )
  564.         ( -- FLAG )
  565.         FULL-OFF-BIT MODE-BIT@ ;
  566. : HAS-BASE ( WE HAVE A BASE )
  567.         ( -- )
  568.         BASED-BIT 1MODE-BIT! ;
  569. : HAS-BASE? ( DO WE HAVE A BASE? )
  570.         ( -- FLAG )
  571.         BASED-BIT MODE-BIT@ ;
  572. : MAYBE-S-I-B? ( DO WE HAVE A POSSIBLE S-I-B? )
  573.         ( -- FLAG )
  574.         BASED-BIT MODE-BIT@ S-I-B-BIT MODE-BIT@ OR ;
  575. : HAS-OFFSET ( FLAG THAT WE DO HAVE AN OFFSET )
  576.         ( -- )
  577.         OFFSET-BIT 1MODE-BIT! ;
  578. : HAS-OFFSET? ( DO WE HAVE AN OFFSET? )
  579.         ( -- FLAG )
  580.         OFFSET-BIT MODE-BIT@ FULL-OFF-BIT MODE-BIT@ OR ;
  581. : IS-SHORT ( WE HAVE A SHORT DISPLACEMENT )
  582.         ( -- )
  583.         SHORT-BIT 1MODE-BIT! ;
  584. : IS-SHORT? ( IS THE DISPLACEMENT SHORT? )
  585.         ( -- FLAG )
  586.         SHORT-BIT MODE-BIT@ ;
  587. : IS-NEAR ( WE HAVE A NEAR DISPLACEMENT )
  588.         ( -- )
  589.         NEAR-BIT 1MODE-BIT! ;
  590. : IS-NEAR? ( DO WE HAVE A NEAR DISPLACEMENT? )
  591.         ( -- FLAG )
  592.         NEAR-BIT MODE-BIT@ FAR-BIT MODE-BIT@ 0= OR ;
  593. : IS-FAR ( WE HAVE A FAR POINTER )
  594.         ( -- )
  595.         FAR-BIT 1MODE-BIT! ;
  596. : IS-FAR? ( DO WE HAVE A FAR DISPLACEMENT? )
  597.         ( -- FLAG )
  598.         FAR-BIT MODE-BIT@ ;
  599. : DO-1OP-EXED ( WE'VE EXEC'D DO-1OP )
  600.         ( -- )
  601.         DO-1OP-BIT 1MODE-BIT! ;
  602. ( NOTE: WHEN WE START TO ASSEMBLE AN OPCODE, ALL FLAGS ARE OFF )
  603. : DO-1OP-EXED? ( HAVE WE EXEC'D DO-1OP? )
  604.        ( -- FLAG )
  605.        DO-1OP-BIT MODE-BIT@ ;
  606. : MAYBE-HAS-OFFSET ( FLAG THAT WE'VE PICKED SOMETHING UP FROM THE STACK )
  607.         ( -- )
  608.         MAYBE-OFFSET-BIT 1MODE-BIT! ;
  609. : MAYBE-HAS-OFFSET? ( HAVE WE PICKED UP SOMETHING FROM THE STACK? )
  610.         ( -- FLAG )
  611.         MAYBE-OFFSET-BIT MODE-BIT@ ;
  612.  
  613. ( TEST FOR ERROR CONDITIONS )
  614. : _?PARAMS ( ARE THERE PARAMETERS ON THE STACK? )
  615.         SP@ SP-SAVE DATA-@ - DUP ?CLR-OPSTACK
  616.         ABORT" OFFSET OR IMMEDIATE OPERAND NOT ALLOWED WITH THIS INSTRUCTION" ;
  617. ' _?PARAMS IS ?PARAMS
  618.  
  619. : _?SEG ( IS THERE A SEGMENT OVERRIDE? )
  620.        SEG-PREFIX DATA-@ DUP ?CLR-OPSTACK
  621.        ABORT" SEGMENT OVERRIDE NOT ALLOWED WITH THIS INSTRUCTION" ;
  622. ' _?SEG IS ?SEG
  623.  
  624. : _?LOCK ( IS THERE A LOCK PREFIX? )
  625.         INST-PREFIX DATA-@ 0F0 = DUP ?CLR-OPSTACK
  626.         ABORT" LOCK PREFIX NOT ALLOWED WITH THIS INSTRUCTION" ;
  627. ' _?LOCK IS ?LOCK
  628.  
  629. : _?REP ( IS THERE A REPEAT PREFIX? )
  630.        INST-PREFIX DATA-@ 0F3 OVER = 0F2 ROT = OR DUP ?CLR-OPSTACK
  631.        ABORT" REP, ETC. NOT ALLOWED WITH THIS INSTRUCTION" ;
  632. ' _?REP IS ?REP
  633.  
  634. : _?INST-PRE ( IS THERE ANY INSTRUCTION PREFIX? )
  635.         INST-PREFIX DATA-@ DUP ?CLR-OPSTACK
  636.         ABORT" INSTRUCTION PREFIXES NOT ALLOWED WITH THIS INSTRUCTION" ;
  637. ' _?INST-PRE IS ?INST-PRE
  638.  
  639. : _?OPERANDS ( ARE THERE ANY OPERANDS? )
  640.        OP-DEPTH DUP ?CLR-OPSTACK
  641.        ABORT" OPERANDS NOT ALLOWED WITH THIS INSTRUCTION" ;
  642. ' _?OPERANDS IS ?OPERANDS
  643.  
  644. : _?OPSIZE1 ( IS THE OPERAND SIZE MISMATCHED? )
  645.         ( N -- )
  646.         ?DUP IF DT-SIZE DATA-@ ?DUP IF - DUP ?CLR-OPSTACK
  647.         ABORT" OPERAND SIZE MISMATCHED" ELSE DT-SIZE DATA-! THEN THEN ;
  648. : _?OPSIZE2 ( JUST STORE THE OPERAND SIZE )
  649.         ( N -- )
  650.         ?DUP IF DT-SIZE DATA-! THEN ;
  651. ' _?OPSIZE1 IS ?OPSIZE
  652.  
  653. : _?ADSIZE1 ( IS THE ADDRESS SIZE MISMATCHED? )
  654.        ( N -- )
  655.        ?DUP IF AD-SIZE DATA-@ ?DUP IF - DUP ?CLR-OPSTACK
  656.        ABORT" ADDRESS SIZE MISMATCHED" ELSE AD-SIZE DATA-! THEN THEN ;
  657. : _?ADSIZE2 ( JUST STORE THE ADDRESS SIZE )
  658.        ( N -- )
  659.        ?DUP IF AD-SIZE DATA-! THEN ;
  660. ' _?ADSIZE1 IS ?ADSIZE
  661.  
  662. : _?SHORT ( IS THE ADDRESS SHORT? )
  663.         ( -- )
  664.         AD-SIZE DATA-@ 8BIT = DUP ?CLR-OPSTACK
  665.         ABORT" SHORT NOT ALLOWED WITH THIS INSTRUCTION" ;
  666. ' _?SHORT IS ?SHORT
  667.  
  668. : ?NOSHORT ( DO WE HAVE AN ILLEGAL SHORT? )
  669.        ( -- )
  670.        IS-SHORT? IF 8BIT AD-SIZE DATA-! ?SHORT THEN ;
  671.  
  672. : _?TOOFAR ( IS THE BRANCH OFFSET TO FAR? )
  673.        ( FLAG -- )
  674.        DUP ?CLR-OPSTACK
  675.        ABORT" BRANCH OFFSET TOO BIG TO FIT SPECIFIED WIDTH" ;
  676. ' _?TOOFAR IS ?TOOFAR
  677.  
  678. : _?UNRES ( ARE THERE ANY UNRESOLVED FORWARD REFERENCE LABELS? )
  679.         ( -- )
  680.         FRTABLE FRMAX 0 DO DUP DATA-@ DUP ?CLR-OPSTACK
  681.         ABORT" UNRESOLVED FORWARD REFERENCE" CELL+ CELL+ LOOP DROP ;
  682. ' _?UNRES IS ?UNRES
  683.  
  684. : _?NOADSIZE ( NO OR UNKNOWN ADDRESS SIZE )
  685.        ( -- )
  686.        CLR-OPSTACK -1
  687.        ABORT" NO OR UNKNOWN ADDRESS SIZE" ;
  688. ' _?NOADSIZE IS ?NOADSIZE
  689.  
  690. : _?TOOMANYOPS ( ARE THERE TOO MANY OPERANDS? )
  691.         ( MAX ALLOWED OPERANDS -- )
  692.         OP-DEPTH < DUP ?CLR-OPSTACK
  693.         ABORT" TOO MANY OPERANDS" ;
  694. ' _?TOOMANYOPS IS ?TOOMANYOPS
  695.  
  696. : _?NOFAR ( IS THERE AN UNALLOWED FAR REFERENCE? )
  697.        ( -- )
  698.        AD-SIZE DATA-@ 32BIT = DUP ?CLR-OPSTACK
  699.        ABORT" FAR REFERENCES NOT ALLOWED WITH THIS INSTRUCTION" ;
  700. ' _?NOFAR IS ?NOFAR
  701.  
  702. : <_?MATCH> ( THE ERROR ACTION FOR ?MATCH AND ?NOMATCH )
  703.         ( FLAG -- )
  704.         DUP ?CLR-OPSTACK
  705.         ABORT" OPERAND MISMATCH" ;
  706.  
  707. : _?MATCH ( ERROR IF THE PARAMETERS MATCH )
  708.         ( X1 \ X2 -- )
  709.         = <_?MATCH> ;
  710. ' _?MATCH IS ?MATCH
  711.  
  712. : _?NOMATCH ( ERROR IF THE PARAMETERS DON'T MATCH )
  713.         ( X1 \ X2 -- )
  714.         - <_?MATCH> ;
  715. ' _?NOMATCH IS ?NOMATCH
  716.  
  717. : _?FINISHED ( ARE THERE OPERANDS LEFT? )
  718.        ( -- )
  719.        OP-DEPTH DUP ?CLR-OPSTACK
  720.        ABORT" UNCONSUMED OPERANDS" ;
  721. ' _?FINISHED IS ?FINISHED
  722.  
  723. : _?BADTYPE ( IS THE OPERAND TYPE ALLOWED? )
  724.         ( MAX TYPE ALLOWED -- )
  725.         MAXTYPE DATA-@ < DUP ?CLR-OPSTACK
  726.         ABORT" ADDRESSING MODE NOT ALLOWED" ;
  727. ' _?BADTYPE IS ?BADTYPE
  728.  
  729. : _?BADCOMBINE ( CAN THE OPERAND TYPES BE COMBINED? )
  730.        ( FLAG -- )
  731.        DUP ?CLR-OPSTACK
  732.        ABORT" ILLEGAL OPERAND COMBINATION" ;
  733. ' _?BADCOMBINE IS ?BADCOMBINE
  734.  
  735. : _?NOTENOUGH ( ARE THERE NOT ENOUGH OPERANDS? )
  736.         ( N -- )
  737.         OP-DEPTH > DUP ?CLR-OPSTACK
  738.         ABORT" NOT ENOUGH OPERANDS" ;
  739. ' _?NOTENOUGH IS ?NOTENOUGH
  740.  
  741. : _?NOIMMED ( IS THERE AN ILLEGAL IMMEDIATE OPERAND? )
  742.        ( -- ) HAS-IMMED? DUP ?CLR-OPSTACK
  743.        ABORT" IMMEDIATE OPERANDS NOT ALLOWED WITH THIS INSTRUCTION" ;
  744. ' _?NOIMMED IS ?NOIMMED
  745.  
  746. : _?BADMODE ( IS THE ADDRESS MODE ILLEGAL? )
  747.         ( FLAG -- )
  748.         DUP ?CLR-OPSTACK
  749.         ABORT" ILLEGAL ADDRESS MODE" ;
  750. ' _?BADMODE IS ?BADMODE
  751.  
  752. : _?REG,R/M ( IS THE DESTINATION A REGISTER? )
  753.        ( -- )
  754.        DIRECTION? 0= MOD-R/M DATA-@ 0C0 < AND DUP ?CLR-OPSTACK
  755.        ABORT" DESTINATION MUST BE A REGISTER" ;
  756. ' _?REG,R/M IS ?REG,R/M
  757.  
  758. : _?R/M,REG ( IS THE SOURCE A REGISTER? )
  759.         ( -- )
  760.         DIRECTION? MOD-R/M DATA-@ 0C0 < AND DUP ?CLR-OPSTACK
  761.         ABORT" SOURCE MUST BE A REGISTER" ;
  762. ' _?R/M,REG IS ?R/M,REG
  763.  
  764. : _?MEM ( IS ONE OF THE OPERANDS IN MEMORY? )
  765.        ( -- )
  766.        MOD-R/M DATA-@ 0BF > MAYBE-HAS-OFFSET? 0= AND DUP ?CLR-OPSTACK
  767.        ABORT" INSTRUCTION REQUIRES A MEMORY OPERAND" ;
  768. ' _?MEM IS ?MEM
  769.  
  770. : _?REG ( ARE ALL OF THE OPERANDS REGISTER? )
  771.         ( -- )
  772.         MOD-R/M DATA-@ 0C0 < HAS-OFFSET? OR DUP ?CLR-OPSTACK
  773.         ABORT" THIS INSTRUCTION MAY ONLY USE REGISTERS" ;
  774. ' _?REG IS ?REG
  775.  
  776. : ?MEM,REG ( IS THE INSTRUCTION CODED AS MEMORY,REGISTER? )
  777.        ( -- )
  778.        ?R/M,REG ?MEM ;
  779.  
  780. : ?REG,MEM ( IS THE INSTRUCTION CODED AS REGISTER,MEMORY? )
  781.        ( -- )
  782.        ?REG,R/M ?MEM ;
  783.  
  784. : ?REGEXCLUS ( IS THE ADDRESSING MODE EXCLUSIVE? )
  785.        ( -- )
  786.        RTYPE DATA-@ 0 ?NOMATCH ;
  787.  
  788. IN-ASM
  789. : REPORT-ERRORS ( TURN ON ERROR REPORTING )
  790.        [']     _?PARAMS IS     ?PARAMS
  791.         [']        _?SEG IS        ?SEG
  792.        [']       _?LOCK IS       ?LOCK
  793.         [']        _?REP IS        ?REP
  794.        [']   _?INST-PRE IS   ?INST-PRE
  795.         [']   _?OPERANDS IS   ?OPERANDS
  796.        [']    _?OPSIZE1 IS     ?OPSIZE
  797.         [']    _?ADSIZE1 IS     ?ADSIZE
  798.        [']      _?SHORT IS      ?SHORT
  799.         [']     _?TOOFAR IS     ?TOOFAR
  800.        [']      _?UNRES IS      ?UNRES
  801.         [']   _?NOADSIZE IS   ?NOADSIZE
  802.        ['] _?TOOMANYOPS IS ?TOOMANYOPS
  803.         [']      _?NOFAR IS      ?NOFAR
  804.        [']      _?MATCH IS      ?MATCH
  805.         [']    _?NOMATCH IS    ?NOMATCH
  806.        [']   _?FINISHED IS   ?FINISHED
  807.         [']    _?BADTYPE IS    ?BADTYPE
  808.        ['] _?BADCOMBINE IS ?BADCOMBINE
  809.         [']  _?NOTENOUGH IS  ?NOTENOUGH
  810.        [']    _?NOIMMED IS    ?NOIMMED
  811.         [']    _?BADMODE IS    ?BADMODE
  812.        [']    _?REG,R/M IS    ?REG,R/M
  813.         [']    _?R/M,REG IS    ?R/M,REG
  814.        [']        _?MEM IS        ?MEM
  815.         [']        _?REG IS        ?REG ;
  816.  
  817. : NO-ERRORS ( TURN OFF ERROR REPORTING )
  818.        [']      NOOP IS     ?PARAMS
  819.         [']      NOOP IS        ?SEG
  820.        [']      NOOP IS       ?LOCK
  821.         [']      NOOP IS        ?REP
  822.        [']      NOOP IS   ?INST-PRE
  823.         [']      NOOP IS   ?OPERANDS
  824.        ['] _?OPSIZE2 IS     ?OPSIZE
  825.         ['] _?ADSIZE2 IS     ?ADSIZE
  826.        [']      NOOP IS      ?SHORT
  827.         [']      DROP IS     ?TOOFAR
  828.        [']      NOOP IS      ?UNRES
  829.         [']      NOOP IS   ?NOADSIZE
  830.        [']      DROP IS ?TOOMANYOPS
  831.         [']      NOOP IS      ?NOFAR
  832.        [']     2DROP IS      ?MATCH
  833.         [']     2DROP IS    ?NOMATCH
  834.        [']      NOOP IS   ?FINISHED
  835.         [']      DROP IS    ?BADTYPE
  836.        [']      DROP IS ?BADCOMBINE
  837.         [']      DROP IS  ?NOTENOUGH
  838.        [']      NOOP IS    ?NOIMMED
  839.         [']      DROP IS    ?BADMODE
  840.        [']      NOOP IS    ?REG,R/M
  841.         [']      NOOP IS    ?R/M,REG
  842.        [']      NOOP IS        ?MEM
  843.         [']      NOOP IS        ?REG ;
  844.  
  845. ( GENERATE PREFIX SEQUENCES )
  846. IN-HIDDEN
  847. : INST, ( GENERATE A NECESSARY INSTRUCTION PREFIX )
  848.        ( -- )
  849.        INST-PREFIX DATA-@ ?DUP IF CODE-C, 0 INST-PREFIX DATA-! THEN ;
  850. : ADDR, ( GENERATE A NECESSARY ADDRESS SIZE PREFIX )
  851.        ( -- )
  852.        ADDR-PREFIX DATA-@   IF 67 CODE-C, 0 ADDR-PREFIX DATA-! THEN ;
  853. : DATA, ( GENERATE A NECESSARY DATA SIZE PREFIX )
  854.        ( -- )
  855.        DATA-PREFIX DATA-@   IF 66 CODE-C, 0 DATA-PREFIX DATA-! THEN ;
  856. : SEG, ( GENERATE A NECESSARY SEGMENT OVERRIDE PREFIX )
  857.        ( -- )
  858.        SEG-PREFIX DATA-@ ?DUP IF CODE-C, 0  SEG-PREFIX DATA-! THEN ;
  859.  
  860. : GENERATE-PREFIXES ( GENERATE NECESSARY PREFIXES )
  861.        ( -- )
  862.        INST, ADDR, DATA, SEG, ;
  863.  
  864. ( THE PREFIXES )
  865. : SEG-PRE CREATE DATA-, DOES> DATA-@ SEG-PREFIX DATA-! ;
  866. : INST-PRE CREATE DATA-, DOES> DATA-@ INST-PREFIX DATA-! ;
  867. IN-ASM
  868. 2E  SEG-PRE   CS:
  869. 36  SEG-PRE   SS:
  870. 3E  SEG-PRE   DS:
  871. 26  SEG-PRE   ES:
  872. 64  SEG-PRE   FS:
  873. 65  SEG-PRE   GS:
  874. 0F3 INST-PRE   REP
  875. 0F3 INST-PRE  REPE
  876. 0F3 INST-PRE  REPZ
  877. 0F2 INST-PRE REPNE
  878. 0F2 INST-PRE REPNZ
  879. 0F0 INST-PRE  LOCK
  880.  
  881. ( SAVE THE P-STACK DEPTH )
  882. IN-HIDDEN
  883. : SAVE-DEPTH ( -- )
  884.        SP@ SP-SAVE DATA-! ;
  885. : DEPTH-CHANGE ( REPORT ON A CHANGE OF DEPTH )
  886.        SP@ SP-SAVE DATA-@ SWAP - CELL/ ;
  887.  
  888. ( CREATE AN ASSEMBLY MNEMONIC )
  889. : COMPILE-OPCODE ( COMPILE THE BYTES IN AN OPCODE )
  890.        ( 0 -- | A -- | X \ A -- | X \ X' \ A -- )
  891.         ( OS: X ... -- )
  892.         ( A IS THE ADDRESS OF A TWO CELL DATA STRUCTURE: )
  893.         ( OFFSET 0 -- XT OF THE ACTUAL ROUTINE TO COMPILE THE CODE )
  894.         ( OFFSET 1 -- PARAMETER USED TO GENERATE THE CODE )
  895.         ?DUP IF
  896.                 DUP CELL+ DATA-@ SWAP DATA-@ REGISTER-ASM EXECUTE
  897.         THEN ;
  898.  
  899. DEFER SAVE-INST ( SAVE THE CURRENT INSTRUCTION -- USED IN POSTFIX MODE )
  900. : _SAVE-INST ( SAVE THE CURRENT INSTRUCTION, AND FETCH THE PREVIOUS ONE )
  901.         ( ALSO SWAPS INSTRUCTION PREFIXES )
  902.         ( A -- A' )
  903.        INST-SAVE DUP DATA-@ >R DATA-! R> INST-PREFIX SV-INST-PREFIX
  904.        2DUP DATA-@ SWAP DATA-@ ROT DATA-! SWAP DATA-! ;
  905. ' _SAVE-INST IS SAVE-INST
  906.  
  907. IN-ASM
  908. : POSTFIX ['] _SAVE-INST IS SAVE-INST ;
  909. : PREFIX ['] NOOP IS SAVE-INST ;
  910.  
  911. IN-HIDDEN
  912. : _DO-OPCODE ( CREATE THE ACTUAL OPCODE, OR AT LEAST CALL THE FUNCTIONS )
  913.         ( THAT DO ... )
  914.         ( X? \ X? \ 0|ADDR -- )
  915.         SAVE-INST COMPILE-OPCODE RESET-FOR-NEXT-INSTR SAVE-DEPTH ;
  916. ' _DO-OPCODE IS DO-OPCODE
  917.  
  918. : OPCODE ( C:: PARAMETER \ XT -- )
  919.        ( R:: -- | X -- | X \ X' -- )
  920.         ( R::OS: X ... -- )
  921.         CREATE DATA-, DATA-, DOES> DO-OPCODE ;
  922.  
  923. ( SUPPORT ROUTINES FOR CREATING ASSEMBLY CODE )
  924. : ALL-EXCEPT ( PROCESS ALL OPERANDS EXCEPT ONE IN PARTICULAR )
  925.         ( X \ N -- TYPE \ MOD-R/M {X!=N} | -- 0 \ 0 )
  926.         OVER = IF DROP 0 0 ELSE <DEC-REG> >R >R ?ADSIZE ?OPSIZE R> R> THEN ;
  927.  
  928. : OFFSET8, ( CREATE AN 8 BIT CODE-HERE RELATIVE OFFSET )
  929.         ( ADDR -- )
  930.         8B-REL REGISTER-REF CODE-HERE 1+ - DUP ABS 7F > ?TOOFAR CODE-C, ;
  931. : OFFSET16, ( CREATE A 16 BIT CODE-HERE RELATIVE OFFSET )
  932.         ( ADDR -- )
  933.         16B-REL REGISTER-REF CODE-HERE 2+ - DUP ABS 7FFF > ?TOOFAR CODE-W, ;
  934. : OFFSET32, ( CREATE A 32 BIT CODE-HERE RELATIVE OFFSET )
  935.         ( ADDR -- )
  936.         32B-REL REGISTER-REF CODE-HERE 4+ - CODE-D, ;
  937. : OFFSET16/32, ( CREATE A 16 OR 32 BIT CODE-HERE RELATIVE OFFSET )
  938.         ( ADDR \ 16BIT? -- )
  939.         IF OFFSET16, ELSE OFFSET32, THEN ;
  940.  
  941. : FLAG-FOR-SIZE-PREFIX ( DO WE NEED A SIZE PREFIX? )
  942.         ( SIZE -- FLAG )
  943.         DUP IF DUP 8BIT - IF DEFAULT-SIZE - ELSE DROP 0 THEN THEN ;
  944. : CHECK-AD-SIZE ( CHECK THE ADDRESS SIZE )
  945.         ( -- )
  946.         AD-SIZE DATA-@ FLAG-FOR-SIZE-PREFIX ADDR-PREFIX DATA-! ;
  947. : CHECK-DT-SIZE ( CHECK THE OPERAND SIZE )
  948.         ( -- )
  949.         DT-SIZE DATA-@ FLAG-FOR-SIZE-PREFIX DATA-PREFIX DATA-! ;
  950. : CHECK-SIZES ( CHECK THE ADDRESS AND OPERAND SIZES )
  951.         ( -- )
  952.         CHECK-AD-SIZE CHECK-DT-SIZE ;
  953. : RTYPE! ( STORE THE ADDRESSING MODE TYPE AND UPDATE MAXTYPE )
  954.         ( TYPE -- )
  955.         DUP RTYPE DATA-! MAXTYPE DATA-@ OVER < IF MAXTYPE DATA-! ELSE
  956.         DROP THEN ;
  957. : SPECIAL-PROCESS? ( DO WE NEED TO SPECIALLY PROCESS THIS REGISTER? )
  958.         ( -- FLAG )
  959.         MAXTYPE DATA-@ DUP REGISTER > SWAP FREG < AND ;
  960. : SPECIAL-REGISTER? ( IS THIS A SPECIAL REGISTER? )
  961.         ( -- FLAG )
  962.         RTYPE DATA-@ DUP REGISTER > SWAP FREG < AND ;
  963. : DO-REG ( DO ANY REGISTER ADDRESSING MODE TRANSLATION )
  964.         ( REG \ TYPE -- )
  965.         ?REGEXCLUS RTYPE! DO-1OP-EXED? IF
  966.                 HAS-MOD-R/M? IF
  967.                         MOD-R/M DATA-@ SWAP SPECIAL-PROCESS? IF
  968.                                 SPECIAL-REGISTER? IF
  969.                                         8*+ REG,R/M
  970.                                 ELSE
  971.                                         MAXTYPE DATA-@ SREG = IF
  972.                                                 C0+ SWAP C0-8* +
  973.                                         ELSE
  974.                                                 C0+ +
  975.                                         THEN R/M,REG
  976.                                 THEN
  977.                         ELSE
  978.                                 8*+ REG,R/M
  979.                         THEN
  980.                 ELSE    ( *MUST* BE REG,DISP OR REG,IMMED )
  981.                         C0+ REG,R/M HAS-MOD-R/M HAS-IMMED? 0= IF
  982.                                 HAS-OFFSET
  983.                         THEN
  984.                 THEN
  985.         ELSE    ( FIRST TIME THROUGH DO-1OP )
  986.                 SPECIAL-REGISTER? RTYPE DATA-@ SREG <> AND IF
  987.                         8*
  988.                 ELSE    ( EITHER A GENERAL OR SEGMENT REGISTER )
  989.                         C0+
  990.                 THEN HAS-MOD-R/M R/M,REG
  991.         THEN MOD-R/M DATA-! ;
  992. : DO-IMMED ( DO AN IMMEDIATE ADDRESSING MODE OPERAND )
  993.         ( X \ 0 -- )
  994.         DROP IMMED-SV DATA-! HAS-IMMED IMMEDIATE RTYPE! ;
  995. : DO-INDIRE ( DO AN INDIRECT ADDRESSING MODE OPERAND )
  996.         ( REG -- )
  997.         HAS-MOD-R/M? IF
  998.                 MOD-R/M DATA-@ DUP 0BF > IF
  999.                         C0-8* +
  1000.                 ELSE
  1001.                         +
  1002.                 THEN
  1003.         ELSE
  1004.                 HAS-MOD-R/M
  1005.         THEN MOD-R/M DATA-! HAS-BASE ;
  1006. : DO-INDEX ( DO A SCALED INDEX ADDRESSING MODE )
  1007.         ( REG -- )
  1008.         HAS-S-I-B 8* S-I-B DATA-@ 8/ + S-I-B DATA-! HAS-MOD-R/M? IF
  1009.                 MOD-R/M DATA-@ DUP 0BF > IF
  1010.                         C0-8* 4+
  1011.                 ELSE
  1012.                         [ 7 -1 XOR ] LITERAL AND 4+
  1013.                 THEN
  1014.         ELSE
  1015.                 4 HAS-MOD-R/M
  1016.         THEN MOD-R/M DATA-! ;
  1017. : DO-BASED ( DO A BASE REGISTER ADDRESSING MODE )
  1018.         ( REG -- )
  1019.         HAS-MOD-R/M? IF
  1020.                 MOD-R/M DATA-@ DUP 0BF > IF
  1021.                         C0-8* OVER 8* S-I-B DATA-! +
  1022.                 ELSE
  1023.                         MAYBE-S-I-B? IF
  1024.                                 HAS-S-I-B S-I-B ROT OVER DATA-@ + SWAP
  1025.                                 DATA-! [ 7 -1 XOR ] LITERAL AND 4+
  1026.                         ELSE
  1027.                                 OVER 8* S-I-B DATA-! +
  1028.                         THEN
  1029.                 THEN
  1030.         ELSE
  1031.                 DUP 8*  S-I-B DATA-! HAS-MOD-R/M
  1032.         THEN MOD-R/M DATA-! HAS-BASE ;
  1033.  
  1034. : OPERAND-CASES ( PROCESS AN OPERAND BASED ON ITS TYPE )
  1035.         ( REG \ TYPE -- | X \ REG \ TYPE -- )
  1036.         CASE UNKNOWN OF
  1037.                 DROP
  1038.         ENDOF IMMEDIATE OF
  1039.                 DO-IMMED
  1040.         ENDOF INDIRECT OF
  1041.                 ?REGEXCLUS INDIRECT RTYPE! DO-INDIRE
  1042.         ENDOF INDEX OF
  1043.                 RTYPE DATA-@ ?DUP IF BASED ?NOMATCH THEN INDEX RTYPE! DO-INDEX
  1044.         ENDOF BASED OF
  1045.                 RTYPE DATA-@ ?DUP IF BASED OVER = INDEX ROT = OR 0= ?BADCOMBINE
  1046.                 THEN BASED RTYPE! DO-BASED
  1047.         ENDOF ( MUST BE A REGISTER TYPE ) DO-REG DUP ( SO ENDCASE HAS )
  1048.         ( SOMETHING TO DISCARD ) ENDCASE ;
  1049. : SAVE-OFFSET ( SAVE THE OFFSET, IF IT'S PRESENT )
  1050.        ( X -- | -- )
  1051.        DEPTH-CHANGE IF MAYBE-HAS-OFFSET ?DUP IF OFFSET-SV DATA-! HAS-OFFSET
  1052.        THEN THEN ;
  1053. : DO-1OP ( PROCESS A SINGLE OPERAND )
  1054.        ( -- | X -- | X \ X' -- )
  1055.         0 RTYPE DATA-! BEGIN OP-DEPTH IF POP-OP ELSE FALSE THEN ?DUP WHILE
  1056.         0 ALL-EXCEPT SWAP OPERAND-CASES REPEAT SAVE-OFFSET DO-1OP-EXED ;
  1057. : LIT-OP ( INSTERT THE LITERAL VALUE OF AN OPERAND INTO CODE )
  1058.         ( C:: -- )
  1059.         ( R:: -- X )
  1060.         ' >BODY DATA-@ POSTPONE LITERAL ; ALSO FORTH IMMEDIATE IN-HIDDEN
  1061. : PARSE-CALL/JMP-OPERANDS ( PARSE THE OPERANDS FOR CALLS AND JUMPS )
  1062.        ( -- | X -- )
  1063.        0 RTYPE DATA-! BEGIN OP-DEPTH WHILE POP-OP DUP LIT-OP SHORT = OVER
  1064.        LIT-OP NEAR = OR OVER LIT-OP FAR = OR IF CASE LIT-OP SHORT OF
  1065.        IS-SHORT ENDOF LIT-OP NEAR OF IS-NEAR ENDOF IS-FAR ENDCASE ELSE
  1066.        0 ALL-EXCEPT SWAP OPERAND-CASES THEN REPEAT ?NOIMMED SAVE-OFFSET ;
  1067. : DO-2OPS ( DO TWO OPERANDS AND SET SIZE PREFIXES )
  1068.        ( -- | X -- | X \ X -- )
  1069.        DO-1OP DO-1OP CHECK-SIZES ;
  1070. : INSTALL-/R ( INSTALL THE /R FIELD IN A MOD-R/M BYTE )
  1071.        ( /R VALUE -- )
  1072.        8* MOD-R/M DATA-@ [ 7 8* -1 XOR ] LITERAL AND OR MOD-R/M DATA-! ;
  1073.  
  1074. : DISP, ( COMPILE THE DISPLACEMENT )
  1075.        ( -- )
  1076.        HAS-OFFSET? IF OFFSET-SV DATA-@ DUP ABS 7F > HAS-FULL-OFF? OR
  1077.        IF AD-SIZE DATA-@ 16BIT = IF 16B-ABS REGISTER-REF CODE-W, ELSE 32B-ABS
  1078.        REGISTER-REF CODE-D, THEN ELSE 8B-ABS REGISTER-REF CODE-C, THEN THEN ;
  1079.  
  1080. : DEFAULT-8BIT ( CHANGE A ZERO SIZE TO 8BIT )
  1081.        ( SIZE -- SIZE' )
  1082.         ?DUP 0= IF 8BIT THEN ;
  1083. : >DEFAULT-SIZE ( CHANGE A ZERO SIZE TO THE DEFAULT SIZE )
  1084.         ( SIZE -- SIZE' )
  1085.        ?DUP 0= IF DEFAULT-SIZE THEN ;
  1086. : GET-DT-SIZE ( GET THE CURRENT DATA SIZE, DEFAULT IS 8 BIT )
  1087.        ( -- DATA SIZE )
  1088.        DT-SIZE DATA-@ DEFAULT-8BIT ;
  1089. : GET-AD-SIZE ( GET THE CURRENT ADDRESS SIZE, DEFAULT IS DEFAULT-SIZE )
  1090.        ( -- ADDRESS SIZE )
  1091.        AD-SIZE DATA-@ >DEFAULT-SIZE ;
  1092. : GET-FP-SIZE ( GET THE SIZE OF FP OPERAND, DEFAULT IS DEFAULT-SIZE )
  1093.        DT-SIZE DATA-@ >DEFAULT-SIZE ;
  1094.  
  1095. : IMMED, ( COMPILE THE IMMEDIATE OPERAND )
  1096.        ( -- )
  1097.        HAS-IMMED? IF
  1098.            IMMED-SV DATA-@ GET-DT-SIZE CASE
  1099.                8BIT  OF  8B-ABS REGISTER-REF CODE-C, ENDOF
  1100.                16BIT OF 16B-ABS REGISTER-REF CODE-W, ENDOF
  1101.                32BIT OF 32B-ABS REGISTER-REF CODE-D, ENDOF
  1102.                ?NOADSIZE DROP
  1103.            ENDCASE
  1104.        THEN ;
  1105.  
  1106. : 8BIT? ( IS THE OPERATION 8 BITS WIDE? )
  1107.        ( -- FLAG )
  1108.        GET-DT-SIZE 8BIT = ;
  1109. : A16BIT? ( IS THE ADDRESS SIZE 16 BITS? )
  1110.        ( -- FLAG )
  1111.        GET-AD-SIZE 16BIT = ;
  1112. : A32BIT? ( IS THE ADDRESS SIZE 32 BITS? )
  1113.        ( -- FLAG )
  1114.        GET-AD-SIZE 32BIT = ;
  1115.  
  1116. : S-I-B, ( COMPILE THE S-I-B BYTE )
  1117.        ( -- )
  1118.        HAS-S-I-B? A32BIT? AND IF S-I-B DATA-@ CODE-C, THEN ;
  1119.  
  1120. : +SIZE-BIT ( ADJUST AN OPCODE FOR THE SIZE OF THE OPERATION )
  1121.        ( OP-CODE -- OP-CODE' )
  1122.         8BIT? 0= IF 1+ THEN ;
  1123. : +DIRECT-BIT ( ADJUST AN OPCODE FOR THE DIRECTION OF THE OPERANDS )
  1124.         ( OP-CODE -- OP-CODE' )
  1125.        DIRECTION? IF 2+ THEN ;
  1126.  
  1127. : MATCH-R/M? ( DOES THE VALUE MATCH THE R/M FIELD OF THE MOD-R/M? )
  1128.        ( VALUE -- FLAG )
  1129.        MOD-R/M DATA-@ 7 AND = ;
  1130. : PURE-REG? ( IS THE MOD FIELD OF THE MOD-R/M = 3? )
  1131.        ( -- FLAG )
  1132.        MOD-R/M DATA-@ 0BF > ;
  1133. : DISPLACEMENT? ( DOES THE ADDRESS MODE HAVE A PURE DISPLACEMENT? )
  1134.        ( -- FLAG )
  1135.        HAS-MOD-R/M? IF PURE-REG? MAYBE-HAS-OFFSET? AND ELSE TRUE THEN ;
  1136. : [(E)BP]? ( DOES THE ADDRESS MODE HAVE EITHER [BP] OR [EBP] ALONE? )
  1137.        ( -- FLAG )
  1138.        A16BIT? 6 MATCH-R/M? AND A32BIT? 5 MATCH-R/M? AND OR MOD-R/M
  1139.        DATA-@ 40 < AND ;
  1140. : [REG*N]? ( DOES IT HAVE ONLY AN INDEX REGISTER? )
  1141.        ( -- FLAG )
  1142.        HAS-S-I-B? HAS-BASE? 0= AND ;
  1143. : [ESP][REG]? ( DOES IT HAVE ESP AS AN INDEX REGISTER? )
  1144.        ( -- FLAG )
  1145.        S-I-B DATA-@ 8/ 4 = ;
  1146. : [ESP]? ( DOES IT HAVE ONLY A BASE OF ESP? )
  1147.        ( -- FLAG )
  1148.        A32BIT? HAS-BASE? HAS-S-I-B? 0= 4 MATCH-R/M? AND AND AND ;
  1149.  
  1150. : DO-[(E)BP] ( DO A NAKED [BP] OR [EBP] )
  1151.        ( -- )
  1152.        [(E)BP]? IF HAS-OFFSET THEN ;
  1153. : DO-DISP ( PROCESS A DISPLACEMENT )
  1154.        ( -- )
  1155.        MOD-R/M DATA-@ DUP 0BF > IF C0-8* THEN 5 + A16BIT? IF 1+ THEN
  1156.        CODE-C, HAS-FULL-OFF ;
  1157. : DO-[REG*N] ( PROCESS A NAKED INDEX )
  1158.        ( -- )
  1159.        [REG*N]? IF HAS-FULL-OFF 5 S-I-B DATA-+! -80 MOD-R/M DATA-+! THEN ;
  1160. : DO-[ESP][REG] ( SWAP INDEX AND BASE REGISTERS IN S-I-B )
  1161.        ( -- )
  1162.        [ESP][REG]? IF S-I-B DATA-@ 7 AND 8* 4+ S-I-B DATA-! THEN ;
  1163. : DO-[ESP] ( DO [ESP] ONLY )
  1164.        ( -- )
  1165.        [ESP]? IF 24 S-I-B DATA-! HAS-S-I-B THEN ;
  1166. : MOD-R/M, ( COMPILE THE MOD-R/M FIELD )
  1167.        ( -- )
  1168.        DISPLACEMENT? IF DO-DISP ELSE DO-[(E)BP] DO-[ESP][REG] DO-[REG*N]
  1169.        DO-[ESP] MOD-R/M DATA-@ HAS-OFFSET? IF OFFSET-SV DATA-@ ABS
  1170.        7F > HAS-FULL-OFF? OR IF 80 ELSE 40 THEN + THEN CODE-C, THEN ;
  1171. : COMPILE-FIELDS ( COMPILE THE MOD-R/M, S-I-B, DISPLACEMENT, AND IMMED FIELDS )
  1172.        ( -- )
  1173.        MOD-R/M, S-I-B, DISP, IMMED, ;
  1174. : GENERIC-ENTRY2 ( GENERIC ENTRY SEQUENCE FOR TWO OPERAND INSTRUCTIONS )
  1175.        ( PARAM \ MAX TYPE -- )
  1176.        ( | X \ PARAM \ MAX TYPE -- )
  1177.        ( | X \ X' \ PARAM \ MAX TYPE -- )
  1178.         2>R DO-2OPS ?FINISHED 2R> ?BADTYPE GENERATE-PREFIXES ;
  1179. : +FP-SIZE ( ADD 4 IF THE OPERATION SIZE IS 64BIT: IE., DEFAULT FLOAT )
  1180.         ( N -- N' )
  1181.        DT-SIZE DATA-@ 64BIT = IF 4+ THEN ;
  1182. : /R&FREG>MOD-R/M ( TURN /R AND FP REG INTO THE RQD MOD-R/M )
  1183.        ( /R \ FREG -- MOD-R/M )
  1184.        SWAP 8*+ C0+ ;
  1185. : SWAP-REGS ( SWAP THE ORDER OF REGISTERS IN THE MOD-R/M BYTE )
  1186.        ( -- )
  1187.        MOD-R/M DATA-@ DUP 0BF > IF 3F AND 8 /MOD /R&FREG>MOD-R/M THEN MOD-R/M
  1188.        DATA-! ;
  1189. : PARSE-FP-OPS ( PARSE FLOATING POINT INSTRUCTION OPERANDS )
  1190.        ( -- N | X -- N )
  1191.        DEPTH-CHANGE 0<> OP-DEPTH 0<> OR IF DO-1OP OP-DEPTH IF DO-1OP 2 ELSE
  1192.        1 THEN ELSE 0 THEN ?NOIMMED ?FINISHED CHECK-SIZES ;
  1193. : MOD-R/M>FREG ( CONVERT MOD-R/M BYTE INTO AN FP REGISTER NUMBER )
  1194.        ( -- N )
  1195.        MOD-R/M DATA-@ C0- DUP 7 > IF 8/ THEN ;
  1196. : FP-DIRECTION? ( WHICH DIRECTION IS THE FLOATING POINT DATA GOING? )
  1197.        ( -- FLAG )
  1198.        MOD-R/M DATA-@ 0C7 > ;
  1199. : +FP-DIRECT-BIT ( ADD 4, DEPENDING ON THE DIRECTION OF THE OPERANDS )
  1200.        ( X -- X' )
  1201.         FP-DIRECTION? IF 4+ THEN ;
  1202. : FP-GENERIC-ASSEMBLE ( GENERIC ASSEMBLY OF FLOATING POINT INSTRUCTIONS )
  1203.         ( OPCODE \ /R FIELD -- )
  1204.         INSTALL-/R ADDR, SEG, CODE-C, COMPILE-FIELDS ;
  1205. : SAVE-IMMED ( SAVE IMMEDIATE OPERANDS FOR DOUBLE-SHIFT )
  1206.         ( X \ PARAM -- PARAM )
  1207.         SWAP IMMED-SV DATA-! HAS-IMMED ;
  1208. : NEXT-IS-, ( MAKE SURE THE NEXT OPERAND IS A COMMA )
  1209.         ( -- )
  1210.         POP-OP LIT-OP , - ?BADMODE ;
  1211.  
  1212. ( THE ASSEMBLY ENGINE WORDS -- ACTUALLY DO THE ASSEMBLY )
  1213. ( SIMPLE ASSEMBLY INSTRUCTIONS -- NO-BRAINERS )
  1214. : 1BYTE ( COMPILE A SINGLE BYTE, NO OPERAND, NO OVERRIDE OPCODE )
  1215.         ( PARAM -- )
  1216.         >R ?PARAMS R> ?SEG ?INST-PRE ?OPERANDS CODE-C, ;
  1217. : 2BYTE ( COMPILE A TWO BYTE, NO OPERAND, NO OVERRIDE OPCODE )
  1218.         ( PARAM -- )
  1219.         >R ?PARAMS R> ?SEG ?INST-PRE ?OPERANDS CODE-W, ;
  1220. : 3BYTE ( COMPILE A THREE BYTE, NO OPERAND, NO OVERRIDE OPCODE )
  1221.         ( PARAM -- )
  1222.         >R ?PARAMS R> ?SEG ?INST-PRE ?OPERANDS 10000 /MOD SWAP CODE-W,
  1223.         CODE-C, ;
  1224. : SIZE-COND-COMP ( COMPILE A SIZE CONDITIONAL ASSEMBLY SEQUENCE )
  1225.         ( PARAM -- )
  1226.         >R ?PARAMS R> ?SEG ?INST-PRE ?OPERANDS 100 /MOD DEFAULT-SIZE - IF
  1227.         66 CODE-C, THEN CODE-C, ;
  1228.  
  1229. ( STRING INSTRUCTIONS )
  1230. : STR-ENTRY ( CHECK FOR ENTRY ERROR CONDITIONS )
  1231.         ( PARAM -- PARAM )
  1232.         >R ?PARAMS R> ?LOCK SEG-PREFIX DATA-@ ?DUP IF 3E OVER - 0<>
  1233.         26 ROT - 0<> AND IF ?SEG THEN 0 SEG-PREFIX DATA-! THEN ;
  1234. : STR-OPERANDS ( PROCESS OPERANDS FOR STRING INSTRUCTIONS )
  1235.         ( -- )
  1236.         BEGIN OP-DEPTH WHILE POP-OP LIT-OP DX ALL-EXCEPT 2DROP REPEAT ;
  1237. : STR-INST ( THE ENGINE TO CREATE STRING INSTRUCTIONS )
  1238.         ( PARAM -- )
  1239.         STR-ENTRY STR-OPERANDS ?SHORT CHECK-SIZES
  1240.         DT-SIZE DATA-@ DUP 0= 8BIT ROT = OR 0= IF 1+ THEN
  1241.         GENERATE-PREFIXES CODE-C, ;
  1242. : BYTE-STR-INST ( BYTE STRING INSTRUCTIONS )
  1243.         ( PARAM -- )
  1244.         BYTE STR-INST ;
  1245. : WORD-STR-INST ( WORD STRING INSTRUCTIONS )
  1246.         ( PARAM -- )
  1247.         WORD STR-INST ;
  1248. : DWORD-STR-INST ( DWORD STRING INSTRUCTIONS )
  1249.         ( PARAM -- )
  1250.         DWORD STR-INST ;
  1251.  
  1252. ( CONDITIONAL BRANCH INSTRUCTIONS )
  1253. : JCC-ENTRY ( THE ENTRY SEQUENCE FOR CONDITIONAL BRANCH INSTRUCTIONS )
  1254.         ( -- )
  1255.         ?SEG ?INST-PRE 1 ?TOOMANYOPS OP-DEPTH IF POP-OP 0 ALL-EXCEPT
  1256.         2DROP ?NOFAR AD-SIZE DATA-@ 16BIT = IF DEFAULT-SIZE AD-SIZE DATA-!
  1257.         THEN DT-SIZE DATA-@ ?DUP IF AD-SIZE DATA-! THEN THEN ;
  1258. : JCC-8BIT ( COMPILE AN 8 BIT CONDITIONAL BRANCH )
  1259.         ( ADDR \ PARAM -- )
  1260.         CODE-C, OFFSET8, ;
  1261. : JCC-16/32BIT ( COMPILE A 16 OR 32BIT CONDITIONAL BRANCH )
  1262.         ( ADDR \ PARAM \ SIZE -- )
  1263.         DUP >R FLAG-FOR-SIZE-PREFIX IF 67 ( ADDRESS SIZE PREFIX ) CODE-C,
  1264.         THEN 0F CODE-C, 10 + CODE-C, R> 16BIT = OFFSET16/32, ;
  1265. : JCC-UNKNOWN ( COMPILE A CONDITIONAL BRANCH WITH AN UNKNOWN SIZE )
  1266.         ( ADDR \ PARAM -- )
  1267.         OVER CODE-HERE = IF ( UNRESOLVED FORWARD REFERENCE )
  1268.                 DEFAULT-SIZE JCC-16/32BIT
  1269.         ELSE
  1270.                 OVER CODE-HERE 2+ SWAP - ABS 7F > IF ( CAN'T BE SHORT )
  1271.                        DEFAULT-SIZE JCC-16/32BIT
  1272.                ELSE                              ( IT CAN BE SHORT )
  1273.                        JCC-8BIT
  1274.                THEN
  1275.        THEN ;
  1276. : JCC-COMPILE ( COMPILE A CONDITIONAL BRANCH )
  1277.        ( ADDR \ PARAM -- )
  1278.        JCC-ENTRY AD-SIZE DATA-@ CASE
  1279.                UNKNOWN OF       JCC-UNKNOWN  ENDOF
  1280.                   8BIT OF       JCC-8BIT     ENDOF
  1281.                  16BIT OF 16BIT JCC-16/32BIT ENDOF
  1282.                  32BIT OF 32BIT JCC-16/32BIT ENDOF
  1283.                ?NOADSIZE 2DROP ENDCASE ;
  1284.  
  1285. ( LOOP INSTRUCTIONS )
  1286. : LOOP-ENTRY ( THE ENTRY SEQUENCE FOR LOOP INSTRUCTIONS )
  1287.        ( -- )
  1288.        ?SEG ?INST-PRE 2 ?TOOMANYOPS OP-DEPTH IF POP-OP ?DUP 0= IF POP-OP
  1289.        THEN 0 ALL-EXCEPT OP-DEPTH IF POP-OP DROP THEN 1 ?NOMATCH
  1290.        REGISTER ?NOMATCH DT-SIZE DATA-@ DUP 8BIT ?MATCH ELSE DEFAULT-SIZE
  1291.        THEN AD-SIZE DATA-! ;
  1292. : LOOP-COMPILE ( COMPILE A LOOP INSTRUCTION )
  1293.        ( ADDRESS \ PARAM -- )
  1294.        LOOP-ENTRY AD-SIZE DATA-@ FLAG-FOR-SIZE-PREFIX IF 67 CODE-C, THEN
  1295.        JCC-8BIT ;
  1296.  
  1297. ( JCXZ/JECXZ )
  1298. : JCXZ-COMPILE ( COMPILE JCXZ )
  1299.        ( ADDRESS \ PARAM -- )
  1300.        CX LOOP-COMPILE ;
  1301. : JECXZ-COMPILE ( COMPILE JECXZ )
  1302.        ( ADDRESS \ PARAM -- )
  1303.        ECX LOOP-COMPILE ;
  1304.  
  1305. ( GROUP 1 INSTRUCTIONS -- ADD, ETC. )
  1306. : GROUP1-COMPILE ( COMPILE GROUP 1 INSTRUCTIONS )
  1307.        ( PARAM -- | X \ PARAM -- | X \ X \ PARAM -- )
  1308.        ?REP REGISTER GENERIC-ENTRY2 HAS-IMMED? IF 80 +SIZE-BIT IMMED-SV
  1309.        DATA-@ 80 OVER > -81 ROT < AND GET-DT-SIZE 8BIT <> AND IF 2+ 8BIT
  1310.        DT-SIZE DATA-! THEN SWAP INSTALL-/R ELSE 8* +SIZE-BIT +DIRECT-BIT
  1311.        THEN GENERATE-PREFIXES CODE-C, COMPILE-FIELDS ;
  1312.  
  1313. ( GROUP 2 INSTRUCTIONS -- RCL, ETC. )
  1314. : GROUP2-COMPILE ( COMPILE GROUP 2 INSTRUCTIONS )
  1315.        ( PARAM -- | X \ PARAM -- | X \ X \ PARAM -- )
  1316.        ?INST-PRE 1 ?NOTENOUGH >R POP-OP CASE
  1317.                LIT-OP  , OF 0 SAVE-IMMED DROP           ENDOF
  1318.                LIT-OP  # OF 0 SAVE-IMMED DROP NEXT-IS-, ENDOF
  1319.                LIT-OP CL OF                   NEXT-IS-, ENDOF
  1320.                        DUP PUSH-OP 1 0 SAVE-IMMED DROP
  1321.        ENDCASE DO-1OP CHECK-SIZES REGISTER ?BADTYPE HAS-IMMED? IF 0C0
  1322.        ELSE 0D2 THEN +SIZE-BIT GENERATE-PREFIXES CODE-C, R> INSTALL-/R
  1323.        MOD-R/M, S-I-B, DISP, 8BIT DT-SIZE DATA-! IMMED, ;
  1324.  
  1325. ( GROUP 3 INSTRUCTIONS -- DIV, ETC. )
  1326. : GROUP3-COMPILE ( COMPILE GROUP 3 INSTRUCTIONS )
  1327.        ( PARAM -- | X \ PARAM -- )
  1328.        ?REP >R DO-1OP BEGIN OP-DEPTH WHILE POP-OP 0 ALL-EXCEPT 2DROP REPEAT
  1329.        ?NOIMMED REGISTER ?BADTYPE CHECK-SIZES GENERATE-PREFIXES R> INSTALL-/R
  1330.        0F6 +SIZE-BIT CODE-C, COMPILE-FIELDS ;
  1331. : TEST-COMPILE ( COMPILE THE TEST INSTRUCTION, WHICH IS A SPECIAL GROUP3 INS )
  1332.        ( PARAM -- | X \ PARAM -- | X \ X' \ PARAM -- )
  1333.         ?INST-PRE REGISTER GENERIC-ENTRY2 DROP HAS-IMMED? IF 0F6 0 INSTALL-/R
  1334.         ELSE 84 THEN +SIZE-BIT CODE-C, COMPILE-FIELDS ;
  1335.  
  1336.  
  1337. ( INC AND DEC )
  1338. : INC-DEC-ENTRY  ( PARAM -- | X \ PARAM -- )
  1339.         ?REP >R DO-1OP R>
  1340.         CHECK-SIZES ?FINISHED REGISTER ?BADTYPE
  1341.         GENERATE-PREFIXES
  1342.         MAXTYPE @ REGISTER =
  1343. ;
  1344.  
  1345. : INC-COMPILE ( COMPILE AN INC OR DEC )
  1346.         ( PARAM -- | X \ PARAM -- )
  1347.         INC-DEC-ENTRY
  1348.         IF   MOD-R/M DATA-@ [ 40 C0 - ] LITERAL + CODE-C, DROP EXIT
  1349.         ELSE 0FE +SIZE-BIT CODE-C,
  1350.         THEN
  1351.         INSTALL-/R COMPILE-FIELDS
  1352. ;
  1353.  
  1354. : DEC-COMPILE ( COMPILE AN INC OR DEC )
  1355.         ( PARAM -- | X \ PARAM -- )
  1356.         INC-DEC-ENTRY
  1357.         IF   MOD-R/M DATA-@ [ 48 C0 - ] LITERAL + CODE-C, DROP EXIT
  1358.         ELSE 0FE +SIZE-BIT CODE-C,
  1359.         THEN
  1360.         INSTALL-/R COMPILE-FIELDS
  1361. ;
  1362.  
  1363. ( GROUP 6 AND 7 INSTRUCTIONS -- SLDT, SGDT, ETC. )
  1364. : GROUP6&7-COMPILE ( COMPILE A GROUP 6 OR 7 INSTRUCTION )
  1365.         ( PARAM -- | X \ PARAM -- )
  1366.         ?INST-PRE >R DO-1OP R> ?FINISHED DUP 100 > OVER 0FF AND 4 <> AND
  1367.         IF ?MEM THEN CHECK-SIZES ADDR, SEG, 0F CODE-C, 100 /MOD CODE-C,
  1368.         INSTALL-/R COMPILE-FIELDS ;
  1369.  
  1370. ( GROUP 8 INSTRUCTIONS -- BT, ETC. )
  1371. : GROUP8-COMPILE ( COMPILE A GROUP 8 INSTRUCTION )
  1372.         ( PARAM -- | X \ PARAM -- | X \ X' \ PARAM -- )
  1373.        ?REP REGISTER GENERIC-ENTRY2 0F CODE-C, HAS-IMMED? IF INSTALL-/R BA
  1374.        ELSE 8* 83 + ?R/M,REG THEN CODE-C, MOD-R/M, S-I-B, DISP, 8BIT DT-SIZE
  1375.        DATA-! IMMED, ;
  1376.  
  1377. ( ENTER )
  1378. : ENTER-COMPILE ( COMPILE THE ENTER INSTRUCTION )
  1379.        ( X \ X' \ PARAM -- )
  1380.         3 ?TOOMANYOPS ?INST-PRE ?SEG CLR-OPSTACK DROP 0C8 CODE-C, SWAP
  1381.         CODE-W, CODE-C, ;
  1382.  
  1383. ( ARPL )
  1384. : ARPL-COMPILE ( COMPILE THE ARPL INSTRUCTION )
  1385.         ( PARAM -- | X \ PARAM -- )
  1386.         ?INST-PRE DROP DO-2OPS ?FINISHED REGISTER ?BADTYPE ?R/M,REG ?NOIMMED
  1387.         ADDR, SEG, 63 CODE-C, SWAP-REGS COMPILE-FIELDS ;
  1388.  
  1389. ( ECHANGE & ALU INSTRUCTIONS -- CMPXCHG, XADD )
  1390. : XCHG&ALU-COMPILE ( COMPILE CMPXCHG OR XADD )
  1391.         ( PARAM -- | X \ PARAM -- )
  1392.         ?REP REGISTER GENERIC-ENTRY2 ?R/M,REG ?NOIMMED 0F CODE-C, +SIZE-BIT
  1393.         CODE-C, SWAP-REGS COMPILE-FIELDS ;
  1394.  
  1395. ( CMPXCHG8B -- PENTIUM INSTRUCTION SET )
  1396. : CMPXCHG8B-COMP ( ASSEMBLE CMPXCHG8B )
  1397.         ( PARAM -- )
  1398.         ?REP DROP ?PARAMS DO-1OP CHECK-AD-SIZE DT-SIZE DATA-@ ?DUP IF 64BIT <>
  1399.         ?BADMODE THEN ?MEM ?NOIMMED GENERATE-PREFIXES 0C70F CODE-W,
  1400.         COMPILE-FIELDS ;
  1401.  
  1402. ( BOUND CHECKING )
  1403. : BOUND-COMPILE ( COMPILE THE BOUND INSTRUCTION )
  1404.         ( PARAM -- | X \ PARAM -- )
  1405.         ?INST-PRE REGISTER GENERIC-ENTRY2 ?REG,MEM ?NOIMMED DROP 62 CODE-C,
  1406.         COMPILE-FIELDS ;
  1407.  
  1408. ( BSWAP )
  1409. : BSWAP-COMPILE ( COMPILE BSWAP )
  1410.         ( PARAM -- )
  1411.         ?INST-PRE ?SEG DROP ?PARAMS 1 ?TOOMANYOPS POP-OP 0 ALL-EXCEPT SWAP
  1412.         REGISTER ?NOMATCH 0F CODE-C, 0C8 + CODE-C, ;
  1413.  
  1414. ( PUSH AND POP )
  1415. : PUSH/POP-ENTRY ( ENTRY SEQUENCE FOR PUSH AND POP COMPILERS )
  1416.         ( PARAM -- )
  1417.         ?INST-PRE DROP DO-1OP ?FINISHED SREG ?BADTYPE CHECK-SIZES
  1418.         SREG MAXTYPE DATA-@ - IF GENERATE-PREFIXES THEN MAXTYPE DATA-@ ;
  1419.  
  1420. : PUSH-COMPILE ( COMPILE PUSH )
  1421.         ( PARAM -- | X \ PARAM -- )
  1422.         PUSH/POP-ENTRY CASE
  1423.                 UNKNOWN OF A16BIT? IF 6 ELSE 5 THEN MOD-R/M DATA-! 6
  1424.                         INSTALL-/R 0FF CODE-C, MOD-R/M DATA-@ CODE-C,
  1425.                         HAS-FULL-OFF DISP,
  1426.                 ENDOF REGISTER OF MOD-R/M DATA-@ [ 50 C0- ] LITERAL +
  1427.                         CODE-C,
  1428.                 ENDOF SREG OF MOD-R/M DATA-@ C0-8* 6 + DUP 1E > IF 0F CODE-C,
  1429.                         [ 0A0 26 - ] LITERAL + THEN CODE-C,
  1430.                 ENDOF IMMEDIATE OF IMMED-SV DATA-@ ABS 7F > IF 68 GET-FP-SIZE
  1431.                         DT-SIZE DATA-! ELSE 6A 8BIT DT-SIZE DATA-! THEN
  1432.                         CODE-C, IMMED,
  1433.                 ENDOF 0FF CODE-C, 6 INSTALL-/R COMPILE-FIELDS
  1434.         ENDCASE ;
  1435.  
  1436. : POP-COMPILE ( COMPILE POP )
  1437.         ( PARAM -- | X \ PARAM -- )
  1438.         PUSH/POP-ENTRY ?NOIMMED CASE
  1439.                 UNKNOWN OF A16BIT? IF 6 ELSE 5 THEN MOD-R/M DATA-! 0
  1440.                         INSTALL-/R 8F CODE-C, MOD-R/M DATA-@ CODE-C,
  1441.                         HAS-FULL-OFF DISP,
  1442.                 ENDOF REGISTER OF MOD-R/M DATA-@ [ 58 C0- ] LITERAL +
  1443.                         CODE-C,
  1444.                 ENDOF SREG OF MOD-R/M DATA-@ C0-8* 7 + DUP 1F > IF 0F CODE-C,
  1445.                         [ 0A1 27 - ] LITERAL + THEN CODE-C,
  1446.                 ENDOF 8F CODE-C, 0 INSTALL-/R COMPILE-FIELDS
  1447.         ENDCASE ;
  1448.  
  1449. ( CALL AND JMP )
  1450. : CALL/JMP-ENTRY ( ENTRY FOR CALL AND JUMP )
  1451.         ( PARAM -- )
  1452.         DROP ?INST-PRE PARSE-CALL/JMP-OPERANDS REGISTER ?BADTYPE CHECK-SIZES ;
  1453. : CALL-COMPILE ( COMPILE CALL )
  1454.         ( PARAM -- | X \ PARAM -- )
  1455.         CALL/JMP-ENTRY ?NOSHORT GENERATE-PREFIXES IS-NEAR? IF HAS-MOD-R/M?
  1456.         IF 0FF CODE-C, 2 INSTALL-/R COMPILE-FIELDS ELSE 0E8 CODE-C, OFFSET-SV
  1457.         DATA-@ A16BIT? OFFSET16/32, THEN ELSE HAS-MOD-R/M? IF 0FF CODE-C, 3
  1458.         INSTALL-/R COMPILE-FIELDS ELSE 9A CODE-C, OFFSET-SV DATA-@ A16BIT?
  1459.         IF CODE-W, ELSE CODE-D, THEN CODE-W, THEN THEN ;
  1460. : JMP-COMPILE ( COMPILE JMP )
  1461.         ( PARAM -- | X \ PARAM -- )
  1462.         CALL/JMP-ENTRY GENERATE-PREFIXES IS-SHORT? IF OFFSET-SV DATA-@ 0EB
  1463.         CODE-C, OFFSET8, ELSE IS-NEAR? IF HAS-MOD-R/M? IF 0FF CODE-C, 4
  1464.         INSTALL-/R COMPILE-FIELDS ELSE 0E9 CODE-C, OFFSET-SV DATA-@ A16BIT?
  1465.         OFFSET16/32, THEN ELSE HAS-MOD-R/M? IF 0FF CODE-C, 5 INSTALL-/R
  1466.         COMPILE-FIELDS ELSE 0EA CODE-C, OFFSET-SV DATA-@ A16BIT? IF CODE-W,
  1467.         ELSE CODE-D, THEN CODE-W, THEN THEN THEN ;
  1468.  
  1469. ( I/O INSTRUCTIONS )
  1470. : I/O-COMPILE ( COMPILE AN IN OR OUT )
  1471.         ( PARAM -- | X \ PARAM -- )
  1472.         ?INST-PRE ?SEG 3 ?TOOMANYOPS >R DEPTH-CHANGE IF IMMED-SV DATA-!
  1473.         HAS-IMMED THEN R> BEGIN OP-DEPTH WHILE POP-OP CASE
  1474.                 LIT-OP     , OF ( DISCARD IT ) ENDOF
  1475.                 LIT-OP    DX OF ( DISCARD IT ) ENDOF
  1476.                 LIT-OP     # OF ( DISCARD IT ) ENDOF
  1477.                 LIT-OP    AL OF  8BIT ?OPSIZE  ENDOF
  1478.                 LIT-OP  BYTE OF  8BIT ?OPSIZE  ENDOF
  1479.                 LIT-OP    AX OF 16BIT ?OPSIZE  ENDOF
  1480.                 LIT-OP  WORD OF 16BIT ?OPSIZE  ENDOF
  1481.                 LIT-OP   EAX OF 32BIT ?OPSIZE  ENDOF
  1482.                 LIT-OP DWORD OF 32BIT ?OPSIZE  ENDOF
  1483.                 -1 ?BADMODE
  1484.         ENDCASE REPEAT CHECK-DT-SIZE DATA, +SIZE-BIT HAS-IMMED?
  1485.         IF CODE-C, IMMED-SV DATA-@ CODE-C, ELSE 8+ CODE-C, THEN ;
  1486.  
  1487. ( BIT SCAN INSTRUCTIONS )
  1488. : BS-COMPILE ( COMPILE A BIT SCAN INSTRUCTION, AND ALSO SELECTOR VALIDATION )
  1489.         ( PARAM -- | X \ PARAM -- )
  1490.         ?INST-PRE REGISTER GENERIC-ENTRY2 ?NOIMMED ?REG,R/M 0F CODE-C, CODE-C,
  1491.         COMPILE-FIELDS ;
  1492.  
  1493. ( MOV INSTRUCTION )
  1494. : MOV-COMPILE ( COMPILE A MOV INSTRUCTION )
  1495.         ( PARAM -- | X \ PARAM -- | X \ X' \ PARAM -- )
  1496.        ?REP TREG GENERIC-ENTRY2 DROP HAS-IMMED? IF 0C6 +SIZE-BIT ELSE
  1497.        MAXTYPE DATA-@ CASE
  1498.                REGISTER OF                 88 +SIZE-BIT ENDOF
  1499.                SREG     OF                 8C           ENDOF
  1500.                CREG     OF ?REG 0F CODE-C, 20           ENDOF
  1501.                DREG     OF ?REG 0F CODE-C, 21           ENDOF
  1502.                TREG     OF ?REG 0F CODE-C, 24           ENDOF
  1503.                -1 ?BADMODE 0
  1504.        ENDCASE +DIRECT-BIT THEN CODE-C, COMPILE-FIELDS ;
  1505.  
  1506. ( XCHG INSTRUCTION )
  1507. : XCHG-COMPILE ( COMPILE THE XCHG INSTRUCTION )
  1508.        ( PARAM -- | X \ PARAM -- )
  1509.        ?REP REGISTER GENERIC-ENTRY2 ?NOIMMED +SIZE-BIT CODE-C,
  1510.        COMPILE-FIELDS ;
  1511.  
  1512. ( RET INSTRUCTION )
  1513. : RETF? ( ADJUST OPCODE FOR FAR RETURN )
  1514.        ( X -- X' )
  1515.         IS-FAR? IF 8+ THEN ;
  1516. : RET-COMPILE ( COMPILE THE RET INSTRUCTION )
  1517.         ( PARAM -- | X \ PARAM -- )
  1518.         ?INST-PRE 2 ?TOOMANYOPS DROP DEPTH-CHANGE IF IMMED-SV DATA-! HAS-IMMED
  1519.         THEN BEGIN OP-DEPTH WHILE POP-OP CASE
  1520.                 LIT-OP NEAR OF IS-NEAR ENDOF
  1521.                 LIT-OP  FAR OF  IS-FAR ENDOF
  1522.                 LIT-OP    # OF         ENDOF
  1523.                         -1 ?BADMODE
  1524.         ENDCASE REPEAT HAS-IMMED? IF 0C2 RETF? CODE-C, IMMED-SV DATA-@ CODE-W,
  1525.         ELSE 0C3 RETF? CODE-C, THEN ;
  1526.  
  1527. : RETF-COMPILE ( COMPILE RETF )
  1528.         ( PARAM -- | X \ PARAM -- )
  1529.         FAR RET-COMPILE ;
  1530.  
  1531. ( INT INSTRUCTION )
  1532. : INT-COMPILE ( COMPILE THE INT INSTRUCTION )
  1533.         ( X \ PARAM -- )
  1534.         ?INST-PRE DROP 0 ?TOOMANYOPS DEPTH-CHANGE 0= IF 2 ?NOTENOUGH THEN
  1535.         DUP 3 = IF DROP 0CC ELSE 0CD CODE-C, THEN CODE-C, ;
  1536.  
  1537. ( SETCC INSTRUCTIONS )
  1538. : SETCC-COMPILE ( COMPILE SETCC INSTRUCTIONS )
  1539.         ( PARAM -- | X \ PARAM -- )
  1540.         ?INST-PRE >R DO-1OP ?FINISHED ?NOIMMED REGISTER ?BADTYPE CHECK-SIZES
  1541.         GENERATE-PREFIXES 0F CODE-C, R> CODE-C, COMPILE-FIELDS ;
  1542.  
  1543. ( XLAT/XLATB )
  1544. : XLAT-COMPILE ( COMPILE XLAT )
  1545.         ( PARAM -- )
  1546.         ?INST-PRE DROP ?PARAMS 3 ?TOOMANYOPS BEGIN OP-DEPTH WHILE POP-OP CASE
  1547.                 LIT-OP    AL OF               ENDOF
  1548.                 LIT-OP  [BX] OF 16BIT ?OPSIZE ENDOF
  1549.                 LIT-OP [EBX] OF 32BIT ?OPSIZE ENDOF
  1550.                         -1 ?BADMODE
  1551.         ENDCASE REPEAT CHECK-SIZES GENERATE-PREFIXES 0D7 CODE-C, ;
  1552.  
  1553. : XLATB-COMPILE ( COMPILE XLATB )
  1554.         ( PARAM -- )
  1555.         ?SEG ?OPERANDS DEFAULT-SIZE 16BIT = IF [BX] ELSE [EBX] THEN
  1556.         XLAT-COMPILE ;
  1557.  
  1558. ( DOUBLE PRECISION SHIFT INSTRUCTIONS )
  1559. : DOUBLE-SHIFT ( COMPILE SHLD, SHRD )
  1560.         ( PARAM -- | X \ PARAM -- | X \ X' \ PARAM -- )
  1561.        ?INST-PRE POP-OP CASE LIT-OP , OF SAVE-IMMED ENDOF LIT-OP # OF
  1562.        SAVE-IMMED NEXT-IS-, ENDOF LIT-OP CL OF 1+ NEXT-IS-, ENDOF -1
  1563.        ?BADMODE ENDCASE REGISTER GENERIC-ENTRY2 0F CODE-C, CODE-C, MOD-R/M,
  1564.        S-I-B, DISP, 8BIT DT-SIZE DATA-! IMMED, ;
  1565.  
  1566. ( POINTER LOADING INSTRUCTIONS )
  1567. : LOAD-PTR-COMP ( COMPILE A POINTER LOAD INSTRUCTION )
  1568.        ( PARAM -- | X \ PARAM -- )
  1569.        ?INST-PRE REGISTER GENERIC-ENTRY2 ?NOIMMED ?REG,R/M ?MEM DUP 100 >
  1570.        IF CODE-W, ELSE CODE-C, THEN COMPILE-FIELDS ;
  1571.  
  1572. ( EXTENDED MOV INSTRUCTIONS )
  1573. : MOVX-COMPILE ( COMPILE MOVSX/MOVZX )
  1574.        ( PARAM -- | X \ PARAM -- )
  1575.        ?INST-PRE >R DO-1OP R> +SIZE-BIT 0 DT-SIZE DATA-! >R DO-1OP R>
  1576.        ?FINISHED ?NOIMMED ?REG,R/M CHECK-SIZES GENERATE-PREFIXES 0F CODE-C,
  1577.        CODE-C, COMPILE-FIELDS ;
  1578.  
  1579. ( FADD & FMUL )
  1580. : FAD/FMUL-COMPILE ( COMPILE FADD AND FMUL )
  1581.        ( PARAM -- | X \ PARAM -- )
  1582.        ?INST-PRE >R PARSE-FP-OPS R> SWAP CASE
  1583.                0 OF 1 /R&FREG>MOD-R/M ?SEG 0DE CODE-C, CODE-C, ENDOF
  1584.                1 OF 0D8 +FP-SIZE SWAP FP-GENERIC-ASSEMBLE ENDOF
  1585.                2 OF ?SEG 0D8 +FP-DIRECT-BIT CODE-C, MOD-R/M>FREG
  1586.                        /R&FREG>MOD-R/M CODE-C, ENDOF
  1587.        ENDCASE ;
  1588.  
  1589. ( FST & FSTP )
  1590. : FST-COMPILE ( COMPILE FST AND FSTP )
  1591.        ( PARAM -- | X \ PARAM -- )
  1592.        ?INST-PRE >R DO-1OP R> ?FINISHED ?NOIMMED MAXTYPE DATA-@ FREG = IF
  1593.                ?SEG 0DD CODE-C, MOD-R/M>FREG /R&FREG>MOD-R/M CODE-C,
  1594.        ELSE
  1595.                REGISTER ?BADTYPE ?MEM CHECK-SIZES DT-SIZE DATA-@
  1596.                CASE
  1597.                        UNKNOWN OF ( FLOAT BY DEFAULT ) 0D9 ENDOF
  1598.                          32BIT OF                      0D9 ENDOF
  1599.                          64BIT OF                      0DD ENDOF
  1600.                          80BIT OF 4+                   0DB ENDOF
  1601.                        -1 ?BADMODE 0
  1602.                ENDCASE SWAP FP-GENERIC-ASSEMBLE
  1603.        THEN ;
  1604.  
  1605. ( INTEGER/FLOATING POINT OPERATIONS )
  1606. : FIX-COMPILE ( COMPILE FIX INSTRUCTIONS )
  1607.        ( PARAM -- | X \ PARAM -- )
  1608.        ?INST-PRE >R DO-1OP ?FINISHED REGISTER ?BADTYPE ?NOIMMED ?MEM
  1609.        CHECK-SIZES 0DA DT-SIZE DATA-@ 16BIT = IF 4+ THEN R>
  1610.        FP-GENERIC-ASSEMBLE ;
  1611.  
  1612. ( FLOAT OPS THAT POP THE STACK )
  1613. : FXP-COMPILE ( COMPILE FXP INSTRUCTIONS )
  1614.        ( PARAM -- )
  1615.        ?INST-PRE ?SEG >R PARSE-FP-OPS 2- ?BADMODE R> 0DE CODE-C,
  1616.        MOD-R/M>FREG + CODE-C, ;
  1617.  
  1618. ( FCOM )
  1619. : FCOM-COMPILE ( COMPILE FCOM AND FCOMP )
  1620.        ( PARAM -- | X \ PARAM -- )
  1621.        ?INST-PRE >R PARSE-FP-OPS R> SWAP CASE
  1622.                0 OF 0D8 CODE-C, 1 /R&FREG>MOD-R/M CODE-C, ENDOF
  1623.                1 OF MAXTYPE DATA-@ FREG = IF
  1624.                        0D8 CODE-C, MOD-R/M>FREG /R&FREG>MOD-R/M CODE-C,
  1625.                ELSE
  1626.                        REGISTER ?BADTYPE ?MEM 0D8 +FP-SIZE SWAP
  1627.                        FP-GENERIC-ASSEMBLE
  1628.                THEN ENDOF
  1629.                        -1 ?BADMODE DROP
  1630.        ENDCASE ;
  1631.  
  1632. ( MISCELLANEOUS FLOATING POINT INSTRUCTIONS )
  1633. : FMISC-COMPILE ( COMPILE MISCELLANEOUS FP INSTRUCTIONS )
  1634.        ( PARAM -- )
  1635.        ?INST-PRE ?SEG >R ?PARAMS PARSE-FP-OPS R> 100 /MOD ROT CASE
  1636.                0 OF 1+ ENDOF
  1637.                1 OF MAXTYPE DATA-@ FREG - ?BADMODE MOD-R/M>FREG + ENDOF
  1638.                -1 ?BADMODE
  1639.        ENDCASE SWAP CODE-C, CODE-C, ;
  1640.  
  1641. ( FBLD & FBSTP, AND LOAD AND STORE CONTROL WORD, ENVIRONMENT, ETC. )
  1642. : GENERIC-FP-ENTRY1 ( GENERIC ENTRY SEQUENCE FOR FP INST THAT TAKE ONE MEMORY )
  1643.        ( OPERAND )
  1644.        ( PARAM -- PARAM | X \ PARAM -- PARAM )
  1645.        ?INST-PRE >R PARSE-FP-OPS 1- ?BADMODE R> REGISTER ?BADTYPE ?MEM ;
  1646. : FBLD/STP-COMPILE ( COMPILE FBLD & FBSTP )
  1647.        ( PARAM -- | X \ PARAM -- )
  1648.        GENERIC-FP-ENTRY1 100 /MOD DUP 7 > IF 8- 9B CODE-C, THEN
  1649.        FP-GENERIC-ASSEMBLE ;
  1650.  
  1651. ( FIST )
  1652. : FIST-COMPILE ( COMPILE FIST & FISTP )
  1653.        ( PARAM -- | X \ PARAM -- )
  1654.        GENERIC-FP-ENTRY1 GET-FP-SIZE CASE
  1655.                16BIT OF    0DF ENDOF
  1656.                32BIT OF    0DB ENDOF
  1657.                64BIT OF 4+ 0DF ENDOF
  1658.                        -1 ?BADMODE 0
  1659.        ENDCASE SWAP FP-GENERIC-ASSEMBLE ;
  1660.  
  1661. ( FSTSW )
  1662. : FSTSW-COMPILE ( COMPILE FSTSW & FNSTSW )
  1663.        ( PARAM -- | X \ PARAM -- )
  1664.        ?INST-PRE >R PARSE-FP-OPS DUP 1 > ?BADMODE REGISTER ?BADTYPE R> IF
  1665.        9B CODE-C, THEN CASE
  1666.                 0 OF ?SEG 0E0DF CODE-W, ENDOF
  1667.                 1 OF MAXTYPE DATA-@ REGISTER = IF
  1668.                        MOD-R/M DATA-@ C0- ?BADMODE ?SEG 0E0DF CODE-W,
  1669.                 ELSE
  1670.                        0DD 7 FP-GENERIC-ASSEMBLE
  1671.                 THEN ENDOF
  1672.        ENDCASE ;
  1673.  
  1674. ( FILD )
  1675. : FILD-COMPILE ( COMPILE FILD )
  1676.        ( PARAM -- | X \ PARAM -- )
  1677.        GENERIC-FP-ENTRY1 DROP GET-FP-SIZE CASE
  1678.                 16BIT OF 0DF 0 ENDOF
  1679.                 32BIT OF 0DB 0 ENDOF
  1680.                 64BIT OF 0DF 5 ENDOF
  1681.                        -1 ?BADMODE 0 0
  1682.        ENDCASE FP-GENERIC-ASSEMBLE ;
  1683.  
  1684. ( FLD COMPILE )
  1685. : FLD-COMPILE ( COMPILE FLD )
  1686.        ( PARAM -- | X \ PARAM -- )
  1687.        ?INST-PRE DROP PARSE-FP-OPS 1- ?BADMODE MAXTYPE DATA-@ FREG = IF
  1688.                ?SEG 0D9 CODE-C, MOD-R/M>FREG C0+ CODE-C,
  1689.        ELSE
  1690.                REGISTER ?BADTYPE ?MEM DT-SIZE DATA-@ CASE
  1691.                        UNKNOWN OF ( ASSUME FLOAT ) 0D9 0 ENDOF
  1692.                          32BIT OF                  0D9 0 ENDOF
  1693.                          64BIT OF                  0DD 0 ENDOF
  1694.                          80BIT OF                  0DB 5 ENDOF
  1695.                                  -1 ?BADMODE 0 0
  1696.                ENDCASE FP-GENERIC-ASSEMBLE
  1697.        THEN ;
  1698.  
  1699. ( FDIV, FDIVR, FSUB, FSUBR )
  1700. : FDIV/SUB-COMPILE ( COMPILE FDIV, FDIVR, FSUB, & FSUBR )
  1701.        ( PARAM -- | X \ PARAM -- )
  1702.        ?INST-PRE >R PARSE-FP-OPS R> SWAP CASE
  1703.                0 OF ?SEG 1 XOR 0DE CODE-C, 1 /R&FREG>MOD-R/M CODE-C, ENDOF
  1704.                1 OF ?MEM 0D8 +FP-SIZE SWAP FP-GENERIC-ASSEMBLE ENDOF
  1705.                2 OF ?SEG MAXTYPE DATA-@ FREG ?NOMATCH 0D8 +FP-DIRECT-BIT
  1706.                        CODE-C, FP-DIRECTION? IF 1 XOR THEN MOD-R/M>FREG
  1707.                        /R&FREG>MOD-R/M CODE-C, ENDOF
  1708.        ENDCASE ;
  1709.  
  1710. ( THE INSTRUCTIONS )
  1711. IN-ASM
  1712.     37 '            1BYTE OPCODE AAA
  1713.    0AD5 '            2BYTE OPCODE AAD
  1714.   0AD4 '            2BYTE OPCODE AAM
  1715.      3F '            1BYTE OPCODE AAS
  1716.     02 '   GROUP1-COMPILE OPCODE ADC
  1717.      00 '   GROUP1-COMPILE OPCODE ADD
  1718.     04 '   GROUP1-COMPILE OPCODE AND
  1719.       0 '     ARPL-COMPILE OPCODE ARPL
  1720.      0 '    BOUND-COMPILE OPCODE BOUND
  1721.     0BC '       BS-COMPILE OPCODE BSF
  1722.    0BD '       BS-COMPILE OPCODE BSR
  1723.       0 '    BSWAP-COMPILE OPCODE BSWAP
  1724.     04 '   GROUP8-COMPILE OPCODE BT
  1725.      07 '   GROUP8-COMPILE OPCODE BTC
  1726.     06 '   GROUP8-COMPILE OPCODE BTR
  1727.      05 '   GROUP8-COMPILE OPCODE BTS
  1728.      0 '     CALL-COMPILE OPCODE CALL
  1729.     298 '   SIZE-COND-COMP OPCODE CBW
  1730.    399 '   SIZE-COND-COMP OPCODE CDQ
  1731.     0F8 '            1BYTE OPCODE CLC
  1732.    0FC '            1BYTE OPCODE CLD
  1733.     0FA '            1BYTE OPCODE CLI
  1734.   060F '            2BYTE OPCODE CLTS
  1735.     0F5 '            1BYTE OPCODE CMC
  1736.     07 '   GROUP1-COMPILE OPCODE CMP
  1737.     0A6 '         STR-INST OPCODE CMPS
  1738.    0A6 '    BYTE-STR-INST OPCODE CMPSB
  1739.     0A6 '   DWORD-STR-INST OPCODE CMPSD
  1740.    0A6 '    WORD-STR-INST OPCODE CMPSW
  1741.     0BC ' XCHG&ALU-COMPILE OPCODE CMPXCHG
  1742.      0 '   CMPXCHG8B-COMP OPCODE CMPXCHG8B
  1743.   0A20F '            2BYTE OPCODE CPUID
  1744.    299 '   SIZE-COND-COMP OPCODE CWD
  1745.     398 '   SIZE-COND-COMP OPCODE CWDE
  1746.     27 '            1BYTE OPCODE DAA
  1747.      2F '            1BYTE OPCODE DAS
  1748.     01 '      DEC-COMPILE OPCODE DEC
  1749.      06 '   GROUP3-COMPILE OPCODE DIV
  1750.      0 '    ENTER-COMPILE OPCODE ENTER
  1751.   0F0D9 '            2BYTE OPCODE F2XM1
  1752.  0E1D9 '            2BYTE OPCODE FABS
  1753.      00 ' FAD/FMUL-COMPILE OPCODE FADD
  1754.    0C0 '      FXP-COMPILE OPCODE FADDP
  1755.     4DF ' FBLD/STP-COMPILE OPCODE FBLD
  1756.    6DF ' FBLD/STP-COMPILE OPCODE FBSTP
  1757.   0E0D9 '            2BYTE OPCODE FCHS
  1758. 0E2DB9B '            3BYTE OPCODE FCLEX
  1759.      02 '     FCOM-COMPILE OPCODE FCOM
  1760.     03 '     FCOM-COMPILE OPCODE FCOMP
  1761.   0D9DE '            2BYTE OPCODE FCOMPP
  1762.  0FFD9 '            2BYTE OPCODE FCOS
  1763.   0F6D9 '            2BYTE OPCODE FDECSTP
  1764.     06 ' FDIV/SUB-COMPILE OPCODE FDIV
  1765.     0F8 '      FXP-COMPILE OPCODE FDIVP
  1766.     07 ' FDIV/SUB-COMPILE OPCODE FDIVR
  1767.     0F0 '      FXP-COMPILE OPCODE FDIVPR
  1768.  0C0DD '    FMISC-COMPILE OPCODE FFREE
  1769.      00 '      FIX-COMPILE OPCODE FIADD
  1770.     02 '      FIX-COMPILE OPCODE FICOM
  1771.      03 '      FIX-COMPILE OPCODE FICOMP
  1772.     06 '      FIX-COMPILE OPCODE FIDIV
  1773.      07 '      FIX-COMPILE OPCODE FIDIVR
  1774.      0 '     FILD-COMPILE OPCODE FILD
  1775.      01 '      FIX-COMPILE OPCODE FIMUL
  1776.  0F7D9 '            2BYTE OPCODE FINCSTP
  1777. 0E3DB9B '            3BYTE OPCODE FINIT
  1778.     04 '      FIX-COMPILE OPCODE FISUB
  1779.      05 '      FIX-COMPILE OPCODE FISUBR
  1780.     02 '     FIST-COMPILE OPCODE FIST
  1781.      03 '     FIST-COMPILE OPCODE FISTP
  1782.      0 '      FLD-COMPILE OPCODE FLD
  1783.   0E8D9 '            2BYTE OPCODE FLD1
  1784.    5D9 ' FBLD/STP-COMPILE OPCODE FLDCW
  1785.     4D9 ' FBLD/STP-COMPILE OPCODE FLDENV
  1786.  0E9D9 '            2BYTE OPCODE FLDL2T
  1787.   0EAD9 '            2BYTE OPCODE FLDL2E
  1788.  0EBD9 '            2BYTE OPCODE FLDPI
  1789.   0ECD9 '            2BYTE OPCODE FLDLG2
  1790.  0EDD9 '            2BYTE OPCODE FLDLN2
  1791.   0EED9 '            2BYTE OPCODE FLDZ
  1792.     01 ' FAD/FMUL-COMPILE OPCODE FMUL
  1793.     0C8 '      FXP-COMPILE OPCODE FMULP
  1794.  0E2DB '            2BYTE OPCODE FNCLEX
  1795.   0E3DB '            2BYTE OPCODE FNINIT
  1796.  0D0D9 '            2BYTE OPCODE FNOP
  1797.     6DD ' FBLD/STP-COMPILE OPCODE FNSAVE
  1798.    7D9 ' FBLD/STP-COMPILE OPCODE FNSTCW
  1799.      00 '    FSTSW-COMPILE OPCODE FNSTSW
  1800.    6D9 ' FBLD/STP-COMPILE OPCODE FNSTENV
  1801.   0F3D9 '            2BYTE OPCODE FPATAN
  1802.  0F8D9 '            2BYTE OPCODE FPREM
  1803.   0F5D9 '            2BYTE OPCODE FPREM1
  1804.  0F2D9 '            2BYTE OPCODE FPTAN
  1805.   0FCD9 '            2BYTE OPCODE FRNDINT
  1806.    4DD ' FBLD/STP-COMPILE OPCODE FRSTOR
  1807.    0EDD ' FBLD/STP-COMPILE OPCODE FSAVE
  1808.  0FDD9 '            2BYTE OPCODE FSCALE
  1809.   0FED9 '            2BYTE OPCODE FSIN
  1810.  0FBD9 '            2BYTE OPCODE FSINCOS
  1811.   0FAD9 '            2BYTE OPCODE FSQRT
  1812.     02 '      FST-COMPILE OPCODE FST
  1813.    0FD9 ' FBLD/STP-COMPILE OPCODE FSTCW
  1814.   0ED9 ' FBLD/STP-COMPILE OPCODE FSTENV
  1815.      03 '      FST-COMPILE OPCODE FSTP
  1816.     01 '    FSTSW-COMPILE OPCODE FSTSW
  1817.      04 ' FDIV/SUB-COMPILE OPCODE FSUB
  1818.    0E8 '      FXP-COMPILE OPCODE FSUBP
  1819.     0E0 '      FXP-COMPILE OPCODE FSUBPR
  1820.     05 ' FDIV/SUB-COMPILE OPCODE FSUBR
  1821.   0E4D9 '            2BYTE OPCODE FTST
  1822.  0E0DD '    FMISC-COMPILE OPCODE FUCOM
  1823.   0E8DD '    FMISC-COMPILE OPCODE FUCOMP
  1824.  0E9DA '            2BYTE OPCODE FUCOMPP
  1825.      9B '            1BYTE OPCODE FWAIT
  1826.  0E5D9 '            2BYTE OPCODE FXAM
  1827.   0C8D9 '    FMISC-COMPILE OPCODE FXCH
  1828.  0F4D9 '            2BYTE OPCODE FXTRACT
  1829.   0F1D9 '            2BYTE OPCODE FYL2X
  1830.  0F9D9 '            2BYTE OPCODE FYL2XP1
  1831.     0F4 '            1BYTE OPCODE HLT
  1832.     07 '   GROUP3-COMPILE OPCODE IDIV
  1833.      05 '   GROUP3-COMPILE OPCODE IMUL
  1834.    0E4 '      I/O-COMPILE OPCODE IN
  1835.      00 '     INC-COMPILE OPCODE INC
  1836.     6C '         STR-INST OPCODE INS
  1837.      6C '    BYTE-STR-INST OPCODE INSB
  1838.     6C '   DWORD-STR-INST OPCODE INSD
  1839.      6C '    WORD-STR-INST OPCODE INSW
  1840.      0 '      INT-COMPILE OPCODE INT
  1841.     0C3 '            1BYTE OPCODE INTO
  1842.   080F '            2BYTE OPCODE INVD
  1843.     107 ' GROUP6&7-COMPILE OPCODE INVLPG
  1844.    2CF '   SIZE-COND-COMP OPCODE IRET
  1845.     3CF '   SIZE-COND-COMP OPCODE IRETD
  1846.     77 '      JCC-COMPILE OPCODE JA
  1847.      73 '      JCC-COMPILE OPCODE JAE
  1848.     72 '      JCC-COMPILE OPCODE JB
  1849.      76 '      JCC-COMPILE OPCODE JBE
  1850.     72 '      JCC-COMPILE OPCODE JC
  1851.     0E3 '     JCXZ-COMPILE OPCODE JCXZ
  1852.    0E3 '    JECXZ-COMPILE OPCODE JECXZ
  1853.      74 '      JCC-COMPILE OPCODE JE
  1854.     7F '      JCC-COMPILE OPCODE JG
  1855.      7D '      JCC-COMPILE OPCODE JGE
  1856.     7C '      JCC-COMPILE OPCODE JL
  1857.      7E '      JCC-COMPILE OPCODE JLE
  1858.      0 '      JMP-COMPILE OPCODE JMP
  1859.      76 '      JCC-COMPILE OPCODE JNA
  1860.     72 '      JCC-COMPILE OPCODE JNAE
  1861.      73 '      JCC-COMPILE OPCODE JNB
  1862.     77 '      JCC-COMPILE OPCODE JNBE
  1863.      73 '      JCC-COMPILE OPCODE JNC
  1864.     75 '      JCC-COMPILE OPCODE JNE
  1865.      7E '      JCC-COMPILE OPCODE JNG
  1866.     7C '      JCC-COMPILE OPCODE JNGE
  1867.      7D '      JCC-COMPILE OPCODE JNL
  1868.     7F '      JCC-COMPILE OPCODE JNLE
  1869.      71 '      JCC-COMPILE OPCODE JNO
  1870.     7B '      JCC-COMPILE OPCODE JNP
  1871.      79 '      JCC-COMPILE OPCODE JNS
  1872.     75 '      JCC-COMPILE OPCODE JNZ
  1873.      70 '      JCC-COMPILE OPCODE JO
  1874.     7A '      JCC-COMPILE OPCODE JP
  1875.      7A '      JCC-COMPILE OPCODE JPE
  1876.     7B '      JCC-COMPILE OPCODE JPO
  1877.      78 '      JCC-COMPILE OPCODE JS
  1878.     74 '      JCC-COMPILE OPCODE JZ
  1879.      9F '            1BYTE OPCODE LAHF
  1880.     02 '       BS-COMPILE OPCODE LAR
  1881.     0C5 '    LOAD-PTR-COMP OPCODE LDS
  1882.     8D '    LOAD-PTR-COMP OPCODE LEA
  1883.     0C9 '            1BYTE OPCODE LEAVE
  1884.    0C4 '    LOAD-PTR-COMP OPCODE LES
  1885.   0B40F '    LOAD-PTR-COMP OPCODE LFS
  1886.  0B50F '    LOAD-PTR-COMP OPCODE LGS
  1887.      03 '       BS-COMPILE OPCODE LSL
  1888.  0B20F '    LOAD-PTR-COMP OPCODE LSS
  1889.     102 ' GROUP6&7-COMPILE OPCODE LGDT
  1890.    103 ' GROUP6&7-COMPILE OPCODE LIDT
  1891.      02 ' GROUP6&7-COMPILE OPCODE LLDT
  1892.    106 ' GROUP6&7-COMPILE OPCODE LMSW
  1893.     0AC '         STR-INST OPCODE LODS
  1894.    0AC '    BYTE-STR-INST OPCODE LODSB
  1895.     0AC '   DWORD-STR-INST OPCODE LODSD
  1896.    0AC '    WORD-STR-INST OPCODE LODSW
  1897.     0E2 '     LOOP-COMPILE OPCODE LOOP
  1898.    0E1 '     LOOP-COMPILE OPCODE LOOPE
  1899.     0E0 '     LOOP-COMPILE OPCODE LOOPNE
  1900.    0E0 '     LOOP-COMPILE OPCODE LOOPNZ
  1901.     0E1 '     LOOP-COMPILE OPCODE LOOPZ
  1902.     03 ' GROUP6&7-COMPILE OPCODE LTR
  1903.       0 '      MOV-COMPILE OPCODE MOV
  1904.    0A4 '         STR-INST OPCODE MOVS
  1905.     0BE '     MOVX-COMPILE OPCODE MOVSX
  1906.    0A4 '    BYTE-STR-INST OPCODE MOVSB
  1907.     0A4 '   DWORD-STR-INST OPCODE MOVSD
  1908.    0A4 '    WORD-STR-INST OPCODE MOVSW
  1909.     0B6 '     MOVX-COMPILE OPCODE MOVZX
  1910.     04 '   GROUP3-COMPILE OPCODE MUL
  1911.      03 '   GROUP3-COMPILE OPCODE NEG
  1912.     90 '            1BYTE OPCODE NOP
  1913.      02 '   GROUP3-COMPILE OPCODE NOT
  1914.     01 '   GROUP1-COMPILE OPCODE OR
  1915.     0E6 '      I/O-COMPILE OPCODE OUT
  1916.     6E '         STR-INST OPCODE OUTS
  1917.      6E '    BYTE-STR-INST OPCODE OUTSB
  1918.     6E '   DWORD-STR-INST OPCODE OUTSD
  1919.      6E '    WORD-STR-INST OPCODE OUTSW
  1920.      0 '      POP-COMPILE OPCODE POP
  1921.     261 '   SIZE-COND-COMP OPCODE POPA
  1922.    361 '   SIZE-COND-COMP OPCODE POPAD
  1923.     29D '   SIZE-COND-COMP OPCODE POPF
  1924.    39D '   SIZE-COND-COMP OPCODE POPFD
  1925.       0 '     PUSH-COMPILE OPCODE PUSH
  1926.    260 '   SIZE-COND-COMP OPCODE PUSHA
  1927.     360 '   SIZE-COND-COMP OPCODE PUSHAD
  1928.    29C '   SIZE-COND-COMP OPCODE PUSHF
  1929.     39C '   SIZE-COND-COMP OPCODE PUSHFD
  1930.     02 '   GROUP2-COMPILE OPCODE RCL
  1931.      03 '   GROUP2-COMPILE OPCODE RCR
  1932.   320F '            2BYTE OPCODE RDMSR
  1933.    310F '            2BYTE OPCODE RDTSC
  1934.      0 '      RET-COMPILE OPCODE RET
  1935.       0 '     RETF-COMPILE OPCODE RETF
  1936.     00 '   GROUP2-COMPILE OPCODE ROL
  1937.      01 '   GROUP2-COMPILE OPCODE ROR
  1938.  0AA0F '            2BYTE OPCODE RSM
  1939.      9E '            1BYTE OPCODE SAHF
  1940.     04 '   GROUP2-COMPILE OPCODE SAL
  1941.      07 '   GROUP2-COMPILE OPCODE SAR
  1942.     03 '   GROUP1-COMPILE OPCODE SBB
  1943.     0AE '         STR-INST OPCODE SCAS
  1944.    0AE '    BYTE-STR-INST OPCODE SCASB
  1945.     0AE '   DWORD-STR-INST OPCODE SCASD
  1946.    0AE '    WORD-STR-INST OPCODE SCASW
  1947.      97 '    SETCC-COMPILE OPCODE SETA
  1948.     93 '    SETCC-COMPILE OPCODE SETAE
  1949.      92 '    SETCC-COMPILE OPCODE SETB
  1950.     96 '    SETCC-COMPILE OPCODE SETBE
  1951.      92 '    SETCC-COMPILE OPCODE SETC
  1952.     94 '    SETCC-COMPILE OPCODE SETE
  1953.      9F '    SETCC-COMPILE OPCODE SETG
  1954.     9D '    SETCC-COMPILE OPCODE SETGE
  1955.      9C '    SETCC-COMPILE OPCODE SETL
  1956.     9E '    SETCC-COMPILE OPCODE SETLE
  1957.      96 '    SETCC-COMPILE OPCODE SETNA
  1958.     92 '    SETCC-COMPILE OPCODE SETNAE
  1959.      93 '    SETCC-COMPILE OPCODE SETNB
  1960.     97 '    SETCC-COMPILE OPCODE SETNBE
  1961.      93 '    SETCC-COMPILE OPCODE SETNC
  1962.     95 '    SETCC-COMPILE OPCODE SETNE
  1963.      9E '    SETCC-COMPILE OPCODE SETNG
  1964.     9C '    SETCC-COMPILE OPCODE SETNGE
  1965.      9D '    SETCC-COMPILE OPCODE SETNL
  1966.     9F '    SETCC-COMPILE OPCODE SETNLE
  1967.      91 '    SETCC-COMPILE OPCODE SETNO
  1968.     9B '    SETCC-COMPILE OPCODE SETNP
  1969.      99 '    SETCC-COMPILE OPCODE SETNS
  1970.     95 '    SETCC-COMPILE OPCODE SETNZ
  1971.      90 '    SETCC-COMPILE OPCODE SETO
  1972.     9A '    SETCC-COMPILE OPCODE SETP
  1973.      9A '    SETCC-COMPILE OPCODE SETPE
  1974.     9B '    SETCC-COMPILE OPCODE SETPO
  1975.      98 '    SETCC-COMPILE OPCODE SETS
  1976.     94 '    SETCC-COMPILE OPCODE SETZ
  1977.     100 ' GROUP6&7-COMPILE OPCODE SGDT
  1978.     04 '   GROUP2-COMPILE OPCODE SHL
  1979.     0A4 '     DOUBLE-SHIFT OPCODE SHLD
  1980.     05 '   GROUP2-COMPILE OPCODE SHR
  1981.     0AC '     DOUBLE-SHIFT OPCODE SHRD
  1982.    101 ' GROUP6&7-COMPILE OPCODE SIDT
  1983.      00 ' GROUP6&7-COMPILE OPCODE SLDT
  1984.    104 ' GROUP6&7-COMPILE OPCODE SMSW
  1985.     0F9 '            1BYTE OPCODE STC
  1986.    0FD '            1BYTE OPCODE STD
  1987.     0FB '            1BYTE OPCODE STI
  1988.    0AA '         STR-INST OPCODE STOS
  1989.     0AA '    BYTE-STR-INST OPCODE STOSB
  1990.    0AA '   DWORD-STR-INST OPCODE STOSD
  1991.     0AA '    WORD-STR-INST OPCODE STOSW
  1992.     01 ' GROUP6&7-COMPILE OPCODE STR
  1993.      05 '   GROUP1-COMPILE OPCODE SUB
  1994.      0 '     TEST-COMPILE OPCODE TEST
  1995.      04 ' GROUP6&7-COMPILE OPCODE VERR
  1996.     05 ' GROUP6&7-COMPILE OPCODE VERW
  1997.      9B '            1BYTE OPCODE WAIT
  1998.   090F '            2BYTE OPCODE WBINVD
  1999.    300F '            2BYTE OPCODE WRMSR
  2000.    0C0 ' XCHG&ALU-COMPILE OPCODE XADD
  2001.      86 '     XCHG-COMPILE OPCODE XCHG
  2002.      0 '     XLAT-COMPILE OPCODE XLAT
  2003.       0 '    XLATB-COMPILE OPCODE XLATB
  2004.     06 '   GROUP1-COMPILE OPCODE XOR
  2005.  
  2006. ( CREATE CODE DEFINITIONS )
  2007. IN-HIDDEN
  2008. VARIABLE CURRENT-SV ( NEEDED FOR STASHING THE CURRENT VOCABULARY )
  2009. : SAVE-CURRENT ( SAVE THE CURRENT VOCABULARY LINKAGE )
  2010.         ( -- )
  2011.         CURRENT DATA-@ CURRENT-SV DATA-! ;
  2012.  
  2013. : UNSAVE-CURRENT ( RESET CURRENT-SV )
  2014.         ( -- )
  2015.         0 CURRENT-SV DATA-! ;
  2016.  
  2017. : RESTORE-CURRENT ( RESTORE CURRENT TO ITS PREVIOUSLY SAVED VALUE )
  2018.         ( -- )
  2019.         CURRENT-SV DATA-@ ?DUP IF CURRENT DATA-! UNSAVE-CURRENT THEN ;
  2020.  
  2021. ( DEBUGGING )
  2022. : RESET-ASM RESET-VARS CLR-OPSTACK LOC-INIT SAVE-DEPTH ;
  2023.  
  2024. IN-ASM
  2025. : INIT-ASM ( INITALIZE ASSEMBLY )
  2026.         ( -- )
  2027.         ALSO ASSEMBLER RESET-ASM ;
  2028.  
  2029. ( FORTH HEADER CREATION WORDS )
  2030. IN-HIDDEN
  2031. : _CODE ( START A NATIVE CODE DEFINITION )
  2032.         CODE-HEADER CODE-HERE CELL+ CODE-D, HIDE !CSP INIT-ASM ;
  2033.  
  2034. : _;CODE ( CREATE THE [;CODE] PART OF A LOW LEVEL DEFINING WORD )
  2035.         ?CSP !CSP COMPILE (;CODE) POSTPONE [ INIT-ASM ;
  2036.  
  2037. IN-FORTH
  2038. DEFER CODE ' _CODE IS CODE
  2039. DEFER ;CODE ' _;CODE IS ;CODE
  2040. ALSO FORTH IMMEDIATE PREVIOUS ( NECESSARY BECAUSE OF ASM-HIDDEN IMMEDIATE )
  2041.  
  2042. : SUBR: ( CREATE A SUBROUTINE IN THE ASSEMBLER VOCABULARY )
  2043.         SAVE-CURRENT INIT-ASM DEFINITIONS !CSP CREATE HIDE DATA-HERE 0
  2044.         DATA-, CODE-ALIGN CODE-HERE SWAP DATA-! DOES> DATA-@ ;
  2045.  
  2046. : MACRO: ( CREATE A MACRO IN THE ASSEMBLER VOCABULARY )
  2047.         SAVE-CURRENT ALSO ASSEMBLER DEFINITIONS : POSTPONE ENTER-MACRO ;
  2048.  
  2049. ( END CODE DEFINITIONS )
  2050. IN-ASM
  2051. : END-ASM A; PREVIOUS ;
  2052.  
  2053. IN-HIDDEN
  2054. : _END-CODE ( END A CODE DEFINITION )
  2055.         END-ASM ?FINISHED ?UNRES ?CSP REVEAL RESTORE-CURRENT CODE-ALIGN
  2056.         EXIT-ASSEMBLER ;
  2057.  
  2058. IN-ASM
  2059. DEFER END-CODE ' _END-CODE IS END-CODE
  2060. DEFER       ;C ' _END-CODE IS       ;C
  2061.  
  2062. : ENDM ( END A MACRO DEFINITION )
  2063.         POSTPONE LEAVE-MACRO POSTPONE ; PREVIOUS RESTORE-CURRENT ;
  2064.  
  2065.  
  2066. ALSO FORTH IMMEDIATE PREVIOUS
  2067.  
  2068. : ;MACRO ( END A MACRO DEFINITION )
  2069.         POSTPONE ENDM ; ALSO FORTH IMMEDIATE PREVIOUS
  2070.  
  2071. \ : EXIT ( REDEFINE EXIT TO TAKE CARE OF MACROS )
  2072. \        IN-MACRO? IF LEAVE-MACRO THEN R> DROP ;
  2073. ( REDEFINE EXIT TO BE CLOSER TO STANDARD )
  2074. : ?LEAVE-MACRO ( CONDITIONALLY UNNEST A MACRO )
  2075.         IN-MACRO? IF LEAVE-MACRO THEN ;
  2076.  
  2077. : EXIT ( REDEFINE EXIT TO TAKE CARE OF MACROS )
  2078.         STATE @ IF POSTPONE ?LEAVE-MACRO POSTPONE EXIT ELSE
  2079.         ?LEAVE-MACRO EXIT THEN ; ALSO FORTH IMMEDIATE PREVIOUS
  2080.  
  2081. ( UTILITY WORDS )
  2082. : PREFIX? ( ARE WE IN PREFIX MODE? )
  2083.         ( -- FLAG )
  2084.         DEFER@ SAVE-INST ['] NOOP = ;
  2085.  
  2086. : POSTFIX? ( ARE WE IN POSTFIX MODE? )
  2087.        ( -- FLAG )
  2088.        PREFIX? 0= ;
  2089.  
  2090. ( SETTING AND RESTORING THE ASSEMBLER SYNTAX )
  2091. : SET-POSTFIX ( SET THE ASSEMBLER TO POSTFIX MODE, LEAVE A MODE FLAG )
  2092.        ( -- PREV. MODE==PREFIX )
  2093.        PREFIX? DUP IF >R A; POSTFIX R> THEN ;
  2094.  
  2095. : SET-PREFIX ( SET THE ASSEMBLER TO PREFIX MODE, LEAVE A MODE FLAG )
  2096.        ( -- PREV. MODE==PREFIX )
  2097.        PREFIX? DUP 0= IF >R A; PREFIX R> THEN ;
  2098.  
  2099. : RESET-SYNTAX ( RESET THE ASSEMBLER TO THE PREVIOUSLY FLAGGED SYNTAX )
  2100.        ( PREV. MODE==PREFIX -- )
  2101.        IF A; PREFIX ELSE A; POSTFIX THEN ;
  2102.  
  2103. ONLY FORTH DEFINITIONS BASE !
  2104.