home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PROGRAMS / UTILS / LASER / FPC35_5.ZIP / FPCSRC.ZIP / KERNEL1.SEQ < prev    next >
Encoding:
Text File  |  1989-09-26  |  45.0 KB  |  1,279 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 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 -- ) [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. DECIMAL
  557.  
  558. CODE SP@        ( -- n )
  559. \ Push the address of the top element on the parameter stack (prior to push).
  560.                 MOV AX, SP      1PUSH           END-CODE
  561. \ Can't use the following because it doesn't work on an 8088.
  562. \               PUSH SP         NEXT            END-CODE
  563.  
  564. CODE SP!        ( n -- )
  565. \ Set the parameter stack pointer to specified value.
  566.                 POP SP          NEXT            END-CODE
  567.  
  568. CODE RP@        ( -- addr )
  569. \ Push the address of the top element of the return stack
  570. \ onto the parameter stack.
  571.                 PUSH RP         NEXT            END-CODE
  572.  
  573. CODE RP!        ( n -- )  \ Set the return stack pointer to n .
  574.                 POP RP          NEXT            END-CODE
  575.  
  576. CODE DROP       ( n1 -- )
  577.                 ADD SP, # 2     NEXT            END-CODE
  578.  
  579. CODE DUP        ( n1 -- n1 n1 )  \ Duplicate the top element of the stack.
  580.                 MOV DI, SP      \ 2
  581.                 PUSH 0 [DI]     \ 21 = 23
  582.                 NEXT            END-CODE
  583.  
  584. CODE SWAP       ( n1 n2 -- n2 n1 )
  585. \ Exchange the top two items on the stack.
  586.                 POP DX          POP AX
  587.                 2PUSH           END-CODE
  588.  
  589. CODE OVER       ( n1 n2 -- n1 n2 n1 )
  590. \ Push a copy of the second stack item.
  591.                 MOV DI, SP
  592.                 PUSH 2 [DI]
  593.                 NEXT            END-CODE
  594.  
  595. CODE PLUCK      ( n1 n2 n3 --- n1 n2 n3 n1 )  
  596. \ Copy the third stack item to top
  597.                 MOV DI, SP
  598.                 PUSH 4 [DI]
  599.                 NEXT            END-CODE
  600.  
  601. CODE TUCK       ( n1 n2 -- n2 n1 n2 )
  602. \ Tuck the first stack element under the second.
  603.                 POP AX          POP DX
  604.                 PUSH AX         2PUSH           END-CODE
  605.  
  606. CODE NIP        ( n1 n2 -- n2 )  \ Delete the second stack item.
  607.                 POP AX          ADD SP, # 2
  608.                 1PUSH           END-CODE
  609.  
  610. CODE ROT        ( n1 n2 n3 --- n2 n3 n1 )  
  611. \ Rotate top three stack values, bringing the third item to the top.
  612.                 POP DX          POP BX          POP AX
  613.                 PUSH BX         2PUSH           END-CODE
  614.  
  615. CODE -ROT       ( n1 n2 n3 --- n3 n1 n2 )  \ Inverse of ROT
  616.                 POP BX          POP AX          POP DX
  617.                 PUSH BX         2PUSH           END-CODE
  618.  
  619. CODE FLIP       ( n1 -- n2 )  \ Exchange the high and low halves of a word
  620.                 POP AX          XCHG AL, AH
  621.                 1PUSH           END-CODE
  622.  
  623. CODE SPLIT      ( n1 --- n2 n3 )        \ Splits n1 into two bytes, low, high
  624.                 POP BX
  625.                 SUB AX, AX
  626.                 MOV AL, BL
  627.                 PUSH AX
  628.                 MOV AL, BH
  629.                 1PUSH           END-CODE
  630.  
  631.                                         \ 07/03/89 RB
  632. CODE JOIN       ( n1 n2 -- n3 )         \ Join bytes into one word, n2 = hi
  633.                 POP DX
  634.                 POP AX
  635.                 MOV AH, DL
  636.                 1PUSH           END-CODE
  637.  
  638. CODE ?DUP       ( n1 -- [n1] n1 )       \ duplicate n1 if <> 0
  639.                 MOV DI, SP              \  2
  640.                 MOV CX, 0 [DI]          \ 13
  641.           CX<>0 IF                      \ 18/6
  642.                         PUSH CX         \ 11
  643.                 THEN                    \ 32 without push
  644.                 NEXT    END-CODE        \ 33 with    push
  645.  
  646.                                         \ 07/03/89 RB
  647. CODE ?DROP      ( n false -- false | n true -- n true )
  648.                 POP AX
  649.                 OR AX, AX
  650.              0= IF      INC SP
  651.                         INC SP
  652.                 THEN
  653.                 1PUSH           END-CODE
  654.  
  655. CODE R>         ( -- n )
  656. \ Pop an item from the return stack and push onto parameter stack.
  657.                 PUSH 0 [RP]
  658.                 ADD RP, # 2
  659.                 NEXT            END-CODE
  660.  
  661. CODE R>DROP     ( --- )  \ Drop an item from the return stack
  662.                 ADD RP, # 2
  663.                 NEXT            END-CODE
  664.  
  665. CODE DUP>R      ( n1 --- n1 )  
  666. \ Pushes a copy of the top item on parameter stack to the return stack.
  667.                 XCHG SP, RP     \  4
  668.                 PUSH 0 [RP]     \ 16 + 5
  669.                 XCHG SP, RP     \  4 = 29 cycles
  670.                 NEXT            END-CODE
  671.  
  672. CODE >R         ( n -- )  
  673. \ Pop top of parameter stack and push value onto return stack.
  674.                 SUB RP, # 2     \  4
  675.                 POP 0 [RP]      \ 22 = 26 cycles
  676.                 NEXT            END-CODE
  677.  
  678. CODE 2R>        ( -- n1 n2 )  
  679. \ Pop two items from return stack onto parameter stack
  680.                 PUSH 2 [RP]     \ 25
  681.                 PUSH 0 [RP]     \ 21
  682.                 ADD RP, # 4     \  4 = 50 cycles
  683.                 NEXT            END-CODE
  684.  
  685. CODE 2>R        ( n1 n2 -- )  
  686. \ Pop two items from parameter stack, push onto return stack.
  687.                 SUB RP, # 4     \  4
  688.                 POP 0 [RP]      \ 22
  689.                 POP 2 [RP]      \ 26 = 52 cycles
  690.                 NEXT            END-CODE
  691.  
  692. CODE R@         ( -- n )  
  693. \ Push a copy of top item on return stack onto parameter stack.
  694.                 PUSH 0 [RP]
  695.                 NEXT            END-CODE
  696.  
  697. CODE 2R@        ( -- n1 n2 )  
  698. \ Push a copy of the top two items on the return stack onto the parameter stack.
  699.                 PUSH 2 [RP]
  700.                 PUSH 0 [RP]
  701.                 NEXT            END-CODE
  702.  
  703. CODE PICK       ( nm ... n2 n1 k -- nm ... n2 n1 nk )  
  704. \ Push a copy of the n-th item on paramter stack.
  705.                 POP DI          SHL DI, # 1     ADD DI, SP
  706.                 PUSH 0 [DI]
  707.                 NEXT            END-CODE
  708.  
  709. CODE RPICK      ( nm ... n2 n1 k -- nm ... n2 n1 nk )   \ return stack pick
  710.                 POP DI          SHL DI, # 1
  711.                 PUSH 0 [RP+DI]
  712.                 NEXT            END-CODE
  713.  
  714. CODE AND        ( n1 n2 -- n3 )  
  715. \ Perform bit-wise logical AND of top two items.
  716.                 POP BX          POP AX          AND AX, BX
  717.                 1PUSH           END-CODE
  718.  
  719. CODE OR         ( n1 n2 -- n3 )
  720. \ Perform bit-wise logical OR of top two items on parameter stack.
  721.                 POP BX          POP AX          OR AX, BX
  722.                 1PUSH           END-CODE
  723.  
  724. CODE XOR        ( n1 n2 -- n3 )
  725. \ Perform bit-wise logical Exclusive OR of top two stack items.
  726.                 POP BX          POP AX          XOR AX, BX
  727.                 1PUSH           END-CODE
  728.  
  729. CODE NOT        ( n -- n' )  \ Logically invert the bits of top stack item.
  730.                 POP AX          NOT AX
  731.                 1PUSH           END-CODE
  732.  
  733. -1 CONSTANT TRUE
  734.  0 CONSTANT FALSE
  735.  
  736. CODE CSET       ( b addr -- )  
  737. \ Logical OR of l.s. 8 bits of "b" with byte at "addr".
  738.                 POP BX          POP AX          OR 0 [BX], AL
  739.                 NEXT            END-CODE
  740.  
  741. CODE CRESET     ( b addr -- )
  742. \ Clear bits in byte at addr corresponding to "1" bits in b .
  743.                 POP BX          POP AX
  744.                 NOT AX          AND 0 [BX], AL
  745.                 NEXT            END-CODE
  746.  
  747. CODE CTOGGLE    ( b addr -- )
  748. \ Toggle bits in byte at addr corresponding to "1" bits in b .
  749.                 POP BX          POP AX          XOR 0 [BX], AL
  750.                 NEXT            END-CODE
  751.  
  752. CODE ON         ( addr -- )  \ Set word at addr to "true"
  753.                 POP BX          MOV 0 [BX], # TRUE WORD
  754.                 NEXT            END-CODE
  755.  
  756. CODE OFF        ( addr -- )  \ Clear all bits of word at addr.
  757.                 POP BX          MOV 0 [BX], # FALSE WORD
  758.                 NEXT            END-CODE
  759.  
  760. CODE -1!        ( addr -- )  \ Same as ON
  761.                 POP BX          MOV 0 [BX], # TRUE WORD
  762.                 NEXT            END-CODE
  763.  
  764. CODE 0!         ( addr -- )  \ Same as OFF
  765.                 POP BX          MOV 0 [BX], # FALSE WORD
  766.                 NEXT            END-CODE
  767.  
  768. CODE INCR       ( addr --- )  \ Increment word at addr.
  769.                 POP BX          INC 0 [BX] WORD
  770.                 NEXT            END-CODE
  771.  
  772. CODE DECR       ( addr --- )  \ Decrement word at addr.
  773.                 POP BX          DEC 0 [BX] WORD
  774.                 NEXT            END-CODE
  775.  
  776. CODE 0DECR      ( addr -- )     \ Decrement to zero only, not below
  777.                 POP BX
  778.                 DEC 0 [BX] WORD
  779.              0< IF      MOV 0 [BX], # 0 WORD
  780.                 THEN
  781.                 NEXT            END-CODE
  782.  
  783. CODE +          ( n1 n2 -- sum )  \ Add top two elements
  784.                 POP BX          POP AX          ADD AX, BX
  785.                 1PUSH           END-CODE
  786.  
  787. CODE NEGATE     ( n -- n' )  \ Arithmetically negate top stack element.
  788.                 POP AX          NEG AX
  789.                 1PUSH           END-CODE
  790.  
  791. CODE -          ( n1 n2 -- n1-n2 )  \ Subtract top stack element from second
  792.                 POP BX          POP AX          SUB AX, BX
  793.                 1PUSH           END-CODE
  794.  
  795. CODE ABS        ( n1 -- n2 )   \  Return absolute value of top stack item 
  796.                 POP AX
  797.                 CWD
  798.                 XOR AX, DX
  799.                 SUB AX, DX
  800.                 1PUSH
  801.                 END-CODE
  802.  
  803. CODE D+!        ( d addr -- )  
  804. \ Add double number "d" to double value at "addr"
  805.                 POP BX          POP AX          POP DX
  806.                 ADD 2 [BX], DX  ADC 0 [BX], AX
  807.                 NEXT            END-CODE
  808.  
  809. CODE +!         ( n addr -- )  \ Add "n" to word at "addr"
  810.                 POP BX          POP AX          ADD 0 [BX], AX
  811.                 NEXT            END-CODE
  812.  
  813. CODE C+!        ( n addr -- )  \ Add "n" to byte at "addr"
  814.                 POP BX          POP AX          ADD 0 [BX], AL
  815.                 NEXT            END-CODE
  816.  
  817.  
  818. \ Since the 8086 has a seperate IO path, we define a Forth
  819. \ interface to it.  Use P@ and P! to read or write directly to
  820. \ the 8086 IO ports.
  821.  
  822. CODE PC@        ( port# -- n )  
  823. \ Read 8-bit port at "port#" and push value on stack.
  824.                 POP DX          IN AL, DX       SUB AH, AH
  825.                 PUSH AX         NEXT            END-CODE
  826.  
  827. CODE P@         ( port# -- n )
  828. \ Read 16-bit value at "port#" and push value on stack.
  829.                 POP DX          IN AX, DX       PUSH AX
  830.                 NEXT            END-CODE
  831.  
  832. CODE PC!        ( n port# -- )
  833. \ Write 8 bit value "n" to "port#".
  834.                 POP DX          POP AX          OUT DX, AL
  835.                 NEXT            END-CODE
  836.  
  837. CODE P!         ( n port# -- )
  838. \ Write 16 bit value "n" to "port#".
  839.                 POP DX          POP AX          OUT DX, AX
  840.                 NEXT            END-CODE
  841.  
  842. CODE PDOS       ( addr drive# --- f1 ) 
  843. \ Read path of drive into addr, NULL terminated.
  844.                 pop dx          pop ax
  845.                 push si         mov si, ax
  846.                 mov ah, # $47   int $21
  847.              u< if
  848.                 mov al, # 1
  849.              else
  850.                 mov al, # 0
  851.              then
  852.                 sub ah, ah      pop si
  853.                 1push           end-code
  854.  
  855. #TTHREADS CONSTANT #THREADS   \ Number of Threads used in dictionary.
  856.  
  857. CODE 2*         ( n -- 2*n )  \ Logical left shift n by 1 position.
  858.                 POP AX          SHL AX, # 1
  859.                 1PUSH           END-CODE
  860.  
  861. CODE 2/         ( n -- n/2 )  \ Arithmetic right shift of n by 1 position
  862.                 POP AX          SAR AX, # 1
  863.                 1PUSH           END-CODE
  864.  
  865. CODE U2/        ( u -- u/2 )  \ Logical right shift of n by 1 position
  866.                 POP AX          SHR AX, # 1
  867.                 1PUSH           END-CODE
  868.  
  869. CODE U16/       ( u -- u/16 ) \ Logical shift right by 4 bit positions. 
  870.                 POP AX
  871.                 SHR AX, # 1     SHR AX, # 1
  872.                 SHR AX, # 1     SHR AX, # 1
  873.                 1PUSH           END-CODE
  874.  
  875. CODE U8/        ( u -- u/8 )  \ Logical shift right by 3 bit positions.
  876.                 POP AX
  877.                 SHR AX, # 1
  878.                 SHR AX, # 1
  879.                 SHR AX, # 1
  880.                 1PUSH           END-CODE
  881.  
  882. CODE 8*         ( n -- 8*n )  \ Logical shift left by 3 positions.
  883.                 POP AX          SHL AX, # 1
  884.                 SHL AX, # 1     SHL AX, # 1
  885.                 1PUSH           END-CODE
  886.  
  887. CODE 1+         ( n1 --- n2 )  \  Add 1 to top stack element
  888.                 POP AX          INC AX
  889.                 1PUSH           END-CODE
  890.  
  891. CODE 2+         ( n1 --- n2 )  \  Add 2 to top stack element
  892.                 POP AX          ADD AX, # 2
  893.                 1PUSH           END-CODE
  894.  
  895. CODE 1-         ( n1 --- n2 )  \  Subtract 1 from top stack element
  896.                 POP AX          DEC AX
  897.                 1PUSH           END-CODE
  898.  
  899. CODE 2-         ( n1 --- n2 )  \  Subtract 2 from top stack element
  900.                 POP AX          SUB AX, # 2
  901.                 1PUSH           END-CODE
  902.  
  903. CODE UM*        ( n1 n2 -- d )  
  904. \  Form a 32 bit product from two 16 bit unsigned numbers
  905.                 POP AX          POP BX          MUL BX
  906.                 XCHG DX, AX     2PUSH           END-CODE
  907.  
  908. CODE *          ( n1 n2 -- n3 )  
  909. \  Form a 16 bit product from two 16 bit numbers
  910.                 POP AX          POP BX          MUL BX
  911.                 1PUSH           END-CODE
  912.  
  913. : U*D           ( n1 n2 -- d )  
  914. \  Form a 32 bit product from two 16 bit unsigned numbers
  915.                 UM*   ;
  916.  
  917. CODE UM/MOD     ( ud un -- URemainder UQuotient )
  918. \ Unsigned double number divided by unsigned single results in unsigned
  919. \ remainder and quotient, with quotient on top.
  920.                 POP BX          POP DX          POP AX
  921.                 CMP DX, BX
  922.             U>=  ( divide by zero? )
  923.             IF
  924.                 MOV AX, # -1    MOV DX, AX      2PUSH
  925.             THEN
  926.                 DIV BX          2PUSH           END-CODE
  927.  
  928. CODE 0=         ( n -- f )  \  Return TRUE if n is zero.  Otherwise FALSE.
  929.                 POP AX          SUB AX, # 1     SBB AX, AX
  930.                 1PUSH           END-CODE
  931.  
  932. CODE 0<         ( n -- f )  
  933. \  If n is negative, return TRUE.  Otherwise FALSE.
  934.                 POP AX          CWD             PUSH DX
  935.                 NEXT            END-CODE
  936.  
  937. CODE 0>         ( n -- f )
  938. \  If n is greater than 0, return TRUE.  Otherwise FALSE.
  939.                 POP AX          NEG AX
  940.            OV<> IF      CWD
  941.                         PUSH DX
  942.                         NEXT
  943.                 THEN
  944.                 SHL AX, # 1
  945.                 1PUSH           END-CODE
  946.  
  947. CODE 0<>        ( n -- f )
  948. \  If n is not equal to 0, return TRUE.  Otherwise FALSE.
  949.                 POP AX          NEG AX          SBB AX, AX
  950.                 1PUSH           END-CODE
  951.  
  952. CODE =          ( n1 n2 -- f )
  953. \  If n1 is equal to n2, return TRUE.  Otherwise FALSE.
  954.                 POP AX          POP CX          SUB AX, CX
  955.                 SUB AX, # 1     SBB AX, AX
  956.                 1PUSH           END-CODE
  957.  
  958. CODE <>         ( n1 n2 -- f )
  959. \  If n1 is not equal to n2, return TRUE.  Otherwise FALSE.
  960.                 POP AX          POP CX          SUB AX, CX
  961.                 NEG AX          SBB AX, AX
  962.                 1PUSH           END-CODE
  963.  
  964. : ?NEGATE       ( n1 n2 -- n3 )  \  If n2 is negative, negate n1.
  965.                 0< IF    NEGATE   THEN   ;
  966.  
  967. CODE   U<       ( n1 n2 -- f )  
  968. \  If unsigned n1 is less than unsigned n2, return TRUE, otherwise FALSE.
  969.                 POP CX          POP AX          SUB AX, CX
  970.                 SBB AX, AX
  971.                 1PUSH           END-CODE
  972.  
  973. CODE   U>       ( n1 n2 -- f )
  974. \  If unsigned n1 is greater than unsigned n2, return TRUE, otherwise FALSE.
  975.                 POP AX          POP CX          SUB AX, CX
  976.                 SBB AX, AX
  977.                 1PUSH           END-CODE
  978.  
  979. CODE <          ( n1 n2 -- f )
  980. \  If signed n1 is less than signed n2, return TRUE, otherwise return FALSE.
  981.                 POP AX          POP BX          CMP BX, AX
  982.              >= IF
  983.                         SUB AX, AX
  984.                         1PUSH
  985.                 THEN
  986.                 MOV AX, # TRUE  1PUSH           END-CODE
  987.  
  988. CODE >          ( n1 n2 -- f )
  989. \  If signed n1 is greater than signed n2, return TRUE, otherwise FALSE.
  990.                 POP AX          POP BX          CMP BX, AX
  991.              <= IF
  992.                         SUB AX, AX
  993.                         1PUSH
  994.                 THEN
  995.                 MOV AX, # TRUE  1PUSH           END-CODE
  996.  
  997. CODE UMIN       ( n1 n2 -- n3 )
  998. \ Return smaller of n1 or n2, treated as unsigned numbers.
  999.                 POP AX          POP BX          CMP BX, AX
  1000.             U<= IF
  1001.                         PUSH BX
  1002.                         NEXT
  1003.                 THEN
  1004.                 1PUSH           END-CODE
  1005.  
  1006. CODE MIN        ( n1 n2 -- n3 )
  1007. \ Return smaller of n1 or n2, treated as signed numbers.
  1008.                 POP AX          POP BX          CMP BX, AX
  1009.              <= IF
  1010.                         PUSH BX
  1011.                         NEXT
  1012.                 THEN
  1013.                 1PUSH           END-CODE
  1014.  
  1015. CODE MAX        ( n1 n2 -- n3 )
  1016. \ Return larger of n1 or n2, treated as signed numbers.
  1017.                 POP AX          POP BX
  1018.                 CMP BX, AX
  1019.              <= IF
  1020.                         1PUSH
  1021.                 THEN
  1022.                 PUSH BX         NEXT            END-CODE
  1023.  
  1024. CODE 0MAX       ( n1 -- n3 )
  1025. \ Return larger of n1 or ZERO, treated as signed numbers.
  1026.                 POP AX
  1027.                 SUB BX, BX
  1028.                 CMP BX, AX
  1029.              <= IF
  1030.                         1PUSH
  1031.                 THEN
  1032.                 PUSH BX
  1033.                 NEXT            END-CODE
  1034.  
  1035. CODE UMAX       ( n1 n2 -- n3 )
  1036. \ Return larger of n1 or n2, treated as unsigned numbers.
  1037.                 POP AX          POP BX          CMP BX, AX
  1038.             U<= IF
  1039.                         1PUSH
  1040.                 THEN
  1041.                 PUSH BX         NEXT            END-CODE
  1042.  
  1043. CODE WITHIN     ( n lo hi -- flag )
  1044. \  Returns TRUE if  lo <= n < hi .  Signed comparison
  1045.                 POP DI          POP CX          POP DX
  1046.                 XOR AX, AX
  1047.                 CMP DX, DI
  1048.               < IF      CMP DX, CX
  1049.                      >= IF      DEC AX
  1050.                         THEN
  1051.                 THEN
  1052.                 1PUSH           END-CODE
  1053.  
  1054. CODE BETWEEN   ( n lo hi -- flag )
  1055. \  Returns TRUE if  lo <= n <= hi . Signed comparison
  1056.                 XOR AX, AX      POP BX          POP CX
  1057.                 POP DX
  1058.                 CMP DX, BX
  1059.              <= IF      CMP DX, CX
  1060.                      >= IF      DEC AX
  1061.                         THEN
  1062.                 THEN
  1063.                 1PUSH           END-CODE
  1064.  
  1065. CODE 2@         ( addr -- d )  \  Fetch a 32 bit value from addr
  1066.                 POP BX
  1067.                 PUSH 2 [BX]
  1068.                 PUSH 0 [BX]
  1069.                 NEXT            END-CODE
  1070.  
  1071. CODE 2!         ( d addr -- )  \ Store a 32 bit value into addr
  1072.                 POP BX          POP 0 [BX]      POP 2 [BX]
  1073.                 NEXT            END-CODE
  1074.  
  1075. CODE 2DROP      ( d -- )  \ Drop two 16 bit values from stack
  1076.                 ADD SP, # 4
  1077.                 NEXT            END-CODE
  1078.  
  1079. CODE 3DROP      ( n1 n2 n3 -- )  \ Drop 3 items from the stack.
  1080.                 ADD SP, # 6
  1081.                 NEXT            END-CODE
  1082.  
  1083. CODE 2DUP       ( d -- d d )  \  Duplicate two top items on stack.
  1084.                 MOV DI, SP
  1085.                 PUSH 2 [DI]
  1086.                 PUSH 0 [DI]
  1087.                 NEXT            END-CODE
  1088.  
  1089. CODE 3DUP       ( n1 n2 n3 -- n1 n2 n3 n1 n2 n3 )
  1090. \ Duplicate top 3 items on stack.
  1091.                 MOV DI, SP
  1092.                 PUSH 4 [DI]
  1093.                 PUSH 2 [DI]
  1094.                 PUSH 0 [DI]
  1095.                 NEXT            END-CODE
  1096.  
  1097. CODE 2SWAP      ( d1 d2 -- d2 d1 )
  1098. \ Exchange top two pairs of numbers on stack.
  1099.                 POP CX          POP BX
  1100.                 POP AX          POP DX
  1101.                 PUSH BX         PUSH CX
  1102.                 2PUSH           END-CODE
  1103.  
  1104. CODE 2OVER      ( d2 d2 -- d1 d2 d1 )
  1105. \ Copy second pair of numbers over top pair of numbers on stack.
  1106.                 MOV DI, SP      \  2
  1107.                 PUSH 6 [DI]     \ 24
  1108.                 PUSH 4 [DI]     \ 24 = 50
  1109.                 NEXT            END-CODE
  1110.  
  1111. CODE D+         ( d1 d2 -- dsum )  \  Add top two double numbers on stack
  1112.                 POP AX          POP DX
  1113.                 POP BX          POP CX
  1114.                 ADD DX, CX      ADC AX, BX
  1115.                 2PUSH           END-CODE
  1116.  
  1117. CODE DNEGATE    ( d# -- d#' )  \  Negate double number on top of stack.
  1118.                 POP AX
  1119.                 POP DX
  1120.                 NEG AX
  1121.                 NEG DX
  1122.                 SBB AX, # 0
  1123.                 2PUSH
  1124.                 END-CODE
  1125.  
  1126. CODE   S>D      ( n -- d )
  1127. \  Convert single signed number to signed double
  1128.                 POP AX          CWD             XCHG DX, AX
  1129.                 2PUSH           END-CODE
  1130.  
  1131. CODE DABS       ( d1 -- d2 )  
  1132. \  Replace the top double number with its absolute value.
  1133.                 POP AX
  1134.                 OR AX, AX
  1135.             0>= IF
  1136.                         1PUSH
  1137.                 THEN
  1138.                 POP DX
  1139.                 NEG AX
  1140.                 NEG DX
  1141.                 SBB AX, # 0
  1142.                 2PUSH
  1143.                 END-CODE
  1144.  
  1145. CODE D2*        ( d -- d*2 )  \  32 bit left shift
  1146.                 POP AX          POP DX
  1147.                 SHL DX, # 1     RCL AX, # 1
  1148.                 2PUSH           END-CODE
  1149.  
  1150. CODE D2/        ( d -- d/2 )  \ 32 bit arithmetic right shift
  1151.                 POP AX          POP DX
  1152.                 SAR AX, # 1     RCR DX, # 1
  1153.                 2PUSH           END-CODE
  1154.  
  1155. : D-            ( d1 d2 -- d3 )  
  1156. \ Subtract double number at top from second double number.
  1157.                 DNEGATE D+   ;
  1158.  
  1159. : ?DNEGATE      ( d1 n -- d2 )  
  1160. \  If number at top is negative, negate the double number underneath.
  1161.                 0< IF   DNEGATE   THEN   ;
  1162.  
  1163. : D0=           ( d -- f )  
  1164. \  If double number is 0.0 , return TRUE flag. Else return FALSE.
  1165.                 OR 0= ;
  1166.  
  1167. : D=            ( d1 d2 -- f )  
  1168. \ If top two double numbers are equal, replace with TRUE flag; else FALSE.
  1169.                 D-  D0=  ;
  1170.  
  1171. CODE DU<        ( ud1 ud2 -- Flag )
  1172. \ Unsigned compare double numbers.  If ud1 < ud2, return TRUE.  Else FALSE.
  1173.                 pop dx          pop bx
  1174.                 pop cx          pop ax
  1175.                 sub ax, bx      sbb cx, dx      sbb ax, ax
  1176.                 1push           end-code
  1177.  
  1178. : D<            ( d1 d2 -- f )
  1179. \ Signed compare two double numbers.  If d1 < d2, return TRUE.
  1180.                 2 PICK OVER =
  1181.                 IF      DU<
  1182.                 ELSE  NIP ROT DROP <  THEN  ;
  1183.  
  1184. : D>            ( d1 d2 -- f ) 
  1185. \ Signed compare two double numbers.  If d1 > d2 , return TRUE.
  1186.                 2SWAP D<   ;
  1187.  
  1188. : 4DUP          ( a b c d -- a b c d a b c d ) 
  1189. \ Duplicate top 4 single numbers (or two double numbers) on the stack.
  1190.                 2OVER 2OVER   ;
  1191.  
  1192. : DMIN          ( d1 d2 -- d3 )  
  1193. \  Replace the top two double numbers with the smaller of the two (signed).
  1194.                 4DUP D> IF  2SWAP  THEN 2DROP ;
  1195.  
  1196. : DMAX          ( d1 d2 -- d3 ) 
  1197. \  Replace the top two double numbers with the larger of the two (signed).
  1198.                 2DUP D< IF  2SWAP  THEN  2DROP ;
  1199.  
  1200. CODE *D         ( n1 n2 -- d# )
  1201. \ Obtain the 32 bit signed product of two 16 bit numbers.
  1202.                 POP CX          POP AX          IMUL CX
  1203.                 PUSH AX         PUSH DX
  1204.                 NEXT            END-CODE
  1205.  
  1206. : M/MOD         ( d# n1 -- rem quot )
  1207. \ Divide a signed double by a signed single, leaving a remainder and 
  1208. \ quotient.
  1209.                 ?DUP
  1210.                 IF  dup>r  2DUP XOR >R  >R DABS R@ ABS  UM/MOD
  1211.                         SWAP R> ?NEGATE
  1212.                         SWAP R> 0<
  1213.                         IF  NEGATE OVER
  1214.                                 IF  1- R@ ROT - SWAP  THEN
  1215.                         THEN    r>drop
  1216.                 THEN  ;
  1217.  
  1218. : MU/MOD        ( ud# un1 -- rem d#quot )
  1219. \  Divide unsigned double by a single, leaving a remainder and quotient.
  1220.                 >R  0  R@  UM/MOD  R>  SWAP  >R  UM/MOD  R>   ;
  1221.  
  1222. CODE /          ( num den --- quot )  \  Floored and signed division.
  1223.                 POP BX          POP AX          CWD
  1224.                 MOV CX, BX      XOR CX, DX
  1225.             0>= IF                              \ POSITIVE QUOTIENT CASE
  1226.                 IDIV BX         1PUSH
  1227.             THEN
  1228.                 IDIV BX         OR DX, DX
  1229.             0<> IF
  1230.                 DEC AX
  1231.             THEN
  1232.                 1PUSH           END-CODE
  1233.  
  1234. CODE /MOD       ( num den --- rem quot )
  1235. \ Divide two signed numbers and return the floored division and remainder.
  1236.                 POP BX          POP AX          CWD
  1237.                 MOV CX, BX      XOR CX, DX
  1238.             0>= IF
  1239.                 IDIV BX         2PUSH
  1240.             THEN
  1241.                 IDIV BX         OR DX, DX
  1242.             0<> IF
  1243.                 ADD DX, BX      DEC AX
  1244.            THEN
  1245.                 2PUSH           END-CODE
  1246.  
  1247. : MOD           ( n1 n2 -- rem )
  1248. \ Divide the second signed number on the stack by the top. 
  1249. \ Return the remainder (modulus).
  1250.                 /MOD  DROP  ;
  1251.  
  1252. CODE */MOD      ( n1 n2 n3 --- rem quot )
  1253. \  Multiply n1 and n2.  Divide the result by n3. 
  1254. \  Return the remainder and quotient.
  1255.                 POP BX          POP AX          POP CX
  1256.                 IMUL CX         MOV CX, BX      XOR CX, DX
  1257.             0>= IF
  1258.                 IDIV BX         2PUSH
  1259.             THEN
  1260.                 IDIV BX         OR DX, DX
  1261.             0<> IF
  1262.                 ADD DX, BX      DEC AX
  1263.             THEN
  1264.                 2PUSH           END-CODE
  1265.  
  1266. : */            ( n1 n2 n3 -- n1*n2/n3 ) 
  1267. \  Multiply n1 by n2.  Divide the product by n3.  Return the quotient.
  1268.                 */MOD  NIP  ;
  1269.  
  1270. : ROLL          ( n1 n2 .. nk k -- n2 n3 .. nk n1 )
  1271. \  Rotate k values on the stack, bringing the deepest to the top.
  1272.                 >R R@ PICK   SP@ DUP 2+   R> 1+ 2* CMOVE>  DROP  ;
  1273.  
  1274. : 2ROT          ( a b c d e f - c d e f a b )   
  1275. \  Rotate the top three double numbers, bringing the deepest pair to top.
  1276.                 5 ROLL  5 ROLL  ;
  1277.  
  1278.  
  1279.