Ekdohibs
/
pforth
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Fix 2OVER, M*, UM*, < and >, FILL, FIND, ELSE, ACCEPT, add SM/REM. Fix shifts.

master
Novatux 2013-07-02 17:31:45 +02:00
parent fc60e7e518
commit f4f6589050
2 changed files with 22 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
forth2.f
View File

@ -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 ;

9
forth3.py
View File

@ -24,6 +24,11 @@ def s32(x):
def u32(x):
return x&0xffffffff
def shift(n, dep):
if dep>=0:
return n<<min(16, dep)
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<<min(16,self.Y))\nself.Y=u16(self.X<<min(16, max(0, self.Y-16)))",
0x3e:"n=self.X\nself.X=u16(n<<min(16,self.Y))\nself.Y=u16(shift(n, self.Y-16))",
0x3f:"if s16(self.Y)<0: self.X=u16(-1)\nelse:\n self.X=0",
0x38:"self.PC=u16(self.PC+self.read(self.PC))\nself.PC=u16(self.PC+2)",