home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / pasm.seq < prev    next >
Text File  |  1990-05-28  |  33KB  |  950 lines
  1. \ PASM.SEQ    PREFIX & POSTFIX assembler by Robert L. Smith & Tom Zimmer
  2.  
  3. comment:
  4.  
  5.   An assembler for the 8086/8088, with both Prefix and Postfix syntax.
  6.  
  7.   PASM defaults to Prefix notation, but can be switched to F83 style
  8. Postfix notation with the word POSTFIX. To revert back to Prefix notation,
  9. use PREFIX.
  10.  
  11.   See the file ASSEM.TXT for a further description of the syntax.
  12.  
  13. comment;
  14.  
  15. 0 VALUE ?LISTING
  16. 0 VALUE LRUNSAVE
  17. 0 VALUE LINESTRT
  18. DEFER LIHERE    ' HERE IS LIHERE
  19. DEFER LIC@      ' C@   IS LIC@
  20.  
  21. : <LRUN>        ( -- )
  22.                 LIHERE =: LINESTRT
  23.                 <RUN>
  24.                 BASE @ >R HEX
  25.                 CR LINESTRT 4 U.R SPACE
  26.                 LIHERE
  27.                 IF      LINESTRT LIHERE OVER - 5 MIN BOUNDS
  28.                         ?DO     I LIC@ 0 <# # # BL HOLD #> TYPE
  29.                         LOOP
  30.                 THEN    22 #OUT @ - SPACES
  31.                 TIB #TIB @ TYPE
  32.                 R> BASE ! ;
  33.  
  34. : /LISTING      ( -- )
  35.                 ON> ?LISTING
  36.                 LRUNSAVE ABORT" Already LISTING!"
  37.                 @> RUN =: LRUNSAVE
  38.                 ['] <LRUN> IS RUN ;
  39.  
  40. : /NOLISTING    ( -- )
  41.                 OFF> ?LISTING
  42.                 LRUNSAVE IS RUN
  43.                 OFF> LRUNSAVE ;
  44.  
  45. DEFER .INST     ' NOOP IS .INST
  46.  
  47. \ The ASSEMBLER follows:
  48. ONLY FORTH ALSO ASSEMBLER DEFINITIONS ALSO
  49.  
  50. 2VARIABLE APRIOR  4 ALLOT
  51.  
  52.         ' DROP APRIOR ! ' DROP APRIOR 4 + !
  53.  
  54. : <A;!>         ( A1 A2 --- )           \ Set up assembly instruction
  55.                 APRIOR 4 + 2! ;         \ completion function
  56.  
  57. : <A;>          ( --- )
  58.                 APRIOR 2@ EXECUTE       \ perform assembly completion
  59.                 APRIOR 4 + 2@ APRIOR 2! \ SET UP FOR NEXT PREVIOUS
  60.                 ['] DROP APRIOR 4 + !   \ Make it not care if it is redone.
  61.                 .INST
  62. \                LIHERE =: LINESTRT
  63.                 ;
  64.  
  65. : <RUN-A;>      ( --- )                 \ make sure we complete instruction
  66.                 ?LISTING
  67.                 IF      LIHERE =: LINESTRT
  68.                         <RUN> <A;>
  69.                         BASE @ >R HEX
  70.                         CR LINESTRT 4 U.R SPACE
  71.                         LIHERE
  72.                         IF      LINESTRT LIHERE OVER - 5 MIN BOUNDS
  73.                                 ?DO     I LIC@ 0 <# # # BL HOLD #> TYPE
  74.                                 LOOP
  75.                         THEN    22 #OUT @ - SPACES
  76.                         TIB #TIB @ TYPE
  77.                         R> BASE !
  78.                 ELSE    <RUN> <A;>      \ at the end of each line.
  79.                 THEN    ;
  80.  
  81. VARIABLE POSTVAR                        \ is this post fix notation?
  82.  
  83. FORTH DEFINITIONS
  84.  
  85. DEFER A;!       ' <A;!>    IS A;!
  86. DEFER A;        ' <A;>     IS A;
  87. DEFER RUN-A;    ' <RUN-A;> IS RUN-A;
  88.  
  89. : PREFIX        ( --- )
  90.                 ['] <A;!>    IS A;!
  91.                 ['] <A;>     IS A;
  92.                 ['] <RUN-A;> IS RUN-A;  POSTVAR OFF ;
  93.  
  94. : POSTFIX       ( --- )
  95.                 ['] EXECUTE  IS A;!
  96.                 ['] NOOP     IS A;
  97.                 ['] <RUN>    IS RUN-A;  POSTVAR ON ;
  98.  
  99. PREFIX          \ Default is PREFIX assembler.
  100.  
  101. : >PRE          2R> POSTVAR @ >R 2>R PREFIX ;    \ SAVE AND SET PREFIX
  102.  
  103. : PRE>          2R> R> IF POSTFIX THEN 2>R ;     \ RESTORE PREVIOUS FIX
  104.  
  105. ASSEMBLER DEFINITIONS
  106.  
  107. DEFER C,        FORTH ' C,      ASSEMBLER IS C,
  108. DEFER ,         FORTH ' ,       ASSEMBLER IS ,
  109. DEFER HERE      FORTH ' HERE    ASSEMBLER IS HERE       ' HERE IS LIHERE
  110. DEFER TC!       FORTH ' C!      ASSEMBLER IS TC!
  111. DEFER TC@       FORTH ' C@      ASSEMBLER IS TC@        ' TC@  IS LIC@
  112. DEFER T!        FORTH ' !       ASSEMBLER IS T!
  113.  
  114. DEFER ?>MARK
  115. DEFER ?>RESOLVE
  116. DEFER ?<MARK
  117. DEFER ?<RESOLVE
  118.  
  119. comment:
  120.  
  121.         The assembler contains the following routines for labels,
  122.         with +/- 127 byte offsets. They are used as follows:
  123.  
  124.                 CLEAR_LABELS    \ Reset label mechanism
  125.  
  126.                 SUB AX, AX
  127.                 JNE 2 $         \ Jump on not equal to label # 2
  128.                 ...
  129.                 ...             \ You can have up to 127 bytes between
  130.                 ...
  131.            2 $: MOV AX, BX      \ Destination of labeled jump.
  132.  
  133.         A total of 32 short labels are currently supported.
  134.  
  135.         The assembler also supports ONE long label.
  136.  
  137.         Use L$ as follows:      \ Usable with JMP or CALL
  138.  
  139.                 JMP L$          \ Does a long jump to L$:
  140.                 ...
  141.                 ...             \ A bunch of bytes occur between these
  142.                 ...             \ instructions
  143.                 ...
  144.             L$: MOV X, X        \ Destination of long jump
  145. comment;
  146.  
  147. \ =========================================================
  148. \               BEGIN LOCAL LABELS SECTION:
  149. \ =========================================================
  150.  
  151. \ "max-llabs" defines the maximum number of local labels
  152. \ allowed (per CODE word or LABEL word).  The labels may be
  153. \ any of the values 0, 1, ..., (max-llabs - 1)
  154.  
  155. $20 value max-llabs
  156.   5 value b/llab
  157. false value ll-global?     \ are local labels available globally?
  158.  
  159. \ The local label table consists of one line per entry.
  160. \ Each line consists of:
  161. \
  162. \     1.  The label dictionary location,  ( 2 bytes)
  163. \
  164. \     2.  a pointer to the location of the first forward
  165. \         reference (if any), and         ( 2 bytes)
  166. \
  167. \     3.  an "ever referenced?" flag.     ( 1 byte )
  168.  
  169. create %llab[] max-llabs b/llab * allot
  170.  
  171. %llab[] value llab[]            \ default to %llab[] array
  172.  
  173. \ This flag is set if local labels are ever used (i.e., the
  174. \ "$" or the "$:" word is used within a CODE word or a LABEL
  175. \ word).  The idea is simply to add a smidgen more time to the
  176. \ "$" and "$:" words to save time later when checking for
  177. \ local label errors when END-CODE is called.
  178.  
  179. false value ll-used?
  180.  
  181. : llab-init  ( -- )     \ initializes local labels
  182.   llab[]  max-llabs b/llab * erase
  183.   false !> ll-used? ;
  184.  
  185. \ Given a label number, returns pointer to line in table.
  186. \ Aborts if label out of range.
  187. : llab>line  ( n -- ^line )
  188.   dup max-llabs 1- u> abort" Bad Label"
  189.   b/llab * llab[] + ;
  190.  
  191. \ Translates a label reference to the appropriate dictionary
  192. \ location and sets the "ever referenced?" flag.
  193. \
  194. \ If the reference is a forward reference, then a linked list
  195. \ of the forward references themselves is built using the
  196. \ dictionary byte locations where the jump offsets are
  197. \ "compiled".  The reason for using this technique at all is
  198. \ that it allows an arbitrary number of forward references per
  199. \ label to be made (within the jump offset limitations of
  200. \ course) and that it requires table space only for the linked
  201. \ list head pointer.  The technique is eloquent if convoluted
  202. \ and, as a minimum, needs explanation.
  203.  
  204. : $  ( n1 -- n2 )
  205.   true !> ll-used?          \ set "labels used?" flag
  206.   llab>line 1 over 4 + c!   \ set "ever referenced?" flag
  207.   dup @ IF      \ if the label is already defined:
  208.     @           \   then return it for resolution
  209.   ELSE          \ otherwise:
  210.     2+          \   move to head of list pointer
  211.     dup @ >r    \   save old head of list on rstack
  212.     here swap ! \   set new head of list
  213.     r>          \   retrieve old head of list
  214.     dup 0= IF   \   if list is empty:
  215.       here +    \     pass current dictionary location
  216.     THEN        \   end-if
  217.   THEN ;        \ end-if
  218.  
  219. \ Resolves all local label forward references for a given
  220. \ label.
  221.  
  222. : >res  ( ^line -- )
  223.   2+ @ dup 0= IF    \ if nothing to resolve
  224.     drop exit       \   then exit
  225.   THEN
  226.   1+ BEGIN          \ stack contains directory address of
  227.                     \   displacement to be resolved
  228.     dup TC@ >r       \ save link for now
  229.     here over - 1-  \ calculate displacement
  230.     dup $7f > abort" Branch out of range"
  231.     over TC!         \   and put in jump instruction
  232.     r>              \ now ready for next link
  233.     $fe over <> WHILE   \ $fe value signifies end of list
  234.     $ff00 or        \ sign extend since link is backward
  235.     + 2+            \ now move to next item on list
  236.   REPEAT 2drop ;
  237.  
  238. : $:f  ( n -- )     \ defines a local label
  239.   true !> ll-used?  \ set "labels used?" flag
  240.   llab>line
  241.   dup @ 0<> abort" Label can't be multiply defined"
  242.   dup >res          \ resolve forward references if needed
  243.   here swap ! ;     \ and set label for subsequent refs
  244.  
  245. : $:  ( n -- )      \ allow use as prefix/postfix
  246.   ['] $:f a;! a; ;
  247.  
  248. : _ll-errs?  ( -- )  \ final error checking for local labels
  249.   false max-llabs 0 DO  \ check each label
  250.     i b/llab * llab[] +
  251.     dup 4 + c@ 0<> IF   \ if jumps to label
  252.       @ 0= IF           \   and no label to jump to
  253.         cr ." jump(s) to label " i .
  254.           ." and label not defined"
  255.         drop true       \ set error flag
  256.       THEN
  257.     ELSE                \ if no jumps to label
  258.       @ 0<> IF          \   and label defined
  259.         cr ." warning - label " i .
  260.            ." defined, but no jumps to it"
  261.       THEN
  262.     THEN
  263.   LOOP
  264.   IF abort THEN ;       \ abort if fatal error
  265.  
  266. : ll-errs?  ( -- )      \ final error checking for local labels
  267.   ll-used? IF _ll-errs? THEN ;
  268.  
  269. \ =========================================================
  270. \                END LOCAL LABELS SECTION:
  271. \ =========================================================
  272.  
  273. : L$            ( --- a1 )              \ Pass a1 to L$:
  274.                 0 A; HERE ;
  275.  
  276. : L$:           ( a1 --- )              \ a1 = addr passed by L$
  277.                 A; HERE OVER - SWAP 2- T! ;
  278.  
  279. \ End of Local Label definitions
  280.  
  281. FORTH DEFINITIONS
  282.  
  283. ' <RUN> VALUE ARUNSAVE
  284.  
  285. : DOASSEM       ( --- )
  286.                 @> RUN =: ARUNSAVE
  287.                   ['] RUN-A; IS RUN
  288.                 0 ['] DROP A;!
  289.                 APRIOR 4 + 2@ APRIOR 2!
  290.                 LIHERE =: LINESTRT
  291.                 ll-global? 0=
  292.                 if      llab-init               \ in case labels used
  293.                 then
  294.                 ALSO ASSEMBLER ;
  295.  
  296. ' DOASSEM IS SETASSEM
  297.  
  298. ' LLAB-INIT ALIAS CLEAR_LABELS
  299.  
  300. : LOCAL_REF     ( --- )
  301.                 OFF> LL-GLOBAL? ;       LOCAL_REF
  302.                                         \ default to LOCAL references only
  303.  
  304. : GLOBAL_REF    ( --- )
  305.                 ON> LL-GLOBAL? ;
  306.  
  307. : LABEL         ( NAME --- )            \ Really just a constant addr
  308.                 SETASSEM CREATE ;
  309.  
  310. : CODE          ( NAME --- )
  311.                 LABEL -3 DP +! HIDE ;
  312.  
  313. ASSEMBLER DEFINITIONS
  314.  
  315. : END-CODE
  316.                 ll-global? 0=
  317.                 if      ll-errs?        \ check for local label errors
  318.                 then
  319.                 ARUNSAVE IS RUN
  320.                 PREVIOUS A; REVEAL ;
  321.  
  322. ' END-CODE ALIAS C;
  323.  
  324. headerless
  325.  
  326. \ 8088 Assembler, based on Ray Duncan's Dr. Dobb's article.
  327.  
  328. : ERROR3        ( --- )
  329.                 ['] DROP APRIOR 4 + !   \ Make it not care if it is redone.
  330.                 TRUE ABORT"  Illegal Operand "  ;
  331.  
  332. : ?ORDERERROR   ( F1 --- )
  333.                 IF      ['] DROP APRIOR 4 + !
  334.                         TRUE ABORT" Wrong Operand Order! "
  335.                 THEN    ;
  336.  
  337.  
  338. VARIABLE <TD>  VARIABLE <TS>   VARIABLE <RD>   VARIABLE <RS>
  339. VARIABLE <W>   VARIABLE <WD>   VARIABLE <OD>   VARIABLE <OS>   VARIABLE <D>
  340. VARIABLE <FR>  VARIABLE <AO>   VARIABLE <ND>   VARIABLE <DST>
  341. VARIABLE <SST> VARIABLE <WS>   VARIABLE <ID>
  342.  
  343. : D>S           ( --- )                 \ Move destination to source.
  344.                 <TD> @ <TS> !
  345.                 <RD> @ <RS> !
  346.                 <OD> @ <OS> ! ;
  347.  
  348. : ?D>S          ( --- )                 \ Move Dest to Src if postfix
  349.                 <TS> @ 0=               \ If no source specified
  350.                 POSTVAR @ 0<> AND       \ and we are in postfix mode
  351.                 IF      D>S             \ Move destination to source
  352.                 THEN    ;
  353.  
  354. : ?D><S         ( --- )                 \ If no destinatiion specified
  355.                 <DST> @                 \ yet, then swap source and dest.
  356.                 IF      <TD> <TS> 2DUP @ SWAP @ ROT ! SWAP !
  357.                         <RD> <RS> 2DUP @ SWAP @ ROT ! SWAP !
  358.                         <OD> <OS> 2DUP @ SWAP @ ROT ! SWAP !
  359.                 THEN    <DST> OFF ;
  360.  
  361. : <SREG>        ( A1 --- )
  362.                 POSTVAR @
  363.                 IF      <DST> OFF       \ Only reset dest if postfix
  364.                 THEN    <SST> ON
  365.                 DUP C@ DUP $0FF = IF DROP ELSE DUP <W> ! <WS> ! THEN
  366.                 1+ DUP C@ <TS> !
  367.                 1+ C@ <RS> !  <TS> @ 4 = IF <OS> ! THEN ;
  368.  
  369. : <DREG>        ( A1 --- )
  370.                 <DST> ON
  371.                 DUP C@ DUP $0FF = IF DROP ELSE DUP <W> !  <WD> ! THEN
  372.                 1+ DUP C@ <TD> !  1+ C@ <RD> !
  373.                 <TD> @ 4 = IF <OD> ! THEN ;
  374.  
  375. HEADERS         \ 05/28/90 21:20:16.87 TJZ
  376.  
  377. \ Destination Register processing.
  378.  
  379. : DREG          CREATE C, C, C, DOES> POSTVAR @
  380.                 IF      <SREG>
  381.                 ELSE    <DREG>
  382.                 THEN    ;
  383.  
  384. \ Source Register processing.
  385.  
  386. : SREG          CREATE C, C, C, DOES> POSTVAR @
  387.                 IF      <SST> @ IF <DREG> ELSE <SREG> THEN
  388.                 ELSE    <SREG>
  389.                 THEN    ;
  390.  
  391. \ Source Register Definitions
  392.  
  393. \    Reg  Type W        Name    Reg  Type W        Name
  394.      0    2    0  SREG  AL      0    3    1  SREG  AX
  395.      1    2    0  SREG  CL      1    3    1  SREG  CX
  396.      2    2    0  SREG  DL      2    3    1  SREG  DX
  397.      3    2    0  SREG  BL      3    3    1  SREG  BX
  398.      4    2    0  SREG  AH      4    3    1  SREG  SP
  399.      5    2    0  SREG  CH      5    3    1  SREG  BP   ' BP ALIAS RP
  400.      6    2    0  SREG  DH      6    3    1  SREG  SI   ' SI ALIAS IP
  401.      7    2    0  SREG  BH      7    3    1  SREG  DI
  402.  
  403.  
  404.      0    4    -1 SREG  [BX+SI]         ' [BX+SI]  ALIAS [SI+BX]
  405.                                         ' [BX+SI]  ALIAS [BX+IP]
  406.                                         ' [BX+SI]  ALIAS [IP+BX]
  407.      1    4    -1 SREG  [BX+DI]         ' [BX+DI]  ALIAS [DI+BX]
  408.      2    4    -1 SREG  [BP+SI]         ' [BP+SI]  ALIAS [SI+BP]
  409.                                         ' [BP+SI]  ALIAS [BP+IP]
  410.                                         ' [BP+SI]  ALIAS [IP+BP]
  411.                                         ' [BP+SI]  ALIAS [RP+IP]
  412.                                         ' [BP+SI]  ALIAS [IP+RP]
  413.                                         ' [BP+SI]  ALIAS [RP+SI]
  414.                                         ' [BP+SI]  ALIAS [SI+RP]
  415.      3    4    -1 SREG  [BP+DI]         ' [BP+DI]  ALIAS [DI+BP]
  416.                                         ' [BP+DI]  ALIAS [DI+RP]
  417.                                         ' [BP+DI]  ALIAS [RP+DI]
  418.      4    4    -1 SREG  [SI]            ' [SI] ALIAS [IP]
  419.      5    4    -1 SREG  [DI]
  420.      6    4    -1 SREG  [BP]            ' [BP] ALIAS [RP]
  421.      7    4    -1 SREG  [BX]
  422.  
  423.      0    5    -1 SREG  ES
  424.      1    5    -1 SREG  CS
  425.      2    5    -1 SREG  SS
  426.      3    5    -1 SREG  DS
  427.                                                       
  428. \ Destination Register Definitions                    
  429.  
  430.      0    5    -1 DREG  ES,
  431.      1    5    -1 DREG  CS,
  432.      2    5    -1 DREG  SS,
  433.      3    5    -1 DREG  DS,
  434.                                                  
  435.      0    2    0  DREG  AL,
  436.      1    2    0  DREG  CL,
  437.      2    2    0  DREG  DL,
  438.      3    2    0  DREG  BL,
  439.      4    2    0  DREG  AH,
  440.      5    2    0  DREG  CH,
  441.      6    2    0  DREG  DH,
  442.      7    2    0  DREG  BH,
  443.  
  444.      0    3    1  DREG  AX,
  445.      1    3    1  DREG  CX,
  446.      2    3    1  DREG  DX,
  447.      3    3    1  DREG  BX,
  448.      4    3    1  DREG  SP,
  449.      5    3    1  DREG  BP,             ' BP, ALIAS RP,
  450.      6    3    1  DREG  SI,             ' SI, ALIAS IP,
  451.      7    3    1  DREG  DI,
  452.  
  453.      0    4    -1 DREG  [BX+SI],        ' [BX+SI], ALIAS [SI+BX],
  454.                                         ' [BX+SI], ALIAS [BX+IP],
  455.                                         ' [BX+SI], ALIAS [IP+BX],
  456.      1    4    -1 DREG  [BX+DI],        ' [BX+DI], ALIAS [DI+BX],
  457.      2    4    -1 DREG  [BP+SI],        ' [BP+SI], ALIAS [SI+BP],
  458.                                         ' [BP+SI], ALIAS [BP+IP],
  459.                                         ' [BP+SI], ALIAS [IP+BP],
  460.                                         ' [BP+SI], ALIAS [RP+SI],
  461.                                         ' [BP+SI], ALIAS [SI+RP],
  462.                                         ' [BP+SI], ALIAS [RP+IP],
  463.                                         ' [BP+SI], ALIAS [IP+RP],
  464.      3    4    -1 DREG  [BP+DI],        ' [BP+DI], ALIAS [DI+BP],
  465.                                         ' [BP+DI], ALIAS [DI+RP],
  466.                                         ' [BP+DI], ALIAS [RP+DI],
  467.      4    4    -1 DREG  [SI],           '    [SI], ALIAS [IP],
  468.      5    4    -1 DREG  [DI],
  469.      6    4    -1 DREG  [BP],           '    [BP], ALIAS [RP],
  470.      7    4    -1 DREG  [BX],
  471.  
  472. \ Miscellaneous Operators
  473. : TS@     <TS> @ ;
  474. : TD@     <TD> @ ;
  475. : RD@     <RD> @ ;
  476. : RS@     <RS> @ ;
  477.  
  478. HEADERLESS      \ 05/28/90 21:20:52.57 TJZ
  479.  
  480. : +D      <D> @ 2* + ;
  481. : +W      <W> @ + ;
  482. : +RD     <RD> @ + ;
  483. : +RS     <RS> @ + ;
  484. : MOD1    $03F AND $040 OR ;
  485. : MOD2    $03F AND $080 OR ;
  486. : MOD3    $03F AND $0C0 OR ;
  487. : RS0    <RS> @ 8 * ;
  488. : RSD    RS0 +RD ;
  489. : MD,    RS0 6 + C, ;
  490. : MS,    RD@ 8 * 6 + C, ;
  491. : RDS    RD@ 8 * +RS ;
  492. : CXD,   C@ MOD3 +RD C, ;
  493. : CXS,   C@ MOD3 +RS C, ;
  494.  
  495. \ Equates to Addressing Modes
  496.  
  497. 0 CONSTANT DIRECT       1 CONSTANT IMMED     2 CONSTANT REG8
  498. 3 CONSTANT REG16        4 CONSTANT INDEXED   5 CONSTANT SEGREG
  499.  
  500. \ Initialize all variables and flags
  501.  
  502. headers
  503.  
  504. : RESET   0 <W> !   0 <OS> !  0 <RD> !
  505.           0 <TD> !  0 <TS> !  0 <OD> !
  506.           0 <D> !   0 <WD> !  0 <RS> !  0 <FR> !  0 <ND> !
  507.           0 <DST> ! 0 <SST> ! 0 <WS> !  0 <ID> !  ;
  508.  
  509. headerless
  510.  
  511. : REG?     REG8 OVER = SWAP REG16 = OR ;
  512.  
  513. : DREG?   TD@ REG? ;
  514.  
  515. : ADREG?  DREG? RD@ ( 3 AND ) 0= AND ;
  516.  
  517. : ASREG?  TS@ REG? RS@ ( 3 AND ) 0= AND ;
  518.  
  519. : SUBREG  C@ $038 AND ;
  520.  
  521. \ Init. Direction Pointer
  522.  
  523. : DSET    TS@ DUP INDEXED = SWAP DIRECT = OR NEGATE <D> ! ;
  524.  
  525. : DT      1 <D> ! ;    \ Set Direction Flag True.
  526.  
  527. : OFFSET8,     HERE 1+ - DUP ABS OVER 0< + $07F >
  528.                ABORT"  Address out of range "  C, ;
  529.  
  530. : OFFSET16,    HERE 2+ - , ;
  531.  
  532. \ Calculate and store displacement for MEM/REG Instructions.
  533.  
  534. : DISP,   <D> @ IF <OS> ELSE <OD> THEN @ DUP
  535.                 IF DUP ABS $07F > IF SWAP MOD2 C, , ELSE SWAP MOD1 C, C, THEN
  536.                 ELSE DROP DUP 7 AND 6 = IF MOD1 C, 0 THEN C, THEN ;
  537.  
  538. HEADERS         \ 05/28/90 21:21:36.34 TJZ
  539.  
  540. \ Calculate the M/R 2nd operator byte
  541.  
  542. : M/RS,   $038 AND TS@
  543.           CASE DIRECT  OF 6 + C, ,                   ENDOF
  544.              REG8    OF $0C0 + +RS C,                ENDOF
  545.              REG16   OF $0C0 + +RS C,                ENDOF
  546.              INDEXED OF <OS> @ 0= RS@ 6 <> AND
  547.                         IF      +RS C,
  548.                         ELSE    <OS> @ $080 + $0100 U<
  549.                                 IF     $040 + +RS C, <OS> @ C,
  550.                                 ELSE   $080 + +RS C, <OS> @ ,
  551.                                 THEN
  552.                         THEN                         ENDOF
  553.                         ERROR3
  554.                         drop
  555.           ENDCASE ;
  556.  
  557. HEADERLESS      \ 05/28/90 21:21:52.99 TJZ
  558.  
  559. : M/RD,         ( ? --- ) D>S M/RS, ;
  560.  
  561. : 8/16,   <W> @ IF , ELSE C, THEN ;
  562.  
  563. \ Words to build the instructions:
  564.  
  565. : 1MIF          ( A1 --- )
  566.                 C@ C, RESET ;           \ Single Byte Inst.
  567.  
  568. : 1MI     CREATE C, DOES> ['] 1MIF A;! A; ;
  569.  
  570. : 1AMIF        ( A1 --- )               \ AX LODS or AX STOS
  571.                 C@ +W C, RESET ;           \ Single Byte Inst.
  572.  
  573. : 1AMI     CREATE C, DOES> ['] 1AMIF A;! A; ;
  574.  
  575. : 2MIF          ( A1 --- )
  576.                 C@ C, OFFSET8, RESET ;  \ Cond Jumps, Loops
  577.  
  578. : 2MI     CREATE C, DOES> ['] 2MIF A;! A; ;
  579.  
  580. : 3MI     CREATE C, DOES> C@ C, ;                       \ Segment Over-ride
  581.  
  582. : 4MIF          ( A1 --- )
  583.                 ?D>S TS@                \ Reg. Push and Pop
  584.           CASE
  585.                 SEGREG OF C@ RS@ 8 * + C,      ENDOF    \ SEGMENT
  586.                 REG16  OF 1+ C@ +RS C,         ENDOF    \ REGISTER
  587.                 REG8   OF ERROR3               ENDOF    \ 8 BIT ILLEGAL
  588.                           DROP 2+ C@ DUP C, $030 AND M/RS,
  589.           ENDCASE                                       \ MEMORY
  590.           RESET ;
  591.  
  592. : 4MI     CREATE C, C, C, DOES> ['] 4MIF A;! A; ;
  593.  
  594. : 5MIF          ( A1 --- )
  595.                 ?D>S TS@                        \ Iseg. Jump, Call
  596.           CASE DIRECT  OF   <ND> @
  597.                             IF   $0FF C, C@ <FR> @
  598.                                  IF  8 +  THEN  M/RS,
  599.                             ELSE <FR> @
  600.                                  IF  2+ C@ C, , ,
  601.                                  ELSE  OVER HERE 3 + - $080 + $0100 U<
  602.                                          OVER C@ $020 = AND
  603.                                          <WD> @ 0= AND
  604.                                          IF  DROP $0EB C, OFFSET8,
  605.                                          ELSE 1+ C@ C, OFFSET16,
  606.                                          THEN
  607.                                  THEN
  608.                             THEN                                ENDOF
  609.              REG16   OF     $0FF C, CXS,                        ENDOF
  610.              INDEXED OF     DSET $0FF C, C@ <FR> @
  611.                             IF  8 +  THEN  +RS DISP,            ENDOF
  612.              ERROR3  DROP
  613.           ENDCASE    RESET ;
  614.  
  615. : 5MI     CREATE C, C, C, DOES> ['] 5MIF A;! A; ;
  616.  
  617. : 6MIF          ( A1 --- )      \ IN and OUT
  618.                 DUP C@ 2 AND            \ IN or OUT?
  619.                 IF      <WS> @          \ This is an OUT
  620.                         ADREG? ?ORDERERROR
  621.                 ELSE    <WD> @          \ This is an IN
  622.                         ASREG? ?ORDERERROR
  623.                 THEN    SWAP <ID> @     \ WAS THERE IMMEDIATE DATA ?
  624.                 IF         C@ + ( +W ) C, C,
  625.                 ELSE    1+ C@ + ( +W ) C,
  626.                 THEN    RESET ;
  627.  
  628.  
  629. : 6MI     CREATE C, C, DOES> ['] 6MIF A;! A; ;
  630.  
  631. \ ADC, ADD, AND, etc.
  632.  
  633. : 7MIF          ( A1 --- )
  634.                 DUP 1+ C@ 1 AND <AO> !
  635.           TS@ IMMED =
  636.           IF ADREG?
  637.                IF 2+ C@ +W C, TD@ REG8 = IF C, ELSE , THEN
  638.                ELSE DUP 1+ C@ $0FE AND +W ROT >R  \ Save IMMEDiate data
  639.                     <AO> @
  640.                     <W> @ AND                     \  *** 07/22/88 10:07:40.64
  641.                     IF  R@ $080 + $0100 U<
  642.                          IF     2 OR C, C@ M/RD, R@ C,
  643.                          ELSE        C, C@ M/RD, R@ ,
  644.                          THEN
  645.                     ELSE             C, C@ M/RD, R@ 8/16,
  646.                     THEN   r>drop              \ Clean Return stack
  647.                THEN
  648.           ELSE C@ TS@ REG?
  649.                IF +W C, RS@ 8 * M/RD,
  650.                ELSE $084 OVER - IF 2 OR THEN +W C, TD@ REG?
  651.                     IF RD@ 8 * M/RS, ELSE ERROR3 THEN
  652.                THEN
  653.           THEN RESET ;
  654.  
  655. : 7MI     CREATE C, C, C, DOES> ['] 7MIF A;! A; ;
  656.  
  657. : 8MIF          ( A1 --- )
  658.                 ?D>S
  659.                 DUP 1+ C@ +W C, C@ M/RS, RESET ;
  660.  
  661. : 8MI     CREATE C, C, DOES> ['] 8MIF A;! A; ;
  662.  
  663. : 9MIF          ( A1 --- )
  664.                 <DST> @ 0=
  665.                 IF      1 <DST> ! ?D><S
  666.                         1 <TS> ! 1 <SST> !      \ : #  1 <TS> !  1 <SST> ! ;
  667.                         1 SWAP  <W> @ <WD> !
  668.                 ELSE    POSTVAR @               \ If postfix, reverse
  669.                         IF      ?D><S           \ the operands
  670.                                 <WS> @ <WD> !   \ Correct word mode
  671.                         THEN
  672.                 THEN
  673.                 DUP 1+ C@ <WD> @ +
  674.           TS@ 1 > IF 2+ C, ELSE C, NIP THEN  C@ M/RD, RESET ;
  675.  
  676. : 9MI           CREATE C, C, DOES> ['] 9MIF A;! A; ;
  677.  
  678. : 10MIF         ( A1 --- )
  679.                 DUP 1+ C@ C, C@ C, RESET ;
  680.  
  681. : 10MI          CREATE C, C, DOES> ['] 10MIF A;! A; ;
  682.  
  683. : 11MIF         ( A1 --- )
  684.                 ?D>S TS@ REG? <W> @ 0<> AND
  685.                 IF C@ +RS C, ELSE 1+ C@ $0FE +W C, M/RS, THEN RESET ;
  686.  
  687. : 11MI          CREATE C, C, DOES> ['] 11MIF A;! A; ;
  688.  
  689. : 12MIF         ( A1 --- )
  690.                 DROP                    \ MOV Instruction
  691.             TD@ SEGREG = IF $08E C,  RD@ 8 * M/RS,   ELSE
  692.             TS@ SEGREG = IF $08C C,  RS@ 8 * M/RD,   ELSE
  693.             TS@ IMMED = TD@ REG? AND
  694.                 IF $016 +W 8 * +RD C, 8/16,          ELSE
  695.             TS@ 0= TD@ 0= OR ADREG? ASREG? OR AND
  696.                 IF $0A0 +W TS@ IF 2+ THEN C, , ( 8/16, ) ELSE
  697.             TS@ IMMED =
  698.                 IF      postvar @
  699. \ *****  09/26/88 18:33:25.98  *******  ZIMMER ***********
  700.                         TD@ INDEXED <> AND
  701.                         if swap then
  702.                         $0C6 +W C, >R 0 M/RD, R> 8/16, ELSE
  703.             $088 +W TD@ REG?
  704.                         IF 2+ C, RD@ 8 * M/RS,      ELSE
  705.             TS@ REG? IF C, RS@ 8 * M/RD, ELSE ERROR3    THEN THEN THEN THEN
  706.                                                         THEN THEN THEN
  707.           RESET ;
  708.  
  709. : 12MI    CREATE DOES> ['] 12MIF A;! A; ;
  710.  
  711. : 13MIF         ( A1 --- )
  712.                 DROP    TS@ REG? TD@ REG? AND   \ Both are registers
  713.                         RS@ 0= RD@ 0= OR AND    \ Either register is AX
  714.                         <W> @ 1 = AND           \ And it is AX not AL.
  715.         IF      RS@ 0=
  716.                 IF      RD@
  717.                 ELSE    RS@
  718.                 THEN    $090 + C,
  719.         ELSE    $086 +W             \ XCHG Instruction
  720.           TS@ REG? 0=
  721.               IF TD@ REG? 0=
  722.                    IF   ERROR3
  723.                    ELSE C,
  724.                         RD@ 8 * M/RS,
  725.                    THEN
  726.               ELSE C, RS@ 8 * M/RD,
  727.               THEN
  728.         THEN    RESET ;
  729.  
  730. : 13MI    CREATE DOES> ['] 13MIF A;! A; ;
  731.  
  732. : 14MIF         ( A1 --- )
  733.                 C@ C, TD@ REG?
  734.               IF RD@ 8 * M/RS, ELSE ERROR3 THEN RESET ;
  735.  
  736. : 14MI    CREATE C, DOES> ['] 14MIF A;! A; ;
  737.  
  738. : 15MIF         ( A1 --- )
  739.                 DROP DUP 3 =
  740.           IF DROP $0CC C, ELSE $0CD C, C, THEN RESET ;
  741.  
  742. : 15MI    CREATE DOES> ['] 15MIF A;! A; ;
  743.  
  744. headers
  745.  
  746. \ Now let's create the actual instructions.
  747.  
  748. $37          1MI   AAA      $FC          1MI   CLD
  749. $D5 $0A     10MI   AAD      $FA          1MI   CLI
  750. $D4 $0A     10MI   AAM      $F5          1MI   CMC
  751. $3F          1MI   AAS      $3C $81 $38  7MI   CMP
  752. $14 $81 $10  7MI   ADC      $A6          1MI   CMPSB
  753. $04 $81 $00  7MI   ADD      $A7          1MI   CMPSW
  754. $24 $80 $20  7MI   AND      $99          1MI   CWD
  755. $9A $E8 $10  5MI   CALL     $27          1MI   DAA
  756. $98          1MI   CBW      $2F          1MI   DAS
  757. $F8          1MI   CLC      $08 $48     11MI   DEC
  758.  
  759. $F6 $30     8MI   DIV      $73        2MI   JAE
  760. $F4         1MI   HLT      $72        2MI   JB
  761. $F6 $38     8MI   IDIV     $76        2MI   JBE
  762. $F6 $28     8MI   IMUL     $72        2MI   JC
  763. $EC $E4     6MI   IN       $E3        2MI   JCXZ
  764. $00 $40    11MI   INC      $74        2MI   JE
  765.            15MI   INT      $7F        2MI   JG
  766. $CE         1MI   INTO     $7D        2MI   JGE
  767. $CF         1MI   IRET     $7C        2MI   JL
  768. $77         2MI   JA       $7E        2MI   JLE
  769.  
  770. $EA $E9 $20 5MI   JMP      $7F        2MI   JNLE
  771. $76         2MI   JNA      $71        2MI   JNO
  772. $72         2MI   JNAE     $7B        2MI   JNP
  773. $73         2MI   JNB      $79        2MI   JNS
  774. $77         2MI   JNBE     $75        2MI   JNZ
  775. $73         2MI   JNC      $70        2MI   JO
  776. $75         2MI   JNE      $7A        2MI   JP
  777. $7E         2MI   JNG      $7A        2MI   JPE
  778. $7C         2MI   JNGE     $7B        2MI   JPO
  779. $7D         2MI   JNL      $78        2MI   JS
  780.  
  781. $74        2MI   JZ       $E0        2MI   LOOPNE
  782. $9F        1MI   LAHF     $E0        2MI   LOOPNZ
  783. $C5       14MI   LDS      $E1        2MI   LOOPZ
  784. $8D       14MI   LEA                12MI   MOV
  785. $C4       14MI   LES      $A4        1MI   MOVSB
  786. $F0        1MI   LOCK     $A5        1MI   MOVSW  $A5      1MI   MOVS
  787. $AC        1MI   LODSB    $F6 $20    8MI   MUL    $AC      1AMI  LODS
  788. $AD        1MI   LODSW    $F6 $18    8MI   NEG
  789. $E2        2MI   LOOP     $90        1MI   NOP
  790. $E1        2MI   LOOPE    $F6 $10    8MI   NOT
  791.  
  792. $0C $80 $08 7MI  OR       $F2         1MI   REPNE
  793. $EE $E6     6MI  OUT      $F2         1MI   REPNZ
  794. $8F $58 $07 4MI  POP      $F3         1MI   REPZ
  795. $9D         1MI  POPF     $C3         1MI   RET
  796.                           $CB         1MI   RETF
  797. $FF $50 $06 4MI  PUSH     $D0 $00     9MI   ROL
  798. $9C         1MI  PUSHF    $D0 $08     9MI   ROR
  799. $D0 $10     9MI  RCL      $9E         1MI   SAHF
  800. $D0 $18     9MI  RCR      $D0 $38     9MI   SAR
  801. $F3         1MI  REP      $1C $81 $18 7MI   SBB
  802. $F3         1MI  REPE     $AE         1MI   SCASB
  803.  
  804. $AF        1MI   SCASW    $AB         1MI   STOSW  $AA    1AMI   STOS
  805. $D0 $20    9MI   SAL      $2C $81 $28 7MI   SUB
  806. $D0 $20    9MI   SHL      $A8 $F6 $84 7MI   TEST
  807. $D0 $28    9MI   SHR      $9B         1MI   WAIT
  808. $F9        1MI   STC                 13MI   XCHG
  809. $FD        1MI   STD      $D7         1MI   XLAT
  810. $FB        1MI   STI      $34 $80 $30 7MI   XOR
  811. $AA        1MI   STOSB    \               ESC
  812.  
  813. \ =========================================================
  814. \               BEGIN MNEMONIC JUMP SECTION:
  815. \ =========================================================
  816.  
  817. \ The jump mnemonics:
  818.  
  819. ' jmp  alias j          ( JMP  )
  820. ' jne  alias j0<>       ( JNE  )
  821. ' jz   alias j0=        ( JZ   )
  822. ' jns  alias j0>=       ( JNS  )
  823. ' js   alias j0<        ( JS   )
  824. ' jne  alias j<>        ( JNE  )
  825. ' jz   alias j=         ( JZ   )
  826. ' jnl  alias j>=        ( JNL  )
  827. ' jnge alias j<         ( JNGE )
  828. ' jnle alias j>         ( JNLE )
  829. ' jng  alias j<=        ( JNG  )
  830. ' jnc  alias ju>=       ( JNC  )
  831. ' jnae alias ju<        ( JNAE )
  832. ' jnbe alias ju>        ( JNBE )
  833. ' jna  alias ju<=       ( JNA  )
  834.  
  835. \ =========================================================
  836. \               END MNEMONIC JUMP SECTION:
  837. \ =========================================================
  838.  
  839. \ Segment over-ride commands:
  840. $26        3MI   ES:
  841. $2E        3MI   CS:
  842. $36        3MI   SS:
  843. $3E        3MI   DS:
  844.  
  845. : FAR     1 <FR> ! ;
  846.  
  847. : BYTE    0 <W> !   0 <WD> ! ;
  848.  
  849. : WORD    1 <W> !   1 <WD> ! ;
  850.  
  851. : #       1 <TS> ! -1 <SST> ! 1 <ID> ! ;
  852.  
  853. : #)      ( ?D><S ) -1 <SST> !   \ Swap source and dest if no dest spec'ed.
  854.           1 <W> ! ;                \ Default to word mode
  855.  
  856. : []      0 <W> !  1 <ND> ! ;
  857.  
  858. : 3*      DUP 2* + ;
  859.  
  860. \ MACROS for NEXT, 1PUSH, and 2PUSH.
  861.  
  862. VARIABLE INLN           \ Flag to determine if we are compiling IN_LINE next.
  863.  
  864. : INLINEON      INLN ON ;
  865. : INLINEOFF     INLN OFF ;      INLINEOFF       \ Default to NO INLINE NEXT.
  866.  
  867. : NEXT          ( -- )
  868.                 >PRE    INLN @
  869.                 IF      LODSW ES: JMP AX    A;
  870.                 ELSE              JMP >NEXT A;
  871.                 THEN    PRE> ;
  872.  
  873. : 1PUSH         ( -- )
  874.                 >PRE    INLN @
  875.                 IF      PUSH AX LODSW ES: JMP AX       A;
  876.                 ELSE                      JMP >NEXT 1- A;
  877.                 THEN    PRE> ;
  878.  
  879. : 2PUSH         ( -- )
  880.                 >PRE    INLN @
  881.                 IF      PUSH DX PUSH AX LODSW ES: JMP AX       A;
  882.                 ELSE                              JMP >NEXT 2- A;
  883.                 THEN    PRE> ;
  884.  
  885. headerless
  886.  
  887. : A?>MARK    ( -- f addr ) TRUE   HERE   0 C,   ;
  888. : A?>RESOLVE ( f addr -- ) HERE OVER 1+ - SWAP TC! ?CONDITION ;
  889. : A?<MARK    ( -- f addr ) TRUE   HERE   ;
  890. : A?<RESOLVE ( f addr -- ) HERE 1+ -  C,   ?CONDITION   ;
  891. ' A?>MARK    ASSEMBLER IS ?>MARK
  892. ' A?>RESOLVE ASSEMBLER IS ?>RESOLVE
  893. ' A?<MARK    ASSEMBLER IS ?<MARK
  894. ' A?<RESOLVE ASSEMBLER IS ?<RESOLVE
  895.  
  896. headers
  897.  
  898. $75 CONSTANT 0=   $74 CONSTANT 0<>   $79 CONSTANT 0<
  899. $78 CONSTANT 0>=  $7D CONSTANT <     $7C CONSTANT >=
  900. $7F CONSTANT <=   $7E CONSTANT >     $73 CONSTANT U<
  901. $72 CONSTANT U>=  $77 CONSTANT U<=   $76 CONSTANT U>
  902. $70 CONSTANT OV<> $71 CONSTANT OV    $E3 CONSTANT CX<>0
  903. $7B CONSTANT PE   $7A CONSTANT PO
  904.  
  905. \ : DO  ( n --- ) MOV CX # A; HERE ;
  906.  
  907. : BEGIN ( - a f ) A; ?<MARK ;
  908. : UNTIL ( a f n - ) >R A; R> C, ?<RESOLVE A; ;  \ ** ADDED A;
  909. : AGAIN ( a f - ) $0EB UNTIL ;
  910. : IF ( n - A f ) >R A; R> C, ?>MARK A; ;        \ ** ADDED A;
  911. : FORWARD ( - A f ) $0EB IF ;
  912. : THEN ( A f - ) A; ?>RESOLVE ;
  913. : AFT ( a f - a f A f ) 2DROP FORWARD BEGIN 2SWAP ;
  914. : ELSE ( A f - A f ) FORWARD 2SWAP THEN ;
  915. : REPEAT ( A f a f - ) A; AGAIN THEN ;
  916. : CONTINUE (  a f A f - a f ) 2OVER REPEAT ;
  917. : WHILE ( a f - A f a f ) IF 2SWAP ;
  918.  
  919.  
  920. FORTH DEFINITIONS
  921.  
  922. : INLINE        [COMPILE] [ SETASSEM HERE X, ; IMMEDIATE
  923.  
  924. ASSEMBLER DEFINITIONS
  925.  
  926. : END-INLINE    [ ASSEMBLER ] END-CODE ] ;
  927.  
  928. COMMENT:
  929.         \ Here is an example of how to use INLINE and END-INLINE to add
  930.         \ assembly code in the middle of a CODE definition.
  931.  
  932.         : TEST  ( --- )
  933.                 5 0
  934.                 DO I
  935.                         INLINE
  936.                                 pop ax
  937.                                 add ax, # 23
  938.                                 1push
  939.                         END-INLINE
  940.                         .
  941.                 LOOP ;
  942. COMMENT;
  943.  
  944. behead
  945.  
  946. ONLY FORTH DEFINITIONS ALSO
  947.  
  948. DECIMAL
  949.  
  950.