From f4f6589050fa2731c345724889de10d6b06d12ed Mon Sep 17 00:00:00 2001 From: Novatux Date: Tue, 2 Jul 2013 17:31:45 +0200 Subject: [PATCH] Fix 2OVER, M*, UM*, < and >, FILL, FIND, ELSE, ACCEPT, add SM/REM. Fix shifts. --- forth2.f | 26 +++++++++++++++----------- forth3.py | 9 +++++++-- 2 files changed, 22 insertions(+), 13 deletions(-) diff --git a/forth2.f b/forth2.f index 3642fe6..597836c 100644 --- a/forth2.f +++ b/forth2.f @@ -11,7 +11,7 @@ ASSEMBLER : 2DROP 0x31 0x31 0x29 ; : 2DUP 0x32 0x30 0x22 0x21 0x22 0x29 ; : 2SWAP 0x31 0x32 0x33 0x03 0x33 0x22 0x21 0x23 0x13 0x23 0x29 ; -: 2OVER 0x33 0x03 0x33 0x32 0x30 0x22 0x23 0x03 0x23 0x21 0x22 0x29 ; +: 2OVER 0x33 0x03 0x33 0x32 0x30 0x22 0x23 0x13 0x23 0x21 0x22 0x29 ; : NIP 0x31 0x20 0x29 ; : TUCK 0x31 0x32 0x21 0x22 0x21 0x29 ; : ?DUP 0x30 0x39 0x01 0x00 0x29 0x21 0x29 ; @@ -35,8 +35,8 @@ ASSEMBLER : * 0x32 0x31 0x0e 0x22 0x29 ; : U< 0x32 0x30 0x0d 0x20 0x29 ; : U> 0x31 0x32 0x0d 0x21 0x29 ; -: M* 0x32 0x31 0x0e 0x22 0x21 0x29 ; -: UM* 0x32 0x31 0x0f 0x22 0x21 0x29 ; +: M* 0x32 0x31 0x0f 0x22 0x21 0x29 ; +: UM* 0x32 0x31 0x0e 0x22 0x21 0x29 ; : 0= 0x30 0x39 0x03 0x00 0x2f 0x20 0x29 0x4d 0x00 0x00 0x20 0x29 ; : 0<> 0x30 0x39 0x01 0x00 0x29 0x4d 0xff 0xff 0x20 0x29 ; : 0< 0x32 0x3f 0x21 0x29 ; @@ -67,10 +67,12 @@ ASSEMBLER : UDM/MOD 0x33 0x31 0x32 0x1e 0x23 0x22 0x21 0x29 ; : RAWKEY 0x50 0x21 0x29 ; : EMIT 0x31 0x51 0x29 ; -\ : < 0x32 0x31 0x0d 0x40 0x3f 0x43 0x2e 0x21 0x29 ; -: < 0x32 0x31 0x0d 0x40 0x3f 0x43 0x21 0x29 ; -\ : > 0x31 0x32 0x0d 0x40 0x3f 0x43 0x2e 0x21 0x29 ; -: > 0x31 0x32 0x0d 0x40 0x3f 0x43 0x21 0x29 ; +\ : < 0x32 0x31 0x0d 0x40 0x3f 0x43 0x2e 0x21 0x29 ; +\ : < 0x32 0x31 0x0d 0x40 0x3f 0x43 0x21 0x29 ; +: < 0x32 0x3f 0x41 0x32 0x22 0x2e 0x45 0x3f 0x2f 0x39 0x04 0x00 0x32 0x3f 0x21 0x29 0x31 0x43 0x0d 0x21 0x29 ; +\ : > 0x31 0x32 0x0d 0x40 0x3f 0x43 0x2e 0x21 0x29 ; +\ : > 0x31 0x32 0x0d 0x40 0x3f 0x43 0x21 0x29 ; +: > 0x31 0x32 0x21 0x3f 0x41 0x32 0x22 0x2e 0x45 0x3f 0x2f 0x39 0x04 0x00 0x32 0x3f 0x21 0x29 0x31 0x43 0x0d 0x21 0x29 ; : NEGATE 0x32 0x4d 0x00 0x00 0x0d 0x22 0x29 ; \ : (do) 0x32 0x31 0x01 0x02 0x29 ; : (do) 0x2b 0x01 0x32 0x33 0x03 0x02 0x29 ; @@ -155,7 +157,7 @@ FORTH : RESTORE-INPUT DUP 1 = IF DROP >IN ! FALSE ELSE 0 ?DO DROP LOOP TRUE THEN ; : COUNT DUP 1+ SWAP C@ ; : CHAR PARSE-WORD DROP C@ ; -: FILL -ROT DUP 0> IF OVER + SWAP DO OVER SWAP C! LOOP ELSE 2DROP THEN ; +: FILL -ROT DUP 0> IF OVER + SWAP DO DUP I C! LOOP ELSE 2DROP THEN DROP ; : ERASE 0 FILL ; : ( 41 PARSE 2DROP ; IMMEDIATE : .( 41 PARSE TYPE ; IMMEDIATE @@ -164,7 +166,7 @@ FORTH : BEGIN HERE ; IMMEDIATE : FIND-WORD-DICO SWAP >R BEGIN DUP 4 - RSTR R@ = IF 2 PICK R@ STR= IF NIP R> DROP EXIT THEN ELSE DROP THEN 3 - @ DUP 0= UNTIL NIP R> DROP ; : FIND-WORD LATEST @ FIND-WORD-DICO ; -: FIND DUP FIND-WORD DUP IF NIP DUP 1- C@ 128 AND IF 1 ELSE -1 THEN THEN ; +: FIND COUNT OVER SWAP FIND-WORD DUP IF NIP DUP 1- C@ 128 AND IF 1 ELSE -1 THEN THEN ; : ' PARSE-WORD FIND-WORD ; : POSTPONE ' DUP 1- C@ 128 AND IF , ELSE ['] (lit) , , ['] , , THEN ; IMMEDIATE \ : LITERAL [ ' (lit) , ] , , ; IMMEDIATE @@ -179,7 +181,7 @@ FORTH : CONSTANT HEADER HERE LATEST ! 77 C, , 33 C, 41 C, ; : MARKER HERE HEADER HERE SWAP 42 C, POSTPONE LITERAL LATEST @ POSTPONE LITERAL ['] (marker) , ['] EXIT , LATEST ! ; : IF ['] (0branch) , HERE 0 , ; IMMEDIATE -: ELSE ['] (0branch) , HERE SWAP 0 , HERE SWAP ! ; IMMEDIATE +: ELSE ['] (branch) , HERE SWAP 0 , HERE SWAP ! ; IMMEDIATE : UNTIL ['] (0branch) , , ; IMMEDIATE : REPEAT ['] (branch) , , HERE SWAP ! ; IMMEDIATE : WHILE ['] (0branch) , HERE SWAP 0 , ; IMMEDIATE @@ -222,7 +224,7 @@ FORTH : LOOP ['] (loop) , , HERE SWAP ! ; IMMEDIATE \ : +LOOP ['] (+loop) , BEGIN DUP INVERT IF HERE CELL+ ROT ! THEN 0= WHILE REPEAT , ; IMMEDIATE : +LOOP ['] (+loop) , , HERE SWAP ! ; IMMEDIATE -: ACCEPT OVER SWAP OVER + 1- SWAP BEGIN RAWKEY DUP 9 = IF DROP 32 THEN DUP 31 > IF DUP 0x7f = IF EMIT 1- ELSE DUP EMIT OVER C! 1+ OVER MIN THEN ELSE 10 = IF NIP SWAP - EXIT THEN THEN WAIT AGAIN ; +: ACCEPT OVER SWAP OVER + 1- SWAP BEGIN RAWKEY DUP 9 = IF DROP 32 THEN DUP 31 > IF DUP 0x7f = IF EMIT 1- ELSE DUP EMIT OVER C! 1+ OVER MIN THEN ELSE 10 = IF NIP SWAP - EXIT ELSE WAIT THEN THEN AGAIN ; : EXPECT ACCEPT SPAN ! ; : QUERY 0 >IN ! 0 SOURCE-ID ! TIB DUP 80 ACCEPT SPACE (source) 2! ; : REFILL SOURCE-ID @ IF FALSE ELSE 0 >IN ! TIB DUP 80 ACCEPT SPACE (source) 2! TRUE THEN ; @@ -231,4 +233,6 @@ FORTH : QUIT EMPTYR CR BEGIN REFILL WHILE BEGIN PARSE-WORD ?DUP WHILE STATE @ IF COMPILE-WORD ELSE INTERPRET-WORD THEN REPEAT DROP SPACE 79 EMIT 75 EMIT DEBUG CR REPEAT ; : (abort") ROT IF TYPE ABORT THEN 2DROP ; : ABORT" POSTPONE S" ['] (abort") , ; IMMEDIATE +: DABS DUP 0< IF OVER NEGATE ROT IF SWAP INVERT ELSE SWAP NEGATE THEN THEN ; +: SM/REM OVER >R 2DUP XOR >R ABS >R DABS R> UM/MOD R> 0< IF NEGATE THEN SWAP R> 0< IF NEGATE THEN SWAP ; : COLD 82 EMIT 101 EMIT 97 EMIT 100 EMIT 121 EMIT QUIT ; diff --git a/forth3.py b/forth3.py index 060a9f2..208ac34 100644 --- a/forth3.py +++ b/forth3.py @@ -24,6 +24,11 @@ def s32(x): def u32(x): return x&0xffffffff +def shift(n, dep): + if dep>=0: + return n<>-dep + ITABLE = { 0x28:"self.I=self.rpop()", 0x29:"self.PC=self.read(self.I)\nself.I=u16(self.I+2)", @@ -75,14 +80,14 @@ ITABLE = { 0x0e:"n=self.X*self.Y\nself.Y=u16(n)\nself.X=u16(n>>16)", # UM* 0x0f:"n=s16(self.X)*s16(self.Y)\nself.Y=u16(n)\nself.X=u16(n>>16)", # M* 0x1e:"n=(self.X<<16)+self.Y\nself.Y=u16(n//self.Z)\nself.X=u16((n//self.Z)>>16)\nself.Z=u16(n%self.Z)", - 0x1f:"n=s32((self.X<<16)+self.Y)\nself.Y=u16(n//s16(self.Z))\nself.X=u16((n//s16(self.Z))>>16)\nself.Z=u16(n%(s16(self.Z))", + 0x1f:"n=s32((self.X<<16)+self.Y)\nself.Y=u16(n//s16(self.Z))\nself.X=u16((n//s16(self.Z))>>16)\nself.Z=u16(n%(s16(self.Z)))", 0x2c:"self.X=u16(self.X&self.Y)", 0x2d:"self.X=u16(self.X|self.Y)", 0x2e:"self.X=u16(self.X^self.Y)", 0x2f:"self.X=u16(~self.X)", 0x3c:"self.X>>=self.Y", 0x3d:"self.X=u16(s16(self.X)>>self.Y)", - 0x3e:"self.X=u16(self.X<