home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / kernel1.seq < prev    next >
Encoding:
Text File  |  1991-03-13  |  46.9 KB  |  1,325 lines
  1. \ KERNEL1.SEQ  Source code for KERNEL1.COM,   modified by Tom Zimmer
  2.  
  3. ONLY FORTH   META ALSO FORTH
  4.  
  5. TRUE    CONSTANT INLINE_NEXT    \ Enable Inline NEXT
  6.  
  7. DECIMAL
  8.  
  9. : ?.INLINE      ( --- )         \ Print state of INLINE_NEXT
  10.                 CR ." NEXT is currently " INLINE_NEXT >REV
  11.                 IF      [ASSEMBLER] INLINEON  [FORTH]
  12.                         ."  INLINE. "
  13.                 ELSE    [ASSEMBLER] INLINEOFF [FORTH]
  14.                         ."  NOT " >NORM ."  INLINE. "
  15.                 THEN    >NORM CR ;
  16. ?.INLINE
  17.  
  18.    256 DP-T !           \ Set Dictionary pointer
  19.      0 DP-X !           \ Set LIST DP
  20.  
  21. IN-META
  22.  
  23. : ]]   ]   ;
  24. : [[   [COMPILE] [   ; FORTH IMMEDIATE META
  25.  
  26. FORWARD: DEFINITIONS
  27. FORWARD: [
  28.  
  29. LABEL ORIGIN    JMP HERE 8000 + \ jump to cold start: will be patched
  30.                 JMP HERE 8000 + \ jump to warm start: will be patched
  31.                 END-CODE
  32.  
  33. LABEL DPUSH     PUSH DX         END-CODE
  34. LABEL APUSH     PUSH AX         END-CODE
  35. LABEL >NEXT     LODSW ES:
  36.                 JMP AX          END-CODE
  37.  
  38. \ Create the FORTH vocabulary as the first definition in dictionary.
  39.  
  40. HERE-T ,-Y                      \ valid "previous" CFA for "CREATE
  41.  
  42. HERE-Y HERE-T CNHASH !-Y        \ first entry in >NAME hash table
  43.  
  44. HERE-T DUP 100 + CURRENT-T !    \ harmless
  45.  
  46. HERE-Y VOCABULARY FORTH   FORTH DEFINITIONS
  47.  
  48. 0 OVER 2+ !-Y ( link )
  49.  
  50. 2+ SWAP  >BODY-T
  51. 'F'   2*                        \ Hash in First char shifted left one
  52. 'O' + 2*                        \ Plus second char, sum shifted left one
  53. 5 +                             \ Plus length byte
  54. #TTHREADS 1- AND 2*             \ Determine which thread FORTH goes in.
  55. + !-T                           \ store it in the proper thread.
  56.  
  57. IN-META
  58.  
  59. VOCABULARY FILES
  60.  
  61. FILES DEFINITIONS
  62.  
  63. \ Create the linked list of files that have been loaded.
  64.  
  65. VARIABLE META86.SEQ VARIABLE KERNEL1.SEQ
  66.  
  67. FORTH DEFINITIONS
  68.  
  69. VARIABLE XSEG
  70. VARIABLE YSEG
  71.  
  72. LABEL ABNORM    MOV AX, # $AD26          \ Value to restore in >NEXT
  73.                 MOV >NEXT AX            \ Restore it
  74.                 MOV AX, # $E0FF          \ Value to restore in >NEXT + 2
  75.                 MOV >NEXT 2+ AX         \ Restore it
  76.                 XOR AX, AX
  77.                 MOV DS, AX
  78.                 MOV BX, # $471
  79.                 MOV 0 [BX], AL
  80.                 MOV AX, CS
  81.                 MOV DS, AX
  82.                 JMP ORIGIN 3 +  END-CODE
  83.  
  84. LABEL BIOSBK    PUSH AX
  85.                 MOV AL, # $E9
  86.                 MOV CS: >NEXT AL
  87.                 MOV AX, # ABNORM >NEXT - 3 -
  88.                 MOV CS: >NEXT 1+ AX
  89.                 POP AX
  90.                 IRET            END-CODE
  91.  
  92. LABEL DOSBK     PUSH AX
  93.                 MOV AH, # 0             \ throw away BREAK KEY
  94.                 INT $16
  95.                 POP AX
  96.                 CLC
  97.                 RETF            END-CODE
  98.  
  99. LABEL NEST              \ JMP = 15 cycles
  100.         XCHG RP, SP     \  4 cycles
  101.         PUSH ES         \ 10 cycles
  102.         PUSH IP         \ 11 cycles
  103.         XCHG RP, SP     \  4 cycles
  104.         MOV DI, AX      \  2 cycles
  105.         MOV AX, 3 [DI]  \ 18 cycles     \ get relative segment
  106. \        ADD AX, XSEG    \ 15 cycles     \ adjust by base of list space
  107.  
  108. \ Patch the following ADD to add the current value of XSEG as of this
  109. \ invocation of F-PC. Patched by COLD in KERNEL4.SEQ
  110. LABEL NESTPATCH
  111.         ADD AX, # XSEG  \ really patched later to add actual XSEG value.
  112.  
  113.         MOV ES, AX      \  2 cycles     \ move into ES
  114.         SUB IP, IP      \  3 cycles     \ clear IP
  115.         NEXT
  116.         END-CODE
  117. META
  118.  
  119. CODE EXIT       ( -- )  \ Terminate a high-level definition
  120.                 XCHG RP, SP     \ 4 cycles
  121.                 POP IP          \ 8 cycles
  122.                 POP ES          \ 8 cycles
  123.                 XCHG RP, SP     \ 4 cycles
  124.                 NEXT
  125.                 END-CODE
  126.  
  127. CODE ?EXIT      ( f1 -- )  \ If boolean f1 is true, exit from definition.
  128.                 POP CX
  129.           CX<>0 IF      JMP ' EXIT
  130.                 THEN
  131.                 NEXT            END-CODE
  132.  
  133. CODE UNNEST     ( --- )   \ Same as EXIT
  134.                 XCHG RP, SP     \ 4 cycles
  135.                 POP IP          \ 8 cycles
  136.                 POP ES          \ 8 cycles
  137.                 XCHG RP, SP     \ 4 cycles
  138.                 NEXT
  139.                 END-CODE
  140.  
  141. LABEL DODOES  ( addr1 addr2 -- addr1 )
  142. \ The two addresses result from two calls.
  143.         XCHG RP, SP     \  4 cycles
  144.         PUSH ES         \ 10 cycles
  145.         PUSH IP         \ 11 cycles
  146.         XCHG RP, SP     \  4 cycles
  147.         POP DI
  148.         MOV AX, 0 [DI]
  149. \        ADD AX, XSEG
  150.  
  151. \ Patch the following ADD to add the current value of XSEG as of this
  152. \ invocation of F-PC. Patched by COLD in KERNEL4.SEQ
  153. LABEL DOESPATCH
  154.         ADD AX, # XSEG  \ really patched later to add actual XSEG value.
  155.  
  156.         MOV ES, AX
  157.         SUB IP, IP
  158.         NEXT            END-CODE
  159.  
  160. VARIABLE UP     \ Pointer to current USER area
  161.  
  162. LABEL DOCONSTANT  \ This code level word is CALLed.
  163.                 MOV BX, AX
  164.                 PUSH 3 [BX]
  165.                 NEXT            END-CODE
  166.  
  167. LABEL DOVALUE                           \ Save as constant, but it is assumed
  168.                 MOV BX, AX
  169.                 PUSH 3 [BX]     \ the user may change it.
  170.                 NEXT            END-CODE
  171.  
  172. LABEL DOUSER-VARIABLE   \ CALLed to fetch from USER area.
  173.                 POP BX
  174.                 MOV AX, 0 [BX]
  175.                 ADD AX, UP
  176.                 1PUSH           END-CODE
  177.  
  178. CODE (LIT)      ( -- n )  \ Fetches an in-line word
  179.                 LODSW ES:       1PUSH           END-CODE
  180.  
  181. CODE <'>        ( -- n )  \ Fetches an in-line word (same as (LIT) )
  182.                 LODSW ES:       1PUSH           END-CODE
  183.  
  184. T: LITERAL      ( n -- ) [TARGET] (LIT)   ,-X   T;
  185. T: DLITERAL     ( d -- ) SWAP [TARGET] (LIT) ,-X   [TARGET] (LIT) ,-X   T;
  186. T: ASCII        ( -- )   [COMPILE] ASCII [[ TRANSITION ]] LITERAL [META]  T;
  187. T: [']          ( -- )   'T >BODY @
  188.                          [[ TRANSITION ]] LITERAL  [META]   T;
  189. : CONSTANT      ( n -- )  \ a defining word that creates constants
  190.                 RECREATE 233 C,-T
  191.                 [[ ASSEMBLER DOCONSTANT ]] LITERAL HERE 2+ - ,-T
  192.                 DUP ,-T   CONSTANT   ;
  193.  
  194. : VALUE         ( n -- )  \ Internally the same as CONSTANT
  195.                 RECREATE 233 C,-T
  196.                 [[ ASSEMBLER DOVALUE    ]] LITERAL HERE 2+ - ,-T
  197.                 DUP ,-T   VALUE      ;
  198.  
  199. FORWARD: <(;CODE)>
  200. T: DOES>        ( -- )
  201.                 [FORWARD] <(;CODE)> HERE-T ,-X
  202.                 HERE-T  ( DOES-OP ) 232 C,-T
  203.                 [[ ASSEMBLER DODOES ]] LITERAL HERE 2+ - ,-T
  204.                 HERE-X PARAGRAPH-X + DUP DPSEG-X ! SEG-X @ - ,-T
  205.                 DP-X OFF T;
  206.  
  207. : NUMERIC   ( -- )
  208.                 [FORTH] HERE [META] NUMBER   DPL @ 1+
  209.                 IF      [[ TRANSITION ]] DLITERAL [META]
  210.                 ELSE    DROP   [[ TRANSITION ]] LITERAL [META]   THEN  ;
  211.  
  212. : UNDEFINED     ( -- )
  213.                 HERE-X >XREL 0 ,-X
  214.                 CR >IN @ BL WORD COUNT TYPE >IN !
  215.                 15 #OUT @ - SPACES .SEQHANDLE
  216.                 40 #OUT @ - SPACES loadline @ 4 .R
  217.                 ."   Forward reference or unresolved."
  218.                 IN-FORWARD  [FORTH] CREATE [META] TRANSITION
  219.                 [FORTH] ,   FALSE ,   [META]
  220.                 DOES>   FORWARD-CODE   ;
  221.  
  222. [FORTH] VARIABLE T-IN      META
  223.  
  224. : ]             ( -- )  \ Return to compilation state.
  225.                 STATE-T ON   IN-TRANSITION
  226.         BEGIN   >IN @ T-IN !
  227.                 BEGIN   BL WORD DUP C@ 0=       \ If nothing in line
  228.                         ?FILLBUFF               \ Optionally refill buffer
  229.                         INLENGTH 0> AND         \ and input buf not empty
  230.                 WHILE   DROP 0 T-IN !
  231.                         ?LISTING
  232.                         IF      CR BASE @ >R HEX
  233.                                 HERE-T 4 .R SPACE
  234.                                 LINESTRT HERE-T OVER - 5 MIN BOUNDS
  235.                                 ?DO     I C@-T 0 <# # # BL HOLD #> TYPE
  236.                                 LOOP    22 #OUT @ - SPACES
  237.                                 TIB #TIB @ TYPE
  238.                                 R> BASE !
  239.                         THEN
  240.                         FILLTIB            \ refill the buffer
  241.                         HERE-T =: LINESTRT
  242.                 REPEAT  ?UPPERCASE FIND
  243.                 IF      EXECUTE
  244.                 ELSE    COUNT NUMERIC?
  245.                         IF      NUMERIC
  246.                         ELSE    T-IN @ >IN !   UNDEFINED
  247.                         THEN
  248.                 THEN    STATE-T @ 0=
  249.         UNTIL ;
  250.  
  251. T: [   ( -- )   IN-META   STATE-T OFF   T;
  252.  
  253. T: ;   ( -- )   [TARGET] UNNEST   [[ TRANSITION ]] [   T;
  254.  
  255.  : :   ( -- )   TARGET-CREATE   233 C,-T        \ a JUMP instruction
  256.                 [[ ASSEMBLER NEST ]] LITERAL HERE 2+ - ,-T
  257.                 HERE-X PARAGRAPH-X + DUP DPSEG-X !
  258.                 SEG-X @ - ( DUP H. ) ,-T
  259.                 DP-X OFF ] ;                              \ compile body addr
  260.  
  261. ASSEMBLER LOCAL_REF CLEAR_LABELS META
  262.  
  263. CODE DOBEGIN    ( -- )  \ really a NOOP
  264.                 NEXT    END-CODE
  265.  
  266. CODE DOCASE     ( -- )  \ really a NOOP
  267.                 NEXT    END-CODE
  268.  
  269. CODE DOENDCASE  ( -- )  \ really a NOOP ( DROP )
  270. \                 ADD SP, # 2
  271.                 NEXT            END-CODE
  272.  
  273. CODE DOTHEN     ( -- )  \ really a NOOP
  274.                 NEXT    END-CODE
  275.  
  276. CODE DOAGAIN    ( -- )  \ an unconditional branch
  277.                 MOV ES: IP, 0 [IP]
  278.                 NEXT           END-CODE
  279.  
  280. CODE DOREPEAT   ( -- )  \ an unconditional branch
  281.                 MOV ES: IP, 0 [IP]
  282.                 NEXT           END-CODE
  283.  
  284. CODE ?WHILE     ( f -- )  \ branch if flag is zero
  285.                 POP CX
  286.           CX<>0 IF      ADD IP, # 2
  287.                         NEXT
  288.                 THEN
  289.                 MOV ES: IP, 0 [IP]
  290.                 NEXT           END-CODE
  291.  
  292. CODE ?UNTIL     ( f -- )  \ branch if flag is zero
  293.                 POP CX
  294.           CX<>0 IF      ADD IP, # 2
  295.                         NEXT
  296.                 THEN
  297.                 MOV ES: IP, 0 [IP]
  298.                 NEXT           END-CODE
  299.  
  300. CODE BRANCH     ( -- )  \ Unconditional branch
  301.                 MOV ES: IP, 0 [IP]
  302.                 NEXT            END-CODE
  303.  
  304. CODE DOENDOF    ( -- )  \ Unconditional branch
  305.                 MOV ES: IP, 0 [IP]
  306.                 NEXT            END-CODE
  307.  
  308. CODE ?BRANCH    ( f -- )  \ Branch if flag is zero
  309.                 POP CX
  310.           CX<>0 IF      ADD IP, # 2
  311.                         NEXT
  312.                 THEN
  313.                 MOV ES: IP, 0 [IP]
  314.                 NEXT            END-CODE
  315.  
  316. CODE NEXT|      ( n1 --- )  \ Primitive form of NEXT (as in FOR - NEXT loops)
  317.                 SUB 0 [RP], # 1 WORD
  318.             U>= IF      MOV IP, ES: 0 [IP]
  319.                         NEXT
  320.                 THEN
  321.                 ADD RP, # 2
  322.                 ADD IP, # 2
  323.                 NEXT    END-CODE
  324.  
  325. T: BEGIN        [TARGET] DOBEGIN X?<MARK      T;
  326. T: FOR          [TARGET] >R      X?<MARK      T;
  327. T: NEXT         [TARGET] NEXT|   X?<RESOLVE   T;
  328. T: AGAIN        [TARGET] DOAGAIN X?<RESOLVE   T;
  329. T: UNTIL        [TARGET] ?UNTIL  X?<RESOLVE   T;
  330. T: IF           [TARGET] ?BRANCH X?>MARK      T;
  331. T: FORWARD      [TARGET] BRANCH  X?>MARK      T;
  332. T: THEN         [TARGET] DOTHEN  X?>RESOLVE   T;
  333. T: AFT          2DROP [TARGET] BRANCH X?>MARK X?<MARK 2SWAP   T;
  334. T: ELSE         [TARGET] BRANCH  X?>MARK   2SWAP X?>RESOLVE   T;
  335. T: WHILE        [TARGET] ?WHILE  X?>MARK   2SWAP              T;
  336. T: REPEAT       [TARGET] DOREPEAT X?<RESOLVE X?>RESOLVE       T;
  337. T: CONTINUE     2OVER [TARGET] DOREPEAT X?<RESOLVE X?>RESOLVE T;
  338. T: BREAK        [TARGET] EXIT [TARGET] DOTHEN X?>RESOLVE      T;
  339.  
  340. CODE UNDO       ( --- )  \ Clean up Return Stack so we can EXIT from DO-loop.
  341.                 ADD RP, # 6
  342.                 NEXT            END-CODE
  343.  
  344. CODE (LOOP)     ( -- )  \ Primitive form of LOOP
  345.                 INC 0 [RP] WORD
  346.            OV<> IF
  347.                         MOV ES: IP, 0 [IP]
  348.                         NEXT
  349.                 THEN
  350.                 ADD RP, # 6     ADD IP, # 2
  351.                 NEXT            END-CODE
  352.  
  353. CODE (+LOOP)    ( n -- )  \ Primitive form of +LOOP
  354.                 AX POP          ADD 0 [RP], AX
  355.            OV<> IF
  356.                         MOV ES: IP, 0 [IP]
  357.                         NEXT
  358.                 THEN
  359.                 ADD RP, # 6     ADD IP, # 2
  360.                 NEXT            END-CODE
  361.  
  362. CODE (DO)       ( l i -- )  \ Primitive form of DO
  363.                 POP DX          POP BX
  364.                 XCHG RP, SP             \ 4
  365.                 LODSW ES:               \ 12 + 2
  366.                 PUSH AX                 \ 11
  367.                 ADD BX, # $8000          \ 4
  368.                 PUSH BX                 \ 11
  369.                 SUB DX, BX              \ 3
  370.                 PUSH DX                 \ 11
  371.                 XCHG RP, SP             \ 4     = 62
  372.                 NEXT            END-CODE
  373.  
  374. CODE (?DO)      ( l i -- )  \ Primitive form of ?DO
  375.                 POP DX          POP BX
  376.                 CMP BX, DX
  377.              0= IF
  378.                         MOV ES: IP, 0 [IP]
  379.                         NEXT
  380.                 THEN
  381.                 XCHG RP, SP             \ 4
  382.                 LODSW ES:               \ 12 + 2
  383.                 PUSH AX                 \ 11
  384.                 ADD BX, # $8000          \ 4
  385.                 PUSH BX                 \ 11
  386.                 SUB DX, BX              \ 3
  387.                 PUSH DX                 \ 11
  388.                 XCHG RP, SP             \ 4     = 62
  389.                 NEXT            END-CODE
  390.  
  391. CODE (OF)       ( n1 n2 -- n1 )  ( or )  ( n1 n1 -- )  \ Primitive form of OF
  392.                 POP AX          MOV DI, SP
  393.                 CMP AX, 0 [DI]
  394.             0<> IF      MOV ES: IP, 0 [IP]
  395.                         NEXT
  396.                 THEN
  397.                 ADD SP, # 2
  398.                 ADD IP, # 2
  399.                 NEXT            END-CODE
  400.  
  401. CODE BOUNDS     ( n1 n2 --- n3 n4 )  \ Calculate limits used in DO-loop
  402.                 POP DX          POP AX          ADD DX, AX
  403.                 2PUSH           END-CODE
  404.  
  405. T: ?DO          [TARGET] (?DO)   X?>MARK   T;
  406. T: DO           [TARGET] (DO)    X?>MARK   T;
  407. T: LOOP         [TARGET] (LOOP)    2DUP 2+   X?<RESOLVE   X?>RESOLVE   T;
  408. T: +LOOP        [TARGET] (+LOOP)   2DUP 2+   X?<RESOLVE   X?>RESOLVE   T;
  409.  
  410. ASSEMBLER >NEXT META CONSTANT >NEXT
  411.                 \ Label to jump to when we are NOT using in-line NEXT
  412. ASSEMBLER  NEST META CONSTANT >NEST
  413.                 \ Address of the nesting function
  414.  
  415. CODE EXECUTE    ( cfa -- )  \ Execute the word whose CFA is on the stack.
  416.                 POP AX          JMP AX          END-CODE
  417.  
  418. CODE PERFORM    ( addr-of-cfa -- )      \ Performs the function  @ EXECUTE
  419.                 POP BX          MOV AX, 0 [BX]
  420.                 JMP AX          END-CODE
  421.  
  422. CODE GOTO       ( --   ;A rmb )         \ 07/03/89 RB
  423. \  terminates execution of the current colon def used to avoid return
  424. \ stack loading, and for execution speed by combining exit and next
  425. \ also used by coroutines
  426.                 LODSW ES:
  427.                 XCHG SP, RP
  428.                 POP IP
  429.                 POP ES
  430.                 XCHG SP, RP
  431.                 JMP AX   END-CODE
  432. \ used only in colon definitions:   : xx   goto yy ;
  433.  
  434. LABEL DODEFER   ( addr -- )  \ run-time code for a DEFERed word
  435.                 POP BX          MOV AX, 0 [BX]
  436.                 JMP AX          END-CODE
  437.  
  438. CODE EXEC:      ( n1 -- )  \ execute the n-th word following EXEC:
  439.                 POP BX
  440.                 SHL BX, # 1
  441.                 ADD IP, BX
  442.                 LODSW ES:
  443.                 XCHG RP, SP     \ 4
  444.                 POP IP          \ 8
  445.                 POP ES          \ 8
  446.                 XCHG RP, SP     \ 4     = 24
  447.                 JMP AX          END-CODE
  448.  
  449. LABEL DOUSER-DEFER   ( addr -- )  \ run-time codef for a USER DEFERed word
  450.                 POP BX          MOV BX, 0 [BX]
  451.                 ADD BX, UP      MOV AX, 0 [BX]
  452.                 JMP AX          END-CODE
  453.  
  454. CODE GO         \ execute CODE at specified address
  455.                 RET             END-CODE        ( addr --- )
  456.  
  457. CODE NOOP       \  Does nothing  (No-Operation)
  458.                 NEXT            END-CODE
  459.  
  460. CODE PAUSE      \  A NOP that can be patched!  Used by Multi-tasker.
  461.                 NOP                             \ Gets patched
  462.                 NOP
  463.                 NOP
  464.                 NEXT            END-CODE
  465.  
  466. CODE I          ( -- n )
  467. \  get the current index of the innermost loop
  468.                 MOV AX, 0 [RP]  ADD AX, 2 [RP]
  469.                 1PUSH           END-CODE
  470.  
  471. CODE J          ( -- n )
  472. \  Get the index of the second most inner loop.
  473.                 MOV AX, 6 [RP]  ADD AX, 8 [RP]
  474.                 1PUSH           END-CODE
  475.  
  476. CODE K          ( -- n )
  477. \  Get the index of the third most inner loop.
  478.                 MOV AX, 12 [RP] ADD AX, 14 [RP]
  479.                 1PUSH           END-CODE
  480.  
  481. CODE (LEAVE)    ( -- )
  482. \ run time version of LEAVE to jump past the end of a DO-LOOP
  483.                 MOV IP, 4 [RP]
  484.                 ADD RP, # 6
  485.                 NEXT            END-CODE
  486.  
  487. CODE (?LEAVE)   ( f -- )
  488. \ If the flag is non-zero, jump out of the DO-LOOP.
  489.                 POP AX
  490.                 OR AX, AX
  491.              0= IF      NEXT
  492.                 THEN
  493.                 MOV IP, 4 [RP]
  494.                 ADD RP, # 6
  495.                 NEXT            END-CODE
  496.  
  497. T: LEAVE        [TARGET] (LEAVE)   T;
  498. T: ?LEAVE       [TARGET] (?LEAVE)  T;
  499.  
  500. CODE @          ( addr -- n )   \ Fetch a 16 bit value from addr
  501.                 POP BX          PUSH 0 [BX]
  502.                 NEXT            END-CODE
  503.  
  504. CODE !          ( n addr -- )   \ Store value n into the address addr
  505.                 POP BX          POP 0 [BX]
  506.                 NEXT            END-CODE
  507.  
  508. CODE C@         ( addr -- char )
  509. \ Fetch an 8 bit value from addr.  Fill high part with zeros.
  510.                 POP BX          SUB AX, AX      MOV AL, 0 [BX]
  511.                 1PUSH           END-CODE
  512.  
  513. CODE C!         ( char addr -- )
  514. \ Store the least significant 8 bits of char at the specified addr
  515.                 POP BX          POP AX          MOV 0 [BX], AL
  516.                 NEXT            END-CODE
  517.  
  518. CODE CMOVE      (  from to count -- )
  519. \ Move "count" bytes from "from" to "to" address.
  520.                 MOV BX, IP      MOV AX, DS
  521.                 POP CX          POP DI          POP IP
  522.                 MOV DX, ES      MOV ES, AX
  523.                 REPNZ           MOVSB
  524.                 MOV IP, BX      MOV ES, DX
  525.                 NEXT            END-CODE
  526.  
  527. CODE CMOVE>     ( from to count -- )
  528. \ move "count" bytes from "from" to "to", highest address first
  529.                 MOV BX, IP      MOV AX, DS
  530.                 POP CX          DEC CX
  531.                 POP DI          POP IP
  532.                 ADD DI, CX      ADD IP, CX      INC CX
  533.                 MOV DX, ES      MOV ES, AX
  534.                 STD
  535.                 REPNZ           MOVSB
  536.                 CLD
  537.                 MOV IP, BX
  538.                 MOV ES, DX
  539.                 NEXT            END-CODE
  540.  
  541. CODE PLACE      ( from cnt to -- )
  542. \ Move "cnt" characters from "from" to "to" + 1, with preceeding count byte
  543. \ at "to".
  544.                 POP DI          POP CX
  545.                 MOV 0 [DI], CL
  546.                 INC DI
  547.                 CLD
  548.                 MOV BX, IP      POP IP
  549.                 MOV DX, ES
  550.                 MOV AX, DS      MOV ES, AX
  551.                 REPNZ           MOVSB
  552.                 MOV IP, BX
  553.                 MOV ES, DX
  554.                 NEXT            END-CODE
  555.  
  556. CODE +PLACE     ( from cnt to -- )      \ append text to counted string
  557. \ Append "cnt" characters from "from" to counted string "to", adjust
  558. \ the count byte of "to" to include "cnt".
  559.                 POP DI          POP CX
  560.                 MOV BX, IP      POP IP
  561.                 MOV DX, ES
  562.                 SUB AX, AX
  563.                 MOV AL, 0 [DI]          \ pick up current length
  564.                 ADD 0 [DI], CL          \ adj current length plus cnt
  565.                 INC DI                  \ step to text start
  566.                 ADD DI, AX              \ adjust to current text end
  567.                 CLD
  568.                 MOV AX, DS      MOV ES, AX
  569.                 REPNZ           MOVSB   \ append the text
  570.                 MOV IP, BX
  571.                 MOV ES, DX
  572.                 NEXT            END-CODE
  573.  
  574. DECIMAL
  575.  
  576. CODE SP@        ( -- n )
  577. \ Push the address of the top element on the parameter stack (prior to push).
  578.                 MOV AX, SP      1PUSH           END-CODE
  579. \ Can't use the following because it doesn't work on an 8088.
  580. \               PUSH SP         NEXT            END-CODE
  581.  
  582. CODE SP!        ( n -- )
  583. \ Set the parameter stack pointer to specified value.
  584.                 POP SP          NEXT            END-CODE
  585.  
  586. CODE RP@        ( -- addr )
  587. \ Push the address of the top element of the return stack
  588. \ onto the parameter stack.
  589.                 PUSH RP         NEXT            END-CODE
  590.  
  591. CODE RP!        ( n -- )  \ Set the return stack pointer to n .
  592.                 POP RP          NEXT            END-CODE
  593.  
  594. CODE DROP       ( n1 -- )
  595.                 ADD SP, # 2     NEXT            END-CODE
  596.  
  597. CODE DUP        ( n1 -- n1 n1 )  \ Duplicate the top element of the stack.
  598.                 MOV DI, SP      \ 2
  599.                 PUSH 0 [DI]     \ 21 = 23
  600.                 NEXT            END-CODE
  601.  
  602. CODE SWAP       ( n1 n2 -- n2 n1 )
  603. \ Exchange the top two items on the stack.
  604.                 POP DX          POP AX
  605.                 2PUSH           END-CODE
  606.  
  607. CODE OVER       ( n1 n2 -- n1 n2 n1 )
  608. \ Push a copy of the second stack item.
  609.                 MOV DI, SP
  610.                 PUSH 2 [DI]
  611.                 NEXT            END-CODE
  612.  
  613. CODE PLUCK      ( n1 n2 n3 --- n1 n2 n3 n1 )  
  614. \ Copy the third stack item to top
  615.                 MOV DI, SP
  616.                 PUSH 4 [DI]
  617.                 NEXT            END-CODE
  618.  
  619. CODE TUCK       ( n1 n2 -- n2 n1 n2 )
  620. \ Tuck the first stack element under the second.
  621.                 POP AX          POP DX
  622.                 PUSH AX         2PUSH           END-CODE
  623.  
  624. CODE NIP        ( n1 n2 -- n2 )  \ Delete the second stack item.
  625.                 POP AX          ADD SP, # 2
  626.                 1PUSH           END-CODE
  627.  
  628. CODE ROT        ( n1 n2 n3 --- n2 n3 n1 )  
  629. \ Rotate top three stack values, bringing the third item to the top.
  630.                 POP DX          POP BX          POP AX
  631.                 PUSH BX         2PUSH           END-CODE
  632.  
  633. CODE -ROT       ( n1 n2 n3 --- n3 n1 n2 )  \ Inverse of ROT
  634.                 POP BX          POP AX          POP DX
  635.                 PUSH BX         2PUSH           END-CODE
  636.  
  637. CODE FLIP       ( n1 -- n2 )  \ Exchange the high and low halves of a word
  638.                 POP AX          XCHG AL, AH
  639.                 1PUSH           END-CODE
  640.  
  641. CODE SPLIT      ( n1 --- n2 n3 )        \ Splits n1 into two bytes, low, high
  642.                 POP BX
  643.                 SUB AX, AX
  644.                 MOV AL, BL
  645.                 PUSH AX
  646.                 MOV AL, BH
  647.                 1PUSH           END-CODE
  648.  
  649.                                         \ 07/03/89 RB
  650. CODE JOIN       ( n1 n2 -- n3 )         \ Join bytes into one word, n2 = hi
  651.                 POP DX
  652.                 POP AX
  653.                 MOV AH, DL
  654.                 1PUSH           END-CODE
  655.  
  656. CODE ?DUP       ( n1 -- [n1] n1 )       \ duplicate n1 if <> 0
  657.                 MOV DI, SP              \  2
  658.                 MOV CX, 0 [DI]          \ 13
  659.           CX<>0 IF                      \ 18/6
  660.                         PUSH CX         \ 11
  661.                 THEN                    \ 32 without push
  662.                 NEXT    END-CODE        \ 33 with    push
  663.  
  664.                                         \ 07/03/89 RB
  665. CODE ?DROP      ( n false -- false | n true -- n true )
  666.                 POP AX
  667.                 OR AX, AX
  668.              0= IF      INC SP
  669.                         INC SP
  670.                 THEN
  671.                 1PUSH           END-CODE
  672.  
  673. CODE R>         ( -- n )
  674. \ Pop an item from the return stack and push onto parameter stack.
  675.                 PUSH 0 [RP]
  676.                 ADD RP, # 2
  677.                 NEXT            END-CODE
  678.  
  679. CODE R>DROP     ( --- )  \ Drop an item from the return stack
  680.                 ADD RP, # 2
  681.                 NEXT            END-CODE
  682.  
  683. CODE DUP>R      ( n1 --- n1 )  
  684. \ Pushes a copy of the top item on parameter stack to the return stack.
  685.                 XCHG SP, RP     \  4
  686.                 PUSH 0 [RP]     \ 16 + 5
  687.                 XCHG SP, RP     \  4 = 29 cycles
  688.                 NEXT            END-CODE
  689.  
  690. CODE >R         ( n -- )  
  691. \ Pop top of parameter stack and push value onto return stack.
  692.                 SUB RP, # 2     \  4
  693.                 POP 0 [RP]      \ 22 = 26 cycles
  694.                 NEXT            END-CODE
  695.  
  696. CODE 2R>        ( -- n1 n2 )  
  697. \ Pop two items from return stack onto parameter stack
  698.                 PUSH 2 [RP]     \ 25
  699.                 PUSH 0 [RP]     \ 21
  700.                 ADD RP, # 4     \  4 = 50 cycles
  701.                 NEXT            END-CODE
  702.  
  703. CODE 2>R        ( n1 n2 -- )  
  704. \ Pop two items from parameter stack, push onto return stack.
  705.                 SUB RP, # 4     \  4
  706.                 POP 0 [RP]      \ 22
  707.                 POP 2 [RP]      \ 26 = 52 cycles
  708.                 NEXT            END-CODE
  709.  
  710. CODE R@         ( -- n )  
  711. \ Push a copy of top item on return stack onto parameter stack.
  712.                 PUSH 0 [RP]
  713.                 NEXT            END-CODE
  714.  
  715. CODE 2R@        ( -- n1 n2 )  
  716. \ Push a copy of the top two items on the return stack onto the parameter stack.
  717.                 PUSH 2 [RP]
  718.                 PUSH 0 [RP]
  719.                 NEXT            END-CODE
  720.  
  721. CODE PICK       ( nm ... n2 n1 k -- nm ... n2 n1 nk )  
  722. \ Push a copy of the n-th item on paramter stack.
  723.                 POP DI          SHL DI, # 1     ADD DI, SP
  724.                 PUSH 0 [DI]
  725.                 NEXT            END-CODE
  726.  
  727. CODE RPICK      ( nm ... n2 n1 k -- nm ... n2 n1 nk )   \ return stack pick
  728.                 POP DI          SHL DI, # 1
  729.                 PUSH 0 [RP+DI]
  730.                 NEXT            END-CODE
  731.  
  732. CODE AND        ( n1 n2 -- n3 )  
  733. \ Perform bit-wise logical AND of top two items.
  734.                 POP BX          POP AX          AND AX, BX
  735.                 1PUSH           END-CODE
  736.  
  737. CODE OR         ( n1 n2 -- n3 )
  738. \ Perform bit-wise logical OR of top two items on parameter stack.
  739.                 POP BX          POP AX          OR AX, BX
  740.                 1PUSH           END-CODE
  741.  
  742. CODE XOR        ( n1 n2 -- n3 )
  743. \ Perform bit-wise logical Exclusive OR of top two stack items.
  744.                 POP BX          POP AX          XOR AX, BX
  745.                 1PUSH           END-CODE
  746.  
  747. CODE NOT        ( n -- n' )  \ Logically invert the bits of top stack item.
  748.                 POP AX          NOT AX
  749.                 1PUSH           END-CODE
  750.  
  751. -1 CONSTANT TRUE
  752.  0 CONSTANT FALSE
  753.  
  754. CODE CSET       ( b addr -- )  
  755. \ Logical OR of l.s. 8 bits of "b" with byte at "addr".
  756.                 POP BX          POP AX          OR 0 [BX], AL
  757.                 NEXT            END-CODE
  758.  
  759. CODE CRESET     ( b addr -- )
  760. \ Clear bits in byte at addr corresponding to "1" bits in b .
  761.                 POP BX          POP AX
  762.                 NOT AX          AND 0 [BX], AL
  763.                 NEXT            END-CODE
  764.  
  765. CODE CTOGGLE    ( b addr -- )
  766. \ Toggle bits in byte at addr corresponding to "1" bits in b .
  767.                 POP BX          POP AX          XOR 0 [BX], AL
  768.                 NEXT            END-CODE
  769.  
  770. CODE ON         ( addr -- )  \ Set word at addr to "true"
  771.                 POP BX          MOV 0 [BX], # TRUE WORD
  772.                 NEXT            END-CODE
  773.  
  774. CODE OFF        ( addr -- )  \ Clear all bits of word at addr.
  775.                 POP BX          MOV 0 [BX], # FALSE WORD
  776.                 NEXT            END-CODE
  777.  
  778. CODE -1!        ( addr -- )  \ Same as ON
  779.                 POP BX          MOV 0 [BX], # TRUE WORD
  780.                 NEXT            END-CODE
  781.  
  782. CODE 0!         ( addr -- )  \ Same as OFF
  783.                 POP BX          MOV 0 [BX], # FALSE WORD
  784.                 NEXT            END-CODE
  785.  
  786. CODE INCR       ( addr --- )  \ Increment word at addr.
  787.                 POP BX          INC 0 [BX] WORD
  788.                 NEXT            END-CODE
  789.  
  790. CODE DECR       ( addr --- )  \ Decrement word at addr.
  791.                 POP BX          DEC 0 [BX] WORD
  792.                 NEXT            END-CODE
  793.  
  794. CODE 0DECR      ( addr -- )     \ Decrement to zero only, not below
  795.                 POP BX
  796.                 DEC 0 [BX] WORD
  797.              0< IF      MOV 0 [BX], # 0 WORD
  798.                 THEN
  799.                 NEXT            END-CODE
  800.  
  801. CODE +          ( n1 n2 -- sum )  \ Add top two elements
  802.                 POP BX          POP AX          ADD AX, BX
  803.                 1PUSH           END-CODE
  804.  
  805. CODE NEGATE     ( n -- n' )  \ Arithmetically negate top stack element.
  806.                 POP AX          NEG AX
  807.                 1PUSH           END-CODE
  808.  
  809. CODE -          ( n1 n2 -- n1-n2 )  \ Subtract top stack element from second
  810.                 POP BX          POP AX          SUB AX, BX
  811.                 1PUSH           END-CODE
  812.  
  813. CODE ABS        ( n1 -- n2 )   \  Return absolute value of top stack item 
  814.                 POP AX
  815.                 CWD
  816.                 XOR AX, DX
  817.                 SUB AX, DX
  818.                 1PUSH
  819.                 END-CODE
  820.  
  821. CODE D+!        ( d addr -- )  
  822. \ Add double number "d" to double value at "addr"
  823.                 POP BX          POP AX          POP DX
  824.                 ADD 2 [BX], DX  ADC 0 [BX], AX
  825.                 NEXT            END-CODE
  826.  
  827. CODE +!         ( n addr -- )  \ Add "n" to word at "addr"
  828.                 POP BX          POP AX          ADD 0 [BX], AX
  829.                 NEXT            END-CODE
  830.  
  831. CODE C+!        ( n addr -- )  \ Add "n" to byte at "addr"
  832.                 POP BX          POP AX          ADD 0 [BX], AL
  833.                 NEXT            END-CODE
  834.  
  835.  
  836. \ Since the 8086 has a seperate IO path, we define a Forth
  837. \ interface to it.  Use P@ and P! to read or write directly to
  838. \ the 8086 IO ports.
  839.  
  840. CODE PC@        ( port# -- n )  
  841. \ Read 8-bit port at "port#" and push value on stack.
  842.                 POP DX          IN AL, DX       SUB AH, AH
  843.                 PUSH AX         NEXT            END-CODE
  844.  
  845. CODE P@         ( port# -- n )
  846. \ Read 16-bit value at "port#" and push value on stack.
  847.                 POP DX          IN AX, DX       PUSH AX
  848.                 NEXT            END-CODE
  849.  
  850. CODE PC!        ( n port# -- )
  851. \ Write 8 bit value "n" to "port#".
  852.                 POP DX          POP AX          OUT DX, AL
  853.                 NEXT            END-CODE
  854.  
  855. CODE P!         ( n port# -- )
  856. \ Write 16 bit value "n" to "port#".
  857.                 POP DX          POP AX          OUT DX, AX
  858.                 NEXT            END-CODE
  859.  
  860. CODE PDOS       ( addr drive# --- f1 ) 
  861. \ Read path of drive into addr, NULL terminated.
  862.                 pop dx          pop ax
  863.                 push si         mov si, ax
  864.                 mov ah, # $47   int $21
  865.              u< if
  866.                 mov al, # 1
  867.              else
  868.                 mov al, # 0
  869.              then
  870.                 sub ah, ah      pop si
  871.                 1push           end-code
  872.  
  873. #TTHREADS CONSTANT #THREADS   \ Number of Threads used in dictionary.
  874.  
  875. CODE 2*         ( n -- 2*n )  \ Logical left shift n by 1 position.
  876.                 POP AX          SHL AX, # 1
  877.                 1PUSH           END-CODE
  878.  
  879. CODE 2/         ( n -- n/2 )  \ Arithmetic right shift of n by 1 position
  880.                 POP AX          SAR AX, # 1
  881.                 1PUSH           END-CODE
  882.  
  883. CODE U2/        ( u -- u/2 )  \ Logical right shift of n by 1 position
  884.                 POP AX          SHR AX, # 1
  885.                 1PUSH           END-CODE
  886.  
  887. CODE U16/       ( u -- u/16 ) \ Logical shift right by 4 bit positions. 
  888.                 POP AX
  889.                 SHR AX, # 1     SHR AX, # 1
  890.                 SHR AX, # 1     SHR AX, # 1
  891.                 1PUSH           END-CODE
  892.  
  893. CODE U8/        ( u -- u/8 )  \ Logical shift right by 3 bit positions.
  894.                 POP AX
  895.                 SHR AX, # 1
  896.                 SHR AX, # 1
  897.                 SHR AX, # 1
  898.                 1PUSH           END-CODE
  899.  
  900. CODE 8*         ( n -- 8*n )  \ Logical shift left by 3 positions.
  901.                 POP AX          SHL AX, # 1
  902.                 SHL AX, # 1     SHL AX, # 1
  903.                 1PUSH           END-CODE
  904.  
  905. CODE 1+         ( n1 --- n2 )  \  Add 1 to top stack element
  906.                 POP AX          INC AX
  907.                 1PUSH           END-CODE
  908.  
  909. CODE 2+         ( n1 --- n2 )  \  Add 2 to top stack element
  910.                 POP AX          ADD AX, # 2
  911.                 1PUSH           END-CODE
  912.  
  913. CODE 1-         ( n1 --- n2 )  \  Subtract 1 from top stack element
  914.                 POP AX          DEC AX
  915.                 1PUSH           END-CODE
  916.  
  917. CODE 2-         ( n1 --- n2 )  \  Subtract 2 from top stack element
  918.                 POP AX          SUB AX, # 2
  919.                 1PUSH           END-CODE
  920.  
  921. CODE UM*        ( n1 n2 -- d )
  922. \  Form a 32 bit product from two 16 bit unsigned numbers
  923.                 POP AX          POP BX          MUL BX
  924.                 XCHG DX, AX     2PUSH           END-CODE
  925.  
  926. CODE *          ( n1 n2 -- n3 )  
  927. \  Form a 16 bit product from two 16 bit numbers
  928.                 POP AX          POP BX          MUL BX
  929.                 1PUSH           END-CODE
  930.  
  931. : U*D           ( n1 n2 -- d )  
  932. \  Form a 32 bit product from two 16 bit unsigned numbers
  933.                 UM*   ;
  934.  
  935. CODE UM/MOD     ( ud un -- URemainder UQuotient )
  936. \ Unsigned double number divided by unsigned single results in unsigned
  937. \ remainder and quotient, with quotient on top.
  938.                 POP BX          POP DX          POP AX
  939.                 CMP DX, BX
  940.             U>=  ( divide by zero? )
  941.             IF
  942.                 MOV AX, # -1    MOV DX, AX      2PUSH
  943.             THEN
  944.                 DIV BX          2PUSH           END-CODE
  945.  
  946. CODE 0=         ( n -- f )  \  Return TRUE if n is zero.  Otherwise FALSE.
  947.                 POP AX          SUB AX, # 1     SBB AX, AX
  948.                 1PUSH           END-CODE
  949.  
  950. CODE 0<         ( n -- f )  
  951. \  If n is negative, return TRUE.  Otherwise FALSE.
  952.                 POP AX          CWD             PUSH DX
  953.                 NEXT            END-CODE
  954.  
  955. CODE 0>         ( n -- f )
  956. \  If n is greater than 0, return TRUE.  Otherwise FALSE.
  957.                 POP AX          NEG AX
  958.            OV<> IF      CWD
  959.                         PUSH DX
  960.                         NEXT
  961.                 THEN
  962.                 SHL AX, # 1
  963.                 1PUSH           END-CODE
  964.  
  965. CODE 0<>        ( n -- f )
  966. \  If n is not equal to 0, return TRUE.  Otherwise FALSE.
  967.                 POP AX          NEG AX          SBB AX, AX
  968.                 1PUSH           END-CODE
  969.  
  970. CODE =          ( n1 n2 -- f )
  971. \  If n1 is equal to n2, return TRUE.  Otherwise FALSE.
  972.                 POP AX          POP CX          SUB AX, CX
  973.                 SUB AX, # 1     SBB AX, AX
  974.                 1PUSH           END-CODE
  975.  
  976. CODE <>         ( n1 n2 -- f )
  977. \  If n1 is not equal to n2, return TRUE.  Otherwise FALSE.
  978.                 POP AX          POP CX          SUB AX, CX
  979.                 NEG AX          SBB AX, AX
  980.                 1PUSH           END-CODE
  981.  
  982. : ?NEGATE       ( n1 n2 -- n3 )  \  If n2 is negative, negate n1.
  983.                 0< IF    NEGATE   THEN   ;
  984.  
  985. CODE   U<       ( n1 n2 -- f )  
  986. \  If unsigned n1 is less than unsigned n2, return TRUE, otherwise FALSE.
  987.                 POP CX          POP AX          SUB AX, CX
  988.                 SBB AX, AX
  989.                 1PUSH           END-CODE
  990.  
  991. CODE   U>       ( n1 n2 -- f )
  992. \  If unsigned n1 is greater than unsigned n2, return TRUE, otherwise FALSE.
  993.                 POP AX          POP CX          SUB AX, CX
  994.                 SBB AX, AX
  995.                 1PUSH           END-CODE
  996.  
  997. CODE <          ( n1 n2 -- f )
  998. \  If signed n1 is less than signed n2, return TRUE, otherwise return FALSE.
  999.                 POP AX          POP BX          CMP BX, AX
  1000.              >= IF
  1001.                         SUB AX, AX
  1002.                         1PUSH
  1003.                 THEN
  1004.                 MOV AX, # TRUE  1PUSH           END-CODE
  1005.  
  1006. CODE >          ( n1 n2 -- f )
  1007. \  If signed n1 is greater than signed n2, return TRUE, otherwise FALSE.
  1008.                 POP AX          POP BX          CMP BX, AX
  1009.              <= IF
  1010.                         SUB AX, AX
  1011.                         1PUSH
  1012.                 THEN
  1013.                 MOV AX, # TRUE  1PUSH           END-CODE
  1014.  
  1015. CODE UMIN       ( n1 n2 -- n3 )
  1016. \ Return smaller of n1 or n2, treated as unsigned numbers.
  1017.                 POP AX          POP BX          CMP BX, AX
  1018.             U<= IF
  1019.                         PUSH BX
  1020.                         NEXT
  1021.                 THEN
  1022.                 1PUSH           END-CODE
  1023.  
  1024. CODE MIN        ( n1 n2 -- n3 )
  1025. \ Return smaller of n1 or n2, treated as signed numbers.
  1026.                 POP AX          POP BX          CMP BX, AX
  1027.              <= IF
  1028.                         PUSH BX
  1029.                         NEXT
  1030.                 THEN
  1031.                 1PUSH           END-CODE
  1032.  
  1033. CODE MAX        ( n1 n2 -- n3 )
  1034. \ Return larger of n1 or n2, treated as signed numbers.
  1035.                 POP AX          POP BX
  1036.                 CMP BX, AX
  1037.              <= IF
  1038.                         1PUSH
  1039.                 THEN
  1040.                 PUSH BX         NEXT            END-CODE
  1041.  
  1042. CODE 0MAX       ( n1 -- n3 )
  1043. \ Return larger of n1 or ZERO, treated as signed numbers.
  1044.                 POP AX
  1045.                 SUB BX, BX
  1046.                 CMP BX, AX
  1047.              <= IF
  1048.                         1PUSH
  1049.                 THEN
  1050.                 PUSH BX
  1051.                 NEXT            END-CODE
  1052.  
  1053. CODE UMAX       ( n1 n2 -- n3 )
  1054. \ Return larger of n1 or n2, treated as unsigned numbers.
  1055.                 POP AX          POP BX          CMP BX, AX
  1056.             U<= IF
  1057.                         1PUSH
  1058.                 THEN
  1059.                 PUSH BX         NEXT            END-CODE
  1060.  
  1061. CODE WITHIN     ( n lo hi -- flag )
  1062. \  Returns TRUE if  lo <= n < hi .  Signed comparison
  1063.                 POP DI          POP CX          POP DX
  1064.                 XOR AX, AX
  1065.                 CMP DX, DI
  1066.               < IF      CMP DX, CX
  1067.                      >= IF      DEC AX
  1068.                         THEN
  1069.                 THEN
  1070.                 1PUSH           END-CODE
  1071.  
  1072. CODE BETWEEN   ( n lo hi -- flag )
  1073. \  Returns TRUE if  lo <= n <= hi . Signed comparison
  1074.                 XOR AX, AX      POP BX          POP CX
  1075.                 POP DX
  1076.                 CMP DX, BX
  1077.              <= IF      CMP DX, CX
  1078.                      >= IF      DEC AX
  1079.                         THEN
  1080.                 THEN
  1081.                 1PUSH           END-CODE
  1082.  
  1083. CODE UBETWEEN   ( n lo hi -- flag )
  1084. \  Returns TRUE if  lo u<= n u<= hi . UNsigned comparison
  1085.                 POP BX          POP CX
  1086.                 POP DX
  1087.                 XOR AX, AX
  1088.                 CMP DX, BX
  1089.             U<= IF      CMP DX, CX
  1090.                     U>= IF      DEC AX
  1091.                         THEN
  1092.                 THEN
  1093.                 1PUSH           END-CODE
  1094.  
  1095. CODE 2@         ( addr -- d )  \  Fetch a 32 bit value from addr
  1096.                 POP BX
  1097.                 PUSH 2 [BX]
  1098.                 PUSH 0 [BX]
  1099.                 NEXT            END-CODE
  1100.  
  1101. CODE 2!         ( d addr -- )  \ Store a 32 bit value into addr
  1102.                 POP BX          POP 0 [BX]      POP 2 [BX]
  1103.                 NEXT            END-CODE
  1104.  
  1105. CODE 2DROP      ( d -- )  \ Drop two 16 bit values from stack
  1106.                 ADD SP, # 4
  1107.                 NEXT            END-CODE
  1108.  
  1109. CODE 3DROP      ( n1 n2 n3 -- )  \ Drop 3 items from the stack.
  1110.                 ADD SP, # 6
  1111.                 NEXT            END-CODE
  1112.  
  1113. CODE 2DUP       ( d -- d d )  \  Duplicate two top items on stack.
  1114.                 MOV DI, SP
  1115.                 PUSH 2 [DI]
  1116.                 PUSH 0 [DI]
  1117.                 NEXT            END-CODE
  1118.  
  1119. CODE 3DUP       ( n1 n2 n3 -- n1 n2 n3 n1 n2 n3 )
  1120. \ Duplicate top 3 items on stack.
  1121.                 MOV DI, SP
  1122.                 PUSH 4 [DI]
  1123.                 PUSH 2 [DI]
  1124.                 PUSH 0 [DI]
  1125.                 NEXT            END-CODE
  1126.  
  1127. CODE 2SWAP      ( d1 d2 -- d2 d1 )
  1128. \ Exchange top two pairs of numbers on stack.
  1129.                 POP CX          POP BX
  1130.                 POP AX          POP DX
  1131.                 PUSH BX         PUSH CX
  1132.                 2PUSH           END-CODE
  1133.  
  1134. CODE 2OVER      ( d2 d2 -- d1 d2 d1 )
  1135. \ Copy second pair of numbers over top pair of numbers on stack.
  1136.                 MOV DI, SP      \  2
  1137.                 PUSH 6 [DI]     \ 24
  1138.                 PUSH 4 [DI]     \ 24 = 50
  1139.                 NEXT            END-CODE
  1140.  
  1141. CODE D+         ( d1 d2 -- dsum )  \  Add top two double numbers on stack
  1142.                 POP AX          POP DX
  1143.                 POP BX          POP CX
  1144.                 ADD DX, CX      ADC AX, BX
  1145.                 2PUSH           END-CODE
  1146.  
  1147. CODE DNEGATE    ( d# -- d#' )  \  Negate double number on top of stack.
  1148.                 POP AX
  1149.                 POP DX
  1150.                 NEG AX
  1151.                 NEG DX
  1152.                 SBB AX, # 0
  1153.                 2PUSH
  1154.                 END-CODE
  1155.  
  1156. CODE   S>D      ( n -- d )
  1157. \  Convert single signed number to signed double
  1158.                 POP AX          CWD             XCHG DX, AX
  1159.                 2PUSH           END-CODE
  1160.  
  1161. CODE DABS       ( d1 -- d2 )  
  1162. \  Replace the top double number with its absolute value.
  1163.                 POP AX
  1164.                 OR AX, AX
  1165.             0>= IF
  1166.                         1PUSH
  1167.                 THEN
  1168.                 POP DX
  1169.                 NEG AX
  1170.                 NEG DX
  1171.                 SBB AX, # 0
  1172.                 2PUSH
  1173.                 END-CODE
  1174.  
  1175. CODE D2*        ( d -- d*2 )  \  32 bit left shift
  1176.                 POP AX          POP DX
  1177.                 SHL DX, # 1     RCL AX, # 1
  1178.                 2PUSH           END-CODE
  1179.  
  1180. CODE D2/        ( d -- d/2 )  \ 32 bit arithmetic right shift
  1181.                 POP AX          POP DX
  1182.                 SAR AX, # 1     RCR DX, # 1
  1183.                 2PUSH           END-CODE
  1184.  
  1185. CODE UD16/      ( d -- d/16 )   \ 32 bit UNSIGNED right shift 4 bits
  1186.                 POP AX          POP DX
  1187.                 SHR AX, # 1     RCR DX, # 1
  1188.                 SHR AX, # 1     RCR DX, # 1
  1189.                 SHR AX, # 1     RCR DX, # 1
  1190.                 SHR AX, # 1     RCR DX, # 1
  1191.                 2PUSH           END-CODE
  1192.  
  1193. : D-            ( d1 d2 -- d3 )
  1194. \ Subtract double number at top from second double number.
  1195.                 DNEGATE D+   ;
  1196.  
  1197. : ?DNEGATE      ( d1 n -- d2 )  
  1198. \  If number at top is negative, negate the double number underneath.
  1199.                 0< IF   DNEGATE   THEN   ;
  1200.  
  1201. : D0=           ( d -- f )  
  1202. \  If double number is 0.0 , return TRUE flag. Else return FALSE.
  1203.                 OR 0= ;
  1204.  
  1205. : D=            ( d1 d2 -- f )  
  1206. \ If top two double numbers are equal, replace with TRUE flag; else FALSE.
  1207.                 D-  D0=  ;
  1208.  
  1209. CODE DU<        ( ud1 ud2 -- Flag )
  1210. \ Unsigned compare double numbers.  If ud1 < ud2, return TRUE.  Else FALSE.
  1211.                 pop dx          pop bx
  1212.                 pop cx          pop ax
  1213.                 sub ax, bx      sbb cx, dx      sbb ax, ax
  1214.                 1push           end-code
  1215.  
  1216. : D<            ( d1 d2 -- f )
  1217. \ Signed compare two double numbers.  If d1 < d2, return TRUE.
  1218.                 2 PICK OVER =
  1219.                 IF      DU<
  1220.                 ELSE  NIP ROT DROP <  THEN  ;
  1221.  
  1222. : D>            ( d1 d2 -- f ) 
  1223. \ Signed compare two double numbers.  If d1 > d2 , return TRUE.
  1224.                 2SWAP D<   ;
  1225.  
  1226. : 4DUP          ( a b c d -- a b c d a b c d ) 
  1227. \ Duplicate top 4 single numbers (or two double numbers) on the stack.
  1228.                 2OVER 2OVER   ;
  1229.  
  1230. : DMIN          ( d1 d2 -- d3 )  
  1231. \  Replace the top two double numbers with the smaller of the two (signed).
  1232.                 4DUP D> IF  2SWAP  THEN 2DROP ;
  1233.  
  1234. : DMAX          ( d1 d2 -- d3 ) 
  1235. \  Replace the top two double numbers with the larger of the two (signed).
  1236.                 4DUP D< IF  2SWAP  THEN  2DROP ;        \ 05/25/90 tjz
  1237.  
  1238. CODE *D         ( n1 n2 -- d# )
  1239. \ Obtain the 32 bit signed product of two 16 bit numbers.
  1240.                 POP CX          POP AX          IMUL CX
  1241.                 PUSH AX         PUSH DX
  1242.                 NEXT            END-CODE
  1243.  
  1244. : M/MOD         ( d# n1 -- rem quot )
  1245. \ Divide a signed double by a signed single, leaving a remainder and 
  1246. \ quotient.
  1247.                 ?DUP
  1248.                 IF  dup>r  2DUP XOR >R  >R DABS R@ ABS  UM/MOD
  1249.                         SWAP R> ?NEGATE
  1250.                         SWAP R> 0<
  1251.                         IF  NEGATE OVER
  1252.                                 IF  1- R@ ROT - SWAP  THEN
  1253.                         THEN    r>drop
  1254.                 THEN  ;
  1255.  
  1256. : MU/MOD        ( ud# un1 -- rem d#quot )
  1257. \  Divide unsigned double by a single, leaving a remainder and quotient.
  1258.                 >R  0  R@  UM/MOD  R>  SWAP  >R  UM/MOD  R>   ;
  1259.  
  1260. CODE /          ( num den --- quot )  \  Floored and signed division.
  1261.                 POP BX          POP AX          CWD
  1262.                 MOV CX, BX      XOR CX, DX
  1263.             0>= IF                              \ POSITIVE QUOTIENT CASE
  1264.                 IDIV BX         1PUSH
  1265.             THEN
  1266.                 IDIV BX         OR DX, DX
  1267.             0<> IF
  1268.                 DEC AX
  1269.             THEN
  1270.                 1PUSH           END-CODE
  1271.  
  1272. CODE /MOD       ( num den --- rem quot )
  1273. \ Divide two signed numbers and return the floored division and remainder.
  1274.                 POP BX          POP AX          CWD
  1275.                 MOV CX, BX      XOR CX, DX
  1276.             0>= IF
  1277.                 IDIV BX         2PUSH
  1278.             THEN
  1279.                 IDIV BX         OR DX, DX
  1280.             0<> IF
  1281.                 ADD DX, BX      DEC AX
  1282.            THEN
  1283.                 2PUSH           END-CODE
  1284.  
  1285. : MOD           ( n1 n2 -- rem )
  1286. \ Divide the second signed number on the stack by the top. 
  1287. \ Return the remainder (modulus).
  1288.                 /MOD  DROP  ;
  1289.  
  1290. CODE */MOD      ( n1 n2 n3 --- rem quot )
  1291. \  Multiply n1 and n2.  Divide the result by n3. 
  1292. \  Return the remainder and quotient.
  1293.                 POP BX          POP AX          POP CX
  1294.                 IMUL CX         MOV CX, BX      XOR CX, DX
  1295.             0>= IF
  1296.                 IDIV BX         2PUSH
  1297.             THEN
  1298.                 IDIV BX         OR DX, DX
  1299.             0<> IF
  1300.                 ADD DX, BX      DEC AX
  1301.             THEN
  1302.                 2PUSH           END-CODE
  1303.  
  1304. : */            ( n1 n2 n3 -- n1*n2/n3 ) 
  1305. \  Multiply n1 by n2.  Divide the product by n3.  Return the quotient.
  1306.                 */MOD  NIP  ;
  1307.  
  1308. : ROLL          ( n1 n2 .. nk k -- n2 n3 .. nk n1 )
  1309. \  Rotate k values on the stack, bringing the deepest to the top.
  1310.                 >R R@ PICK   SP@ DUP 2+   R> 1+ 2* CMOVE>  DROP  ;
  1311.  
  1312. : 2ROT          ( a b c d e f - c d e f a b )   
  1313. \  Rotate the top three double numbers, bringing the deepest pair to top.
  1314.                 5 ROLL  5 ROLL  ;
  1315.  
  1316. : PARAGRAPH     ( bytes -- paragraphs )
  1317. \ convert bytes to a whole number of paragraphs equal or greater than bytes.
  1318.                 15 + U16/ ;
  1319.  
  1320. : DPARAGRAPH    ( dbl_bytes -- paragraphs )
  1321. \ convert dbl_bytes to a whole number of paragraphs equal or greater
  1322. \ than dbl_bytes.
  1323.                 15. D+ UD16/ DROP ;
  1324.  
  1325.