pcat: add PICK and (roll)

This port is taking shape!

blk/750

@@ -1 +1 @@
-1 9 LOADR+
+1 11 LOADR+

blk/751

@@ -8,3 +8,4 @@ VARIABLE L1 VARIABLE L2 VARIABLE L3 VARIABLE L4
 : ES 0 ; : CS 1 ; : SS 2 ; : DS 3 ;
 : [BX+SI] 0 ; : [BX+DI] 1 ; : [BP+SI] 2 ; : [BP+DI] 3 ;
 : [SI] 4 ; : [DI] 5 ; : [BP] 6 ; : [BX] 7 ;
+: <<3 3 LSHIFT ;

blk/753

@@ -2,12 +2,13 @@
 0xc3 OP1 RETn,       0xfa OP1 CLI,       0xfb OP1 STI,
 0xf4 OP1 HLT,        0xfc OP1 CLD,       0xfd OP1 STD,
 0x90 OP1 NOP,
+0xf3 OP1 REPZ,       0xf2 OP1 REPNZ,     0xac OP1 LODSB,
+0xad OP1 LODSW,      0xa6 OP1 CMPSB,     0xa7 OP1 CMPSW,
+0xa4 OP1 MOVSB,      0xa5 OP1 MOVSW,     0xae OP1 SCASB,
+0xaf OP1 SCASW,      0xaa OP1 STOSB,     0xab OP1 STOSW,
 ( no argument, jumps with relative addrs are special )
 0xeb OP1 JMPs,       0xe9 OP1 JMPn,      0x74 OP1 JZ,
 0x75 OP1 JNZ,        0xe8 OP1 CALLn,
-0xf3 OP1 REPZ,       0xf2 OP1 REPNZ,     0xac OP1 LODSB,
-0xa6 OP1 CMPSB,      0xa4 OP1 MOVSB,     0xae OP1 SCASB,
-0xaa OP1 STOSB,
 
 : OP1r CREATE C, DOES> C@ + A, ;
 0x40 OP1r INCx,      0x48 OP1r DECx,

blk/754

@@ -1,6 +1,14 @@
-: OPrr CREATE C, DOES> C@ A, 3 LSHIFT OR 0xc0 OR A, ;
+: OPr0 ( reg op ) CREATE C, C, DOES>
+    C@+ A, C@ <<3 OR 0xc0 OR A, ;
+0 0xd0 OPr0 ROLr1,   0 0xd1 OPr0 ROLx1,
+1 0xd0 OPr0 RORr1,   1 0xd1 OPr0 RORx1,
+4 0xd0 OPr0 SHLr1,   4 0xd1 OPr0 SHLx1,
+5 0xd0 OPr0 SHRr1,   5 0xd1 OPr0 SHRx1,
+
+: OPrr CREATE C, DOES> C@ A, <<3 OR 0xc0 OR A, ;
 0x31 OPrr XORxx,     0x30 OPrr XORrr,
 0x88 OPrr MOVrr,     0x89 OPrr MOVxx,    0x28 OPrr SUBrr,
 0x29 OPrr SUBxx,     0x08 OPrr ORrr,     0x09 OPrr ORxx,
 0x3a OPrr CMPrr,     0x3b OPrr CMPxx,    0x00 OPrr ADDrr,
 0x01 OPrr ADDxx,
+

blk/755

@@ -1,13 +1,10 @@
-: OPrm CREATE C, DOES> C@ A, SWAP 3 LSHIFT OR A, ;
+: OPm ( modrm op ) CREATE C, C, DOES> C@+ A, C@ OR A, ;
-0x8a OPrm MOVr[],    0x8b OPrm MOVx[],
+0 0xff OPm INC[w], 0 0xfe OPm INC[b],
+0x8 0xff OPm DEC[w], 0x8 0xfe OPm DEC[b],
+0x30 0xff OPm PUSH[w], 0 0x8f OPm POP[w],
 
-: OPmr CREATE C, DOES> C@ A, 3 LSHIFT OR A, ;
+: OPm+ ( modrm op ) CREATE C, C, DOES>
-0x88 OPmr MOV[]r,    0x89 OPmr MOV[]x,
+    ( m off ) C@+ A, C@ ROT OR A, A, ;
-
+0x40 0xff OPm+ INC[w]+, 0x40 0xfe OPm+ INC[b]+,
-: OPrm+ ( r m off ) CREATE C, DOES>
+0x48 0xff OPm+ DEC[w]+, 0x48 0xfe OPm+ DEC[b]+,
-    C@ A, ROT 3 LSHIFT ROT OR 0x40 OR A, A, ;
+0x70 0xff OPm+ PUSH[w]+, 0x40 0x8f OPm+ POP[w]+,
-0x8a OPrm+ MOVr[]+,    0x8b OPrm+ MOVx[]+,
-
-: OPm+r ( m off r ) CREATE C, DOES>
-    C@ A, 3 LSHIFT ROT OR 0x40 OR A, A, ;
-0x88 OPm+r MOV[]+r,    0x89 OPm+r MOV[]+x,

blk/756

@@ -1,9 +0,0 @@
-: MOVri, SWAP 0xb0 OR A, A, ;
-: MOVxI, SWAP 0xb8 OR A, A,, ;
-: MOVsx, 0x8e A, SWAP 3 LSHIFT OR 0xc0 OR A, ;
-: MOVxm, 0x8b A, SWAP 3 LSHIFT 0x6 OR A, A,, ;
-: INT, 0xcd A, A, ;
-: ADDAXI, 0x05 A, A,, ; : ADDALi, 0x04 A, A, ;
-: SUBxi, 0x83 A, SWAP 0xe8 OR A, A, ;
-: JMPr, 0xff A, 7 AND 0xe0 OR A, ;
-: JMPf, ( seg off ) 0xea A, SPLITB A, A, A,, ;

blk/757

@@ -1,16 +1,14 @@
-( Place BEGIN, where you want to jump back and AGAIN after
+: OPrm CREATE C, DOES> C@ A, SWAP 3 LSHIFT OR A, ;
-  a relative jump operator. Just like BSET and BWR. )
+0x8a OPrm MOVr[],    0x8b OPrm MOVx[],
-: BEGIN, PC ;
+
-: BSET PC SWAP ! ;
+: OPmr CREATE C, DOES> C@ A, 3 LSHIFT OR A, ;
-( same as BSET, but we need to write a placeholder )
+0x88 OPmr MOV[]r,    0x89 OPmr MOV[]x,
-: FJR, PC 0 A, ;
+
-: IFZ, JNZ, FJR, ;
+: OPrm+ ( r m off ) CREATE C, DOES>
-: IFNZ, JZ, FJR, ;
+    C@ A, ROT 3 LSHIFT ROT OR 0x40 OR A, A, ;
-( : IFC, JRNC, FJR, ;
+0x8a OPrm+ MOVr[]+,    0x8b OPrm+ MOVx[]+,
-: IFNC, JRC, FJR, ; )
+0x3a OPrm+ CMPr[]+,    0x3b OPrm+ CMPx[]+,
-: THEN,
+
-    DUP PC          ( l l pc )
+: OPm+r ( m off r ) CREATE C, DOES>
-    -^ 1-           ( l off )
+    C@ A, 3 LSHIFT ROT OR 0x40 OR A, A, ;
-    ( warning: l is a PC offset, not a mem addr! )
+0x88 OPm+r MOV[]+r,    0x89 OPm+r MOV[]+x,
-    SWAP ORG @ + BIN( @ - ( off addr )
-    C! ;

blk/758

@@ -1,10 +1,10 @@
-: FWRs BSET 0 A, ;
+: MOVri, SWAP 0xb0 OR A, A, ;
-: FSET @ THEN, ;
+: MOVxI, SWAP 0xb8 OR A, A,, ;
-( : BREAK, FJR, 0x8000 OR ;
+: MOVsx, 0x8e A, SWAP 3 LSHIFT OR 0xc0 OR A, ;
-: BREAK?, DUP 0x8000 AND IF
+: MOVxm, 0x8b A, SWAP 3 LSHIFT 0x6 OR A, A,, ;
-        0x7fff AND 1 ALLOT THEN, -1 ALLOT
+: INT, 0xcd A, A, ;
-    THEN ; )
+: ADDAXI, 0x05 A, A,, ; : ADDALi, 0x04 A, A, ;
-: RPCs, PC - 1- A, ; : RPCn, PC - 2- A,, ;
+: SUBxi, 0x83 A, SWAP 0xe8 OR A, A, ;
-: AGAIN, ( BREAK?, ) RPCs, ;
+: ADDxi, 0x83 A, SWAP 0xc0 OR A, A, ;
-( Use RPCx with appropriate JMP/CALL op. Example:
+: JMPr, 0xff A, 7 AND 0xe0 OR A, ;
-  JMPs, 0x42 RPCs, or CALLn, 0x1234 RPCn, )
+: JMPf, ( seg off ) 0xea A, SPLITB A, A, A,, ;

blk/759

@@ -1,3 +1,16 @@
-: CODE ( same as CREATE, but with native word )
+( Place BEGIN, where you want to jump back and AGAIN after
-    (entry) 0 ( native ) C, ;
+  a relative jump operator. Just like BSET and BWR. )
-: ;CODE JMPn, 0x1a ( next ) RPCn, ;
+: BEGIN, PC ;
+: BSET PC SWAP ! ;
+( same as BSET, but we need to write a placeholder )
+: FJR, PC 0 A, ;
+: IFZ, JNZ, FJR, ;
+: IFNZ, JZ, FJR, ;
+( : IFC, JRNC, FJR, ;
+: IFNC, JRC, FJR, ; )
+: THEN,
+    DUP PC          ( l l pc )
+    -^ 1-           ( l off )
+    ( warning: l is a PC offset, not a mem addr! )
+    SWAP ORG @ + BIN( @ - ( off addr )
+    C! ;

blk/760

@@ -0,0 +1,10 @@
+: FWRs BSET 0 A, ;
+: FSET @ THEN, ;
+( : BREAK, FJR, 0x8000 OR ;
+: BREAK?, DUP 0x8000 AND IF
+        0x7fff AND 1 ALLOT THEN, -1 ALLOT
+    THEN ; )
+: RPCs, PC - 1- A, ; : RPCn, PC - 2- A,, ;
+: AGAIN, ( BREAK?, ) RPCs, ;
+( Use RPCx with appropriate JMP/CALL op. Example:
+  JMPs, 0x42 RPCs, or CALLn, 0x1234 RPCn, )

blk/761

@@ -0,0 +1,3 @@
+: CODE ( same as CREATE, but with native word )
+    (entry) 0 ( native ) C, ;
+: ;CODE JMPn, 0x1a ( next ) RPCn, ;

blk/811

@@ -4,7 +4,7 @@ ORG @ 0x25 + HERE ! ( bypass BPB )
 L1 FSET ( start )
 CLI, CLD, AX 0x800 MOVxI, DS AX MOVsx, ES AX MOVsx,
 SS AX MOVsx, STI,
-AH 2 MOVri, DX 0 MOVxI, CH 0 MOVri, CL 2 MOVri, AL 1 MOVri,
+AH 2 MOVri, DX 0 MOVxI, CH 0 MOVri, CL 2 MOVri, AL 2 MOVri,
-BX 0 MOVxI, 0x13 INT, ( read 2nd sector of boot floppy )
+BX 0 MOVxI, 0x13 INT, ( read sectors 2-3 of boot floppy )
 0x800 0 JMPf,
 ORG @ 0x1fe + HERE ! 0x55 A, 0xaa A,

blk/812

@@ -1,15 +1,15 @@
+VARIABLE lblexec VARIABLE lblfind
 H@ ORG !
-JMPn, 0 A,,   ( 00, main )     JMPn, 0 A,,   ( 03, find )
+JMPn, 0 A,,   ( 00, main )     0 A, 0 A,, ( unused )
-0 A,,         ( 06, unused )   0 A,,         ( 08, LATEST )
+0 A,, ( unused ) 0 A,, ( 08, LATEST )
-0 A,          ( 0a, unused )   0 A, 0 A,,    ( 0b, unused )
+0 A, 0 A, 0 A,,    ( unused )
-0 A, 0 A,,    ( 0e, unused )   JMPn, 0 A,,  ( 11, pushRS )
+0 A, 0 A,, ( unused ) JMPn, 0 A,,  ( 11, pushRS )
 JMPn, 0 A,,   ( 14, popRS )
-0 A, 0 A,,    ( 17, unused )
+0 A, 0 A,, ( unused )
-JMPn, 0 A,,   ( 1a, next )     0 A, 0 A,,    ( 1d, unused )
+JMPn, 0 A,,   ( 1a, next )     0 A, 0 A,,    ( unused )
-0 A, 0 A,     ( 20, unused )   0 A, 0 A,     ( 22, unused )
+0 A, 0 A, 0 A, 0 A,     ( unused )
-0 A, 0 A,     ( 24, unused )   0 A, 0 A,     ( 26, unused )
+0 A, 0 A, 0 A, 0 A,     ( unused )
-0 A, 0 A,,    ( unused )
+0 A, 0 A,, ( unused )
-0 A, 0 A,,    ( 2b, unused )   0 A, 0 A,     ( 2e, unused )
+0 A, 0 A,, 0 A, 0 A, ( unused )
-0 A, 0 A,,    ( unused )
-JMPn, 0 A,,   ( 33, execute )  0 A, 0 A,     ( unused )
 0 A, 0 A,,    ( unused )
+JMPn, 0 A,, ( 33, execute ) 0 A, 0 A, 0 A, 0 A,, ( unused )

blk/813

@@ -12,5 +12,5 @@ CODE (br) ( 0x53 ) L2 BSET ( used in br? )
 CODE (br?) ( 0x67 )
     AX POPx, AX AX ORxx, JZ, L2 @ RPCs, ( False, branch )
     ( True, skip next 2 bytes and don't branch )
-    DX INCx, DX INCx,
+    L1 BSET ( loop will jump here ) DX INCx, DX INCx,
-;CODE
+;CODE NOP, NOP, NOP, NOP, NOP,

blk/814

@@ -1,5 +1,15 @@
-ORG @ 0xb9 + HERE !
+CODE (loop) ( 0x80 )
+    [BP] 0 INC[w]+, ( I++ )
+    ( Jump if I <> I' )
+    AX [BP] 0 MOVx[]+, AX [BP] -2 CMPx[]+,
+    JNZ, L2 @ RPCs, ( branch )
+    ( don't branch )
+    BP 4 SUBxi, JMPs, L1 @ RPCs,
+ORG @ 0xa3 + HERE !
+CODE 2>R ( 0xa9 )
+    [BP] 4 POP[w]+, [BP] 2 POP[w]+, BP 4 ADDxi,
+;CODE NOP, NOP, NOP, NOP, NOP,
 CODE (n) ( 0xbf, number literal )
     DI DX MOVxx, DI [DI] MOVx[], DI PUSHx,
     DX INCx, DX INCx,
-;CODE
+;CODE ( END OF STABLE ABI )

blk/815

@@ -1,14 +0,0 @@
-PC 0x1d - ORG @ 0x1b + ! ( next )
-    DI DX MOVxx, ( <-- IP ) DX INCx, DX INCx,
-    DI [DI] MOVx[], ( wordref )
-    ( continue to execute )
-L1 BSET PC 0x36 - ORG @ 0x34 + ! ( execute -- DI -> wordref )
-    AL [DI] MOVr[], DI INCx, ( PFA )
-    AL AL ORrr, IFZ, DI JMPr, THEN, ( native )
-    ( continue to compiled )
-
-PC 0x11 - ORG @ 0x0f + ! ( compiled -- DI -> PFA )
-    BP INCx, BP INCx, [BP] 0 DX MOV[]+x, ( pushRS )
-    DX DI MOVxx, DX INCx, DX INCx, ( --> IP )
-    DI [DI] MOVx[],
-    JMPs, L1 @ RPCs,

blk/816

@@ -1,16 +1,14 @@
-L4 BSET PC 3 - ORG @ 4 + ! ( find )
+PC 0x1d - ORG @ 0x1b + ! ( next )
-( find word the same name as str in SI starting from tip in
+    DI DX MOVxx, ( <-- IP ) DX INCx, DX INCx,
-  DI. Returns wordref in DI. Z if found, NZ if not. )
+    DI [DI] MOVx[], ( wordref )
-    CH CH XORrr, CL [SI] MOVr[], ( CX -> strlen )
+    ( continue to execute )
-    SI INCx, ( first char ) AX AX XORxx, ( initial prev )
+lblexec BSET PC 0x36 - ORG @ 0x34 + ! ( DI -> wordref )
-    BEGIN, ( loop )
+    AL [DI] MOVr[], DI INCx, ( PFA )
-        DI AX SUBxx, ( jump to prev wordref )
+    AL AL ORrr, IFZ, DI JMPr, THEN, ( native )
-        AL [DI] -1 MOVr[]+, ( strlen )
+    ( continue to compiled )
-        CL AL CMPrr, IFZ, ( same len )
+
-            SI PUSHx, DI PUSHx, CX PUSHx, ( --> lvl 3 )
+PC 0x11 - ORG @ 0x0f + ! ( compiled -- DI -> PFA )
-            3 ADDALi, ( header ) AH AH XORrr, DI AX SUBxx,
+    BP INCx, BP INCx, [BP] 0 DX MOV[]+x, ( pushRS )
-            REPZ, CMPSB,
+    DX DI MOVxx, DX INCx, DX INCx, ( --> IP )
-            CX POPx, DI POPx, SI POPx, ( <-- lvl 3 )
+    DI [DI] MOVx[],
-            IFZ, AL AL XORrr, ( Z ) RETn, THEN,
+    JMPs, lblexec @ RPCs,
-        THEN,
-                                                      ( cont. )

blk/817

@@ -1,6 +1,16 @@
-( find cont. )
+lblfind BSET
-        DI 3 SUBxi, AX [DI] MOVx[], ( prev )
+( find word the same name as str in SI starting from tip in
-        AX AX ORxx,
+  DI. Returns wordref in DI. Z if found, NZ if not. )
-    JNZ, AGAIN, ( loop )
+    CH CH XORrr, CL [SI] MOVr[], ( CX -> strlen )
-    AX INCx, ( NZ ) RETn,
+    SI INCx, ( first char ) AX AX XORxx, ( initial prev )
-
+    BEGIN, ( loop )
+        DI AX SUBxx, ( jump to prev wordref )
+        AL [DI] -1 MOVr[]+, ( strlen )
+        CL AL CMPrr, IFZ, ( same len )
+            SI PUSHx, DI PUSHx, CX PUSHx, ( --> lvl 3 )
+            3 ADDALi, ( header ) AH AH XORrr, DI AX SUBxx,
+            REPZ, CMPSB,
+            CX POPx, DI POPx, SI POPx, ( <-- lvl 3 )
+            IFZ, AL AL XORrr, ( Z ) RETn, THEN,
+        THEN,
+                                                      ( cont. )

blk/818

@@ -1,15 +1,5 @@
-CODE BYE BEGIN, JMPs, AGAIN, ;CODE
+( find cont. )
-CODE EMIT
+        DI 3 SUBxi, AX [DI] MOVx[], ( prev )
-    AX POPx, AH 0x0e MOVri, ( print char ) 0x10 INT,
+        AX AX ORxx,
-;CODE CODE 0 AX AX XORxx, AX PUSHx, ;CODE
+    JNZ, AGAIN, ( loop )
-: FOO 'F' EMIT ; : BAR 0 IF FOO THEN FOO BYE ;
+    AX INCx, ( NZ ) RETn,
-L3 BSET 3 A, 'B' A, 'A' A, 'R' A,
-PC 3 - ORG @ 1+ ! ( main )
-    SP PS_ADDR MOVxI,
-    BP RS_ADDR MOVxI,
-    DI 0x08 MOVxm, ( LATEST )
-    SI L3 @ MOVxI,
-    CALLn, L4 @ RPCn, ( find )
-    IFZ, JMPn, L1 @ RPCn, ( execute ) THEN,
-    AH 0x0e MOVri, ( print char ) AL '!' MOVri, 0x10 INT,
-    BEGIN, JMPs, AGAIN,

blk/819

@@ -0,0 +1,10 @@
+L3 BSET 4 A, 'B' A, 'O' A, 'O' A, 'T' A,
+PC 3 - ORG @ 1+ ! ( main )
+    SP PS_ADDR MOVxI,
+    BP RS_ADDR MOVxI,
+    DI 0x08 MOVxm, ( LATEST )
+    SI L3 @ MOVxI,
+    CALLn, lblfind @ RPCn, ( find )
+    IFZ, JMPn, lblexec @ RPCn, ( execute ) THEN,
+    AH 0x0e MOVri, ( print char ) AL '!' MOVri, 0x10 INT,
+    BEGIN, JMPs, AGAIN,

blk/820

@@ -0,0 +1,16 @@
+( native words )
+CODE EXECUTE
+    DI POPx, JMPs, lblexec @ RPCs,
+CODE >R
+    BP INCx, BP INCx, [BP] 0 POP[w]+,
+;CODE NOP, NOP, NOP,
+CODE R>
+    [BP] 0 PUSH[w]+, BP DECx, BP DECx,
+;CODE
+CODE 2R>
+    [BP] -2 PUSH[w]+, [BP] 0 PUSH[w]+, BP 4 SUBxi,
+;CODE
+CODE ROT ( a b c -- b c a )
+    CX POPx, BX POPx, AX POPx,
+    BX PUSHx, CX PUSHx, AX PUSHx,
+;CODE

blk/821

@@ -0,0 +1,16 @@
+CODE DUP AX POPx, AX PUSHx, AX PUSHx, ;CODE
+CODE ?DUP AX POPx, AX AX ORxx, IFNZ, AX PUSHx, THEN, ;CODE
+CODE DROP AX POPx, ;CODE
+CODE SWAP AX POPx, BX POPx, AX PUSHx, BX PUSHx, ;CODE
+CODE OVER ( a b -- a b a )
+    DI SP MOVxx, AX [DI] 2 MOVx[]+, AX PUSHx,
+;CODE
+CODE PICK
+    DI POPx, DI SHLx1, ( x2 )
+    DI SP ADDxx, DI [DI] MOVx[], DI PUSHx,
+;CODE
+CODE (roll) ( "2 3 4 5 4 --> 2 4 5 5". See B311 )
+    CX POPx, SI SP MOVxx, SI CX ADDxx,
+    DI SI MOVxx, SI DECx, SI DECx,
+    STD, REPZ, MOVSB,
+;CODE

blk/822

@@ -0,0 +1,5 @@
+CODE 0 AX AX XORxx, AX PUSHx, ;CODE
+CODE 1 AX 1 MOVxI, AX PUSHx, ;CODE
+CODE I [BP] 0 PUSH[w]+, ;CODE
+CODE 1+ DI SP MOVxx, [DI] INC[w], ;CODE
+CODE 1- DI SP MOVxx, [DI] DEC[w], ;CODE

blk/824

@@ -0,0 +1,6 @@
+CODE BYE BEGIN, JMPs, AGAIN, ;CODE
+CODE EMIT
+    AX POPx, AH 0x0e MOVri, ( print char ) 0x10 INT,
+;CODE
+: FOO 'A' 'B' 'C' 2 PICK 4 (roll) EMIT EMIT EMIT EMIT ;
+: BOOT ['] FOO EXECUTE BYE ;

recipes/pcat/xcomp.fs

@@ -3,7 +3,7 @@
 750 LOAD  ( 8086 asm )
 262 LOAD  ( xcomp )
 270 LOAD  ( xcomp overrides )
-812 818 LOADR
+812 824 LOADR
 (entry) _
 ( Update LATEST )
 PC ORG @ 8 + !