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