Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/FFA.ZIP/KERNEL1.SEQ

Text File | 1988-01-11 | 25.9 KB | 825 lines

\ KERNEL86.SEQ  Source code for SKERNEL.COM,   modified by Tom Zimmer

ONLY FORTH   META ALSO FORTH

FALSE   CONSTANT INLINE_NEXT    \ Enable Inline NEXT

: ?.INLINE      ( --- )         \ Print state of INLINE_NEXT
                CR ." NEXT is currently " INLINE_NEXT >REV
                IF      [ASSEMBLER] INLINEON  [FORTH]
                        ."  INLINE. "
                ELSE    [ASSEMBLER] INLINEOFF [FORTH]
                        ."  NOT " >NORM ."  INLINE. "
                THEN    >NORM CR ;
?.INLINE

256 DP-T !      \ Set Dictionary pointer
  0 DP-X !      \ Set LIST DP

HERE   6000 + ' TARGET-ORIGIN >BODY !

IN-META

: ]]   ]   ;
: [[   [COMPILE] [   ; FORTH IMMEDIATE META

FORWARD: DEFINITIONS
FORWARD: [

LABEL ORIGIN    JMP HERE 8000 + \ jump to cold start: will be patched
                JMP HERE 8000 + \ jump to warm start: will be patched
                END-CODE

LABEL DPUSH     PUSH DX         END-CODE
LABEL APUSH     PUSH AX         END-CODE
LABEL >NEXT     LODSW ES:
                JMP AX          END-CODE

\ Create the FORTH vocabulary as the first definition in dictionary.

HERE-T ,-Y                      \ valid "previous" CFA for "CREATE

HERE-Y HERE-T CNHASH !-Y        \ first entry in >NAME hash table

HERE-T DUP 100 + CURRENT-T !    \ harmless

HERE-Y VOCABULARY FORTH   FORTH DEFINITIONS

                                \ #THREADS - 1 = 127 the mask.
0 OVER 2+ !-Y ( link )          \ ASCII F     15 AND = 6
                                \ ASCII F 5 + 127 AND = 75
2+ SWAP  >BODY-T
ASCII F 5 +                     \ hash is first char + length
#TTHREADS 1- AND 2*             \ Determine which thread FORTH goes in.
\ ( 12 ) 150
+ !-T ( thread 75 )  IN-META

VOCABULARY FILES

FILES DEFINITIONS

\ Create the linked list of files that have been loaded.

VARIABLE KERNEL1.SEQ

FORTH DEFINITIONS

LABEL NEST              \ JMP = 15 cycles  CALL = 19 cycles
        DEC RP          \ DEC =  3 cycles
        DEC RP          \        3 cycles
        MOV 0 [RP], IP  \ MOV = 14 cycles
        MOV DI, AX      \ * POP =  8 cycles
        MOV IP, 3 [DI]  \ *
        NEXT
        END-CODE
META

CODE EXIT     ( -- )
        MOV IP, 0 [RP]  \ MOV = 13 cycles
        INC RP          \ INC =  3 cycles
        INC RP          \        3 cycles
        NEXT
        END-CODE

CODE UNNEST   ( --- )
        MOV IP, 0 [RP]  INC RP          INC RP
        NEXT            END-CODE

LABEL DODOES
        DEC RP
        DEC RP
        MOV 0 [RP], IP
        POP DI
        MOV IP, 0 [DI]
        NEXT            END-CODE

VARIABLE UP

LABEL DOCONSTANT
        POP BX          PUSH 0 [BX]
        NEXT            END-CODE

LABEL DOUSER-VARIABLE
        POP BX          MOV AX, 0 [BX]  ADD AX, UP
        1PUSH           END-CODE

CODE (LIT)      ( -- n )
                LODSW ES:       1PUSH           END-CODE

T: LITERAL      ( n -- ) [TARGET] (LIT)   ,-X   T;
T: DLITERAL     ( d -- ) [TARGET] (LIT) ,-X   [TARGET] (LIT) ,-X   T;
T: ASCII        ( -- )   [COMPILE] ASCII [[ TRANSITION ]] LITERAL [META]  T;
T: [']          ( -- )   'T >BODY @
                         [[ TRANSITION ]] LITERAL  [META]   T;
: CONSTANT      ( n -- )
                RECREATE   232 C,-T
                [[ ASSEMBLER DOCONSTANT ]] LITERAL HERE 2+ - ,-T
                DUP ,-T   CONSTANT   ;

FORWARD: <(;CODE)>
T: DOES>        ( -- )
                [FORWARD] <(;CODE)> HERE-T ,-X
                HERE-T  ( DOES-OP ) 232 C,-T
                [[ ASSEMBLER DODOES ]] LITERAL HERE 2+ - ,-T
                HERE-X ,-T T;

: NUMERIC   ( -- )
                [FORTH] HERE [META] NUMBER   DPL @ 1+
                IF      [[ TRANSITION ]] DLITERAL [META]
                ELSE    DROP   [[ TRANSITION ]] LITERAL [META]   THEN  ;

: UNDEFINED     ( -- )
                HERE-X   0 ,-X
                IN-FORWARD  [FORTH] CREATE [META] TRANSITION
                [FORTH] ,   FALSE ,   [META]
                DOES>   FORWARD-CODE   ;

[FORTH] VARIABLE T-IN      META

: ]             ( -- )
                STATE-T ON   IN-TRANSITION
        BEGIN   >IN @ T-IN !
                BEGIN   BL WORD DUP C@ 0=       \ If nothing in line
                        ?FILLBUFF               \ Optionally refill buffer
                        INLEN @ 0> AND          \ and input buf not empty
                WHILE   DROP FILLTIB            \ refill the buffer
                REPEAT  ?UPPERCASE FIND
                IF      EXECUTE
                ELSE    COUNT NUMERIC?
                        IF      NUMERIC
                        ELSE    T-IN @ >IN !   UNDEFINED
                        THEN
                THEN    STATE-T @ 0=
        UNTIL ;

T: [   ( -- )   IN-META   STATE-T OFF   T;
T: ;   ( -- )   [TARGET] UNNEST   [[ TRANSITION ]] [   T;

 : :   ( -- )   TARGET-CREATE   233 C,-T        \ a JUMP instruction
                [[ ASSEMBLER NEST ]] LITERAL HERE 2+ - ,-T
                HERE-X ,-T ] ;                  \ Compile body address

ASSEMBLER CLEAR_LABELS META

CODE DOBEGIN    ( -- )  \ REALLY A NOOP
                NEXT    END-CODE

CODE DOTHEN     ( -- )  \ REALLY A NOOP
                NEXT    END-CODE

CODE DOAGAIN    ( -- )
                MOV ES: IP, 0 [IP]
                NEXT           END-CODE

CODE DOREPEAT   ( -- )
LABEL DOREP1    MOV ES: IP, 0 [IP]
                NEXT           END-CODE

CODE ?WHILE     ( f -- )
                POP AX          OR AX, AX
                JE DOREP1
                INC IP          INC IP
                NEXT            END-CODE

CODE ?UNTIL     ( f -- )
                POP AX          OR AX, AX
                JE DOREP1
                INC IP          INC IP
                NEXT            END-CODE

CODE BRANCH     ( -- )
LABEL BRAN1     MOV ES: IP, 0 [IP]
                NEXT            END-CODE

CODE ?BRANCH    ( f -- )
                POP AX          OR AX, AX
                JE BRAN1
                INC IP          INC IP
                NEXT            END-CODE

T: BEGIN        [TARGET] DOBEGIN X?<MARK   T;
T: AGAIN        [TARGET] DOAGAIN X?<RESOLVE   T;
T: UNTIL        [TARGET] ?UNTIL  X?<RESOLVE   T;
T: IF           [TARGET] ?BRANCH X?>MARK      T;
T: THEN         [TARGET] DOTHEN  X?>RESOLVE    T;
T: ELSE         [TARGET] BRANCH  X?>MARK   2SWAP X?>RESOLVE   T;
T: WHILE        [TARGET] ?WHILE  X?>MARK   T;
T: REPEAT       2SWAP [TARGET] DOREPEAT X?<RESOLVE X?>RESOLVE T;

LABEL LOOPEXIT  ( --- )
                ADD RP, # 6     INC IP          INC IP
                NEXT            END-CODE

CODE (LOOP)     ( -- )
                INC 0 [RP] WORD
                JO LOOPEXIT
                MOV ES: IP, 0 [IP]
                NEXT            END-CODE

CODE (+LOOP)    ( n -- )
                AX POP          ADD 0 [RP], AX
                JO LOOPEXIT     MOV ES: IP, 0 [IP]
                NEXT            END-CODE

HEX
CODE (DO)       ( l i -- )
                POP AX          POP BX
LABEL PDO1      DEC RP          DEC RP
                MOV ES: DX, 0 [IP]
                MOV 0 [RP], DX
                INC IP          INC IP
                ADD BX, # 8000
                DEC RP          DEC RP
                MOV 0 [RP], BX  SUB AX, BX
                DEC RP          DEC RP
                MOV 0 [RP], AX
                NEXT            END-CODE
DECIMAL

CODE (?DO)      ( l i -- )
                POP AX          POP BX
                CMP BX, AX
                JNE PDO1        MOV ES: IP, 0 [IP]
                NEXT            END-CODE


CODE (OF)       ( n1 n2 -- n1 )  ( or )  ( n1 n1 -- )
                POP AX          XCHG SP, RP     CMP AX, 0 [RP]
        0= IF
                XCHG RP, SP     POP AX
                INC IP          INC IP          NEXT
        ELSE
                XCHG RP, SP     MOV ES: IP, 0 [IP]
                NEXT
        THEN
                END-CODE

CODE BOUNDS     ( n1 n2 --- n3 n4 )
                POP DX          POP AX          ADD DX, AX
                2PUSH           END-CODE

T: ?DO          [TARGET] (?DO)   X?>MARK   T;
T: DO           [TARGET] (DO)    X?>MARK   T;
T: LOOP         [TARGET] (LOOP)    2DUP 2+   X?<RESOLVE   X?>RESOLVE   T;
T: +LOOP        [TARGET] (+LOOP)   2DUP 2+   X?<RESOLVE   X?>RESOLVE   T;

ASSEMBLER >NEXT META CONSTANT >NEXT

CODE EXECUTE    ( cfa -- )
                POP AX          JMP AX          END-CODE

CODE PERFORM    ( addr-of-cfa -- )
LABEL DODEFER   POP BX          MOV AX, 0 [BX]
                JMP AX          END-CODE

CODE XPERFORM   ( Xaddr-of-cfa -- )
                POP BX          MOV ES: AX, 0 [BX]
                JMP AX          END-CODE

LABEL DOUSER-DEFER
                POP BX          MOV BX, 0 [BX]
                ADD BX, UP      MOV AX, 0 [BX]
                JMP AX          END-CODE

CODE GO         RET             END-CODE        ( ADDR --- )
CODE NOOP       NEXT            END-CODE
CODE PAUSE      NEXT            END-CODE

CODE I ( -- n ) MOV AX, 0 [RP]  ADD AX, 2 [RP]
                1PUSH           END-CODE

CODE J ( -- n ) MOV AX, 6 [RP]  ADD AX, 8 [RP]
                1PUSH           END-CODE

DECIMAL

CODE (LEAVE)    ( -- )
LABEL PLEAVE    ADD RP, # 4     MOV IP, 0 [RP]
                INC RP          INC RP
                NEXT            END-CODE

CODE (?LEAVE)   ( f -- )
                POP AX          OR AX, AX       JNE PLEAVE
                NEXT            END-CODE

T: LEAVE        [TARGET] (LEAVE)   T;
T: ?LEAVE       [TARGET] (?LEAVE)  T;

CODE @  ( addr -- n )
                POP BX          PUSH 0 [BX]
                NEXT            END-CODE

CODE !  ( n addr -- )
                POP BX          POP 0 [BX]
                NEXT            END-CODE

CODE C@ ( addr -- char )
                POP BX          SUB AX, AX      MOV AL, 0 [BX]
                1PUSH           END-CODE

CODE C! ( char addr -- )
                POP BX          POP AX          MOV 0 [BX], AL
                NEXT            END-CODE

CODE CMOVE      (  from to count -- )
                CLD             MOV BX, IP      MOV AX, DS
                POP CX          POP DI          POP IP
                PUSH ES         MOV ES, AX
                REPNZ           MOVSB
                MOV IP, BX      POP ES
                NEXT            END-CODE

CODE CMOVE>     ( from to count -- )
                STD             MOV BX, IP      MOV AX, DS
                POP CX          DEC CX
                POP DI          POP IP
                ADD DI, CX      ADD IP, CX      INC CX
                PUSH ES         MOV ES, AX
                REPNZ           MOVSB
                MOV IP, BX      CLD             POP ES
                NEXT            END-CODE

CODE PLACE      ( from cnt to -- )
                POP BX          POP AX          MOV 0 [BX], AL
                INC BX          PUSH BX         PUSH AX
                CLD             MOV BX, IP      MOV AX, DS
                POP CX          POP DI          POP IP
                PUSH ES         MOV ES, AX
                REPNZ           MOVSB
                MOV IP, BX      POP ES
                NEXT            END-CODE

DECIMAL

CODE SP@        ( -- n )
                MOV AX, SP      1PUSH           END-CODE

CODE SP!        ( n -- )
                POP SP          NEXT            END-CODE

CODE RP@        ( -- addr )
                MOV AX, RP      1PUSH           END-CODE

CODE RP!        ( n -- )
                POP RP          NEXT            END-CODE

CODE DROP       ( n1 -- )
                POP AX          NEXT            END-CODE

CODE DUP        ( n1 -- n1 n1 )
                POP AX          PUSH AX
                1PUSH           END-CODE

CODE SWAP       ( n1 n2 -- n2 n1 )
                POP DX          POP AX
                2PUSH           END-CODE

CODE OVER       ( n1 n2 -- n1 n2 n1 )
                POP DX          POP AX
                PUSH AX         2PUSH           END-CODE

CODE TUCK       ( n1 n2 -- n2 n1 n2 )
                POP AX          POP DX
                PUSH AX         2PUSH           END-CODE

CODE NIP        ( n1 n2 -- n2 )
                POP AX          POP DX
                1PUSH           END-CODE

CODE ROT        ( n1 n2 n3 --- n2 n3 n1 )
                POP DX          POP BX          POP AX
                PUSH BX         2PUSH           END-CODE

CODE -ROT       ( n1 n2 n3 --- n3 n1 n2 )
                POP BX          POP AX          POP DX
                PUSH BX         2PUSH           END-CODE

CODE FLIP       ( n1 -- n2 )
                POP AX          XCHG AL, AH
                1PUSH           END-CODE

CODE ?DUP       ( n1 -- [n1] n1 )
                POP AX          CMP AX, # 0
            0<> IF
                PUSH AX
            THEN
                1PUSH           END-CODE

CODE R>         ( -- n )
                MOV AX, 0 [RP]  INC RP          INC RP
                1PUSH           END-CODE

CODE >R         ( n -- )
                POP AX          DEC RP          DEC RP
                MOV 0 [RP], AX  NEXT            END-CODE

CODE R@         ( -- n )
                MOV AX, 0 [RP]  1PUSH           END-CODE

CODE PICK       ( nm ... n2 n1 k -- nm ... n2 n1 nk )
                POP BX          SHL BX, # 1     ADD BX, SP
                MOV AX, 0 [BX]  1PUSH           END-CODE

CODE AND        ( n1 n2 -- n3 )
                POP BX          POP AX          AND AX, BX
                1PUSH           END-CODE

CODE OR         ( n1 n2 -- n3 )
                POP BX          POP AX          OR AX, BX
                1PUSH           END-CODE

CODE XOR        ( n1 n2 -- n3 )
                POP BX          POP AX          XOR AX, BX
                1PUSH           END-CODE

CODE NOT        ( n -- n' )
                POP AX          NOT AX
                1PUSH           END-CODE

-1 CONSTANT TRUE
 0 CONSTANT FALSE

CODE CSET       ( b addr -- )
                POP BX          POP AX          OR 0 [BX], AL
                NEXT            END-CODE

CODE CRESET     ( b addr -- )
                POP BX          POP AX
                NOT AX          AND 0 [BX], AL
                NEXT            END-CODE

CODE CTOGGLE    ( b addr -- )
                POP BX          POP AX          XOR 0 [BX], AL
                NEXT            END-CODE

CODE ON         ( addr -- )
                POP BX          MOV 0 [BX], # TRUE WORD
                NEXT            END-CODE

CODE OFF        ( addr -- )
                POP BX          MOV 0 [BX], # FALSE WORD
                NEXT            END-CODE

CODE -1!        ( addr -- )
                POP BX          MOV 0 [BX], # TRUE WORD
                NEXT            END-CODE

CODE 0!         ( addr -- )
                POP BX          MOV 0 [BX], # FALSE WORD
                NEXT            END-CODE

CODE INCR       ( A1 --- )
                POP BX          INC 0 [BX] WORD
                NEXT            END-CODE

CODE DECR       ( A1 --- )
                POP BX          DEC 0 [BX] WORD
                NEXT            END-CODE

CODE +          ( n1 n2 -- sum )
                POP BX          POP AX          ADD AX, BX
                1PUSH           END-CODE

CODE NEGATE     ( n -- n' )
                POP AX          NEG AX
                1PUSH           END-CODE

CODE -          ( n1 n2 -- n1-n2 )
                POP BX          POP AX          SUB AX, BX
                1PUSH           END-CODE

CODE ABS        ( n -- n )
                POP AX          OR AX, AX
             0< IF
                NEG AX
             THEN
                1PUSH           END-CODE

CODE 2+!        ( d addr -- )
                POP BX          POP AX          POP DX
                ADD 0 [BX], DX  ADC 2 [BX], AX
                NEXT            END-CODE

CODE +!         ( n addr -- )
                POP BX          POP AX          ADD 0 [BX], AX
                NEXT            END-CODE

CODE C+!        ( n addr -- )
                POP BX          POP AX          ADD 0 [BX], AL
                NEXT            END-CODE


\ Since the 8086 has a seperate IO path, we define a Forth
\ interface to it.  Use P@ and P! to read or write directly to
\ the 8086 IO ports.

CODE PC@        ( port# -- n )
                POP DX          IN DX, AL       SUB AH, AH
                PUSH AX         NEXT            END-CODE

CODE P@         ( port# -- n )
                POP DX          IN DX, AX       PUSH AX
                NEXT            END-CODE

CODE PC!        ( n port# -- )
                POP DX          POP AX          OUT AL, DX
                NEXT            END-CODE

CODE P!         ( n port# -- )
                POP DX          POP AX          OUT AX, DX
                NEXT            END-CODE

                \ read drive path into addr, null terminated.
CODE PDOS       ( addr drive --- f1 ) \ RETURN PATH OF DRIVE
                pop dx          pop ax
                push si         mov si, ax
                mov ah, # 71    int 33
             u< if
                mov al, # 1
             else
                mov al, # 0
             then
                sub ah, ah      pop si
                1push           end-code

 0 CONSTANT 0
 1 CONSTANT 1
 2 CONSTANT 2
 3 CONSTANT 3
64 CONSTANT 64

#TTHREADS CONSTANT #THREADS

CODE 2*         ( n -- 2*n )
                POP AX          SHL AX, # 1
                1PUSH           END-CODE

CODE 2/         ( n -- n/2 )
                POP AX          SAR AX, # 1
                1PUSH           END-CODE

CODE U2/        ( u -- u/2 )
                POP AX          SHR AX, # 1
                1PUSH           END-CODE

CODE 8*         ( n -- 8*n )
                POP AX          SHL AX, # 1
                SHL AX, # 1     SHL AX, # 1
                1PUSH           END-CODE

                ( n1 --- n2 )
CODE 1+         POP AX          INC AX
                1PUSH           END-CODE

CODE 2+         POP AX          INC AX
                INC AX          1PUSH           END-CODE

CODE 1-         POP AX          DEC AX
                1PUSH           END-CODE

CODE 2-         POP AX          DEC AX          DEC AX
                1PUSH           END-CODE

CODE UM*        ( n1 n2 -- d )
                POP AX          POP BX          MUL BX
                XCHG DX, AX     2PUSH           END-CODE

CODE *          ( N1 N2 -- N3 )
                POP AX          POP BX          MUL BX
                1PUSH           END-CODE

: U*D           ( n1 n2 -- d )  UM*   ;

CODE UM/MOD     ( d1 n1 -- Remainder Quotient )
                POP BX          POP DX          POP AX
                CMP DX, BX
            U>=  ( divide by zero? )
            IF
                MOV AX, # -1    MOV DX, AX      2PUSH
            THEN
                DIV BX          2PUSH           END-CODE

LABEL YES       MOV AX, # TRUE  1PUSH           END-CODE

CODE 0=         ( n -- f )
                POP AX          OR AX, AX
                JE YES
                SUB AX, AX      1PUSH           END-CODE

CODE 0<         ( n -- f )
                POP AX          OR AX, AX
                JS YES
                SUB AX, AX      1PUSH           END-CODE

CODE 0>         ( n -- f )
                POP AX          OR AX, AX
                JG YES
                SUB AX, AX      1PUSH           END-CODE

CODE 0<>        ( n -- f )
                POP AX          OR AX, AX
                JNE YES
                SUB AX, AX      1PUSH           END-CODE

CODE =          ( n1 n2 -- f )
                POP AX          POP BX          CMP BX, AX
                JE YES
                SUB AX, AX      1PUSH           END-CODE

: <>            ( n1 n2 -- f )  = NOT   ;

: ?NEGATE       ( n1 n2 -- n3 ) 0< IF    NEGATE   THEN   ;

CODE   U<       ( n1 n2 -- f )
                POP AX          POP BX          CMP BX, AX
                JB YES
                SUB AX, AX      1PUSH           END-CODE

CODE   U>       ( n1 n2 -- f )
                POP AX          POP BX          CMP AX, BX
                JB YES
                SUB AX, AX      1PUSH           END-CODE

CODE <          ( n1 n2 -- f )
                POP AX          POP BX          CMP BX, AX
                JL YES
                SUB AX, AX      1PUSH           END-CODE

CODE >          ( n1 n2 -- f )
                POP AX          POP BX          CMP BX, AX
                JG YES
                SUB AX, AX
LABEL PUSH1     1PUSH           END-CODE

CODE MIN        POP AX          POP BX          CMP BX, AX
                JG PUSH1
LABEL MIN1      PUSH BX         NEXT            END-CODE

CODE MAX        POP AX          POP BX          CMP BX, AX
                JG MIN1
                1PUSH           END-CODE

: BETWEEN       ( n1 min max -- f )     >R  OVER > SWAP R> > OR NOT ;
: WITHIN        ( n1 min max -- f )     1- BETWEEN  ;

CODE 2@         ( addr -- d )
                POP BX          MOV AX, 0 [BX]  MOV DX, 2 [BX]
                2PUSH           END-CODE

CODE 2!         ( d addr -- )
                POP BX          POP 0 [BX]      POP 2 [BX]
                NEXT            END-CODE

CODE 2DROP      ( d -- )
                POP AX          POP AX
                NEXT            END-CODE

CODE 3DROP      ( d -- )
                POP AX          POP AX          POP AX
                NEXT            END-CODE

CODE 2DUP       ( d -- d d )
                POP AX          POP DX
                PUSH DX         PUSH AX
                2PUSH           END-CODE

CODE 3DUP       ( d -- d d )
                POP AX          POP DX          POP BX
                PUSH BX         PUSH DX         PUSH AX
                PUSH BX         PUSH DX         PUSH AX
                NEXT            END-CODE

CODE 2SWAP      ( d1 d2 -- d2 d1 )
                POP CX          POP BX
                POP AX          POP DX
                PUSH BX         PUSH CX
                2PUSH           END-CODE

CODE 2OVER      ( d2 d2 -- d1 d2 d1 )
                POP CX          POP BX
                POP AX          POP DX
                PUSH DX         PUSH AX
                PUSH BX         PUSH CX
                2PUSH           END-CODE

CODE D+         ( d1 d2 -- dsum )
                POP AX          POP DX
                POP BX          POP CX
                ADD DX, CX      ADC AX, BX
                2PUSH           END-CODE

CODE DNEGATE    ( d# -- d#' )
LABEL DNEG1     POP BX          POP CX
                SUB AX, AX      MOV DX, AX
                SUB DX, CX      SBB AX, BX
                2PUSH           END-CODE

CODE   S>D      ( n -- d )
                POP AX          CWD             XCHG DX, AX
                2PUSH           END-CODE

CODE DABS       ( d# -- d# )
                POP DX          PUSH DX         OR DX, DX
                JS DNEG1
                NEXT            END-CODE

CODE D2*        ( d -- d*2 )
                POP AX          POP DX
                SHL DX, # 1     RCL AX, # 1
                2PUSH           END-CODE

CODE D2/        ( d -- d/2 )
                POP AX          POP DX
                SAR AX, # 1     RCR DX, # 1
                2PUSH           END-CODE

: D-            ( d1 d2 -- d3 ) DNEGATE D+   ;

: ?DNEGATE      ( d1 n -- d2 )  0< IF   DNEGATE   THEN   ;

: D0=           ( d -- f )      OR 0= ;

: D=            ( d1 d2 -- f )  D-  D0=  ;

: DU<           ( ud1 ud2 -- f )
                ROT SWAP 2DUP U<
                IF      2DROP 2DROP TRUE
                ELSE    <> IF   2DROP FALSE  ELSE  U<  THEN
                THEN  ;

: D<            ( d1 d2 -- f )
                2 PICK OVER =
                IF      DU<
                ELSE  NIP ROT DROP <  THEN  ;

: D>            ( d1 d2 -- f )  2SWAP D<   ;

: 4DUP          ( a b c d -- a b c d a b c d )  2OVER 2OVER   ;

: DMIN          ( d1 d2 -- d3 ) 4DUP D> IF  2SWAP  THEN 2DROP ;

: DMAX          ( d1 d2 -- d3 ) 4DUP D< IF  2SWAP  THEN  2DROP ;

: *D            ( n1 n2 -- d# )
                2DUP  XOR  >R  ABS  SWAP  ABS  UM*  R>  ?DNEGATE  ;

: M/MOD         ( d# n1 -- rem quot )
                ?DUP
                IF  DUP >R  2DUP XOR >R  >R DABS R@ ABS  UM/MOD
                        SWAP R> ?NEGATE
                        SWAP R> 0<
                        IF  NEGATE OVER
                                IF  1- R@ ROT - SWAP  THEN
                        THEN    R> DROP
                THEN  ;

: MU/MOD        ( d# n1 -- rem d#quot )
                >R  0  R@  UM/MOD  R>  SWAP  >R  UM/MOD  R>   ;

CODE /          ( NUM DEN --- QUOT )
                POP BX          POP AX          CWD
                MOV CX, BX      XOR CX, DX
            0>= IF                              \ POSITIVE QUOTIENT CASE
                IDIV BX         1PUSH
            THEN
                IDIV BX         OR DX, DX
            0<> IF
                DEC AX
            THEN
                1PUSH           END-CODE

CODE /MOD       ( NUM DEN --- REM QUOT )
                POP BX          POP AX          CWD
                MOV CX, BX      XOR CX, DX
            0>= IF
                IDIV BX         2PUSH
            THEN
                IDIV BX         OR DX, DX
            0<> IF
                ADD DX, BX      DEC AX
           THEN
                2PUSH           END-CODE

: MOD           ( n1 n2 -- rem ) /MOD  DROP  ;

CODE */MOD      ( N1 N2 N3 --- REM QUOT )
                POP BX          POP AX          POP CX
                IMUL CX         MOV CX, BX      XOR CX, DX
            0>= IF
                IDIV BX         2PUSH
            THEN
                IDIV BX         OR DX, DX
            0<> IF
                ADD DX, BX      DEC AX
            THEN
                2PUSH           END-CODE

: */            ( n1 n2 n3 -- n1*n2/n3 ) */MOD  NIP  ;

: ROLL          ( n1 n2 .. nk n -- wierd )
                >R R@ PICK   SP@ DUP 2+   R> 1+ 2* CMOVE>  DROP  ;

: 2ROT          ( a b c d e f - c d e f a b )   5 ROLL  5 ROLL  ;