From: Tim Vaughan Date: Tue, 26 Apr 2016 19:25:41 +0000 (+1200) Subject: Fixed ROT/-ROT, added LEAVE? and LOOP+ X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=eaec011bac29e0101b20a9e87593d0bc621d9bf7;p=forth.jl.git Fixed ROT/-ROT, added LEAVE? and LOOP+ --- diff --git a/src/forth.jl b/src/forth.jl index 0b4871f..bba6a98 100644 --- a/src/forth.jl +++ b/src/forth.jl @@ -241,7 +241,7 @@ OVER = defPrimWord("OVER", () -> begin return NEXT end) -NROT = defPrimWord("-ROT", () -> begin +ROT = defPrimWord("ROT", () -> begin a = popPS() b = popPS() c = popPS() @@ -251,7 +251,7 @@ NROT = defPrimWord("-ROT", () -> begin return NEXT end) -ROT = defPrimWord("ROT", () -> begin +NROT = defPrimWord("-ROT", () -> begin a = popPS() b = popPS() c = popPS() @@ -872,7 +872,7 @@ INTERPRET = defPrimWord("INTERPRET", () -> begin isImmediate = (mem[wordAddr+1] & F_IMMED) != 0 callPrim(mem[TOCFA]) - callPrim(mem[ROT]) # get rid of extra copy of word string details + callPrim(mem[NROT]) # get rid of extra copy of word string details popPS() popPS() diff --git a/src/lib.4th b/src/lib.4th index ff46f5f..51f0b97 100644 --- a/src/lib.4th +++ b/src/lib.4th @@ -116,15 +116,21 @@ : I RSP@ 3 - @ ; -: LEAVE IMMEDIATE +: LEAVE? IMMEDIATE + ' 0BRANCH , 13 , ' R> , ' RDROP , ' RDROP , - ' LIT , HERE @ 7 + , ' DUP , ' ROT , ' - , ' SWAP , ' ! , + ' LIT , HERE @ 7 + , ' DUP , ' -ROT , ' - , ' SWAP , ' ! , ' BRANCH , 0 , ; -: LOOP IMMEDIATE - ' R> , ' R> , ' R> , ' 1+ , ' 2DUP , ' - , +: LEAVE IMMEDIATE + ' LIT , -1 , + [COMPILE] LEAVE? +; + +: LOOP+ IMMEDIATE + ' R> , ' SWAP , ' R> , ' SWAP , ' R> , ' SWAP , ' + , ' 2DUP , ' - , ' SWAP , ' >R , ' SWAP , ' >R , ' SWAP , ' >R , ' 0<= , ' 0BRANCH , HERE @ - , @@ -132,8 +138,10 @@ HERE @ SWAP ! ; -: lt 10 0 do leave loop ; - +: LOOP IMMEDIATE + ' LIT , 1 , + [COMPILE] LOOP+ +; \ COMMENTS ---------------------------------------------------------------------- @@ -155,7 +163,7 @@ ( Some more complicated stack examples, showing the stack notation. ) : NIP ( x y -- y ) SWAP DROP ; -: TUCK ( x y -- y x y ) DUP ROT ; +: TUCK ( x y -- y x y ) DUP -ROT ; : PICK ( x_u ... x_1 x_0 u -- x_u ... x_1 x_0 x_u ) 1+ ( add one because of 'u' on the stack ) PSP@ SWAP - ( add to the stack pointer ) @@ -235,7 +243,7 @@ SWAP ( width u ) DUP ( width u u ) UWIDTH ( width u uwidth ) - -ROT ( u uwidth width ) + ROT ( u uwidth width ) SWAP - ( u width-uwidth ) ( At this point if the requested width is narrower, we'll have a negative number on the stack. Otherwise the number on the stack is the number of spaces to print. But SPACES won't print @@ -250,18 +258,18 @@ DUP 0< IF NEGATE ( width u ) 1 ( save a flag to remember that it was negative | width n 1 ) - ROT ( 1 width u ) + -ROT ( 1 width u ) SWAP ( 1 u width ) 1- ( 1 u width-1 ) ELSE 0 ( width u 0 ) - ROT ( 0 width u ) + -ROT ( 0 width u ) SWAP ( 0 u width ) THEN SWAP ( flag width u ) DUP ( flag width u u ) UWIDTH ( flag width u uwidth ) - -ROT ( flag u uwidth width ) + ROT ( flag u uwidth width ) SWAP - ( flag u width-uwidth ) SPACES ( flag u ) @@ -295,7 +303,7 @@ ( c a b WITHIN returns true if a <= c and c < b ) : WITHIN - ROT ( b c a ) + -ROT ( b c a ) OVER ( b c a c ) <= IF > IF ( b c -- )