IN FORTH the "DO...LOOP" expects two parameters on the stack : lower and upper bounds of looping.
When executing :
: test 10 0 DO I . LOOP ;
"I" gets the value of the index and "." prints it, so the output is :
0 1 2 3 4 5 6 7 8 9 ok
For eight years old children, I wanted a simpler looping construct expecting only one parameter :
: test 10 TIMES( I . ) ;
to get the same output.
With ComputerOne FORTH, it is relatively easy to implement this new control structure, but not so with SupperFORTH !
But with both FORTHs, when trying to execute :
: test 0 0 DO I . LOOP ;
or :
: test 0 TIMES( I . ) ;
instead of getting zero looping, wich seems natural, you get 65535 loops ! But why would you do such a silly thing ? I discovered this "feature" when I tried to code a "Folly" word to plot spirals : with first a word called SIDE to plot a strait line of <n> STEP and a RIGHT 90° turn :
: SIDE TIMES( STEP ) RIGHT ; expecting a number <n> of steps
and then a word using SIDE in another loop together with its index I :
: SPIRAL 30 TIMES( I SIDE ) ; for a fixed number of <30> sides
or :
: SPIRAL TIMES( I SIDE ) ; expecting the number <n> of sides to plot
This of course did not work, because entering the loop of SPIRAL, the first value of I was 0 and thus, the loop of SIDE got to do STEP zero times and did it actually 65535 times !
However, ComputerOne FORTH (and Folly on it) had a way to solve this issue : instead of DO , it has also a word ?DO that checks this "runtime condition" and does nothing when both bounds of a loop are equal.
whereas DO is coded using a looping primitive called (DO), ?DO uses a primitive called (?DO).
Wich I adopted for coding TIMES(
Let's compare :
: DO ?COMP COMPILE (DO) 0 , 3 ; IMMEDIATE
: ?DO ?COMP COMPILE (?DO) 0 , 3 ; IMMEDIATE
: TIMES( ?COMP COMPILE 0 COMPILE (?DO) HERE 0 , 3 ; IMMEDIATE
: LOOP ?COMP 3 ?PAIRS COMPILE (LOOP) 2+ BACK HERE SWAP ! ; IMMEDIATE
: ) ?COMP 3 ?PAIRS COMPILE (LOOP) DUP 2+ BACK HERE SWAP ! ; IMMEDIATE
To be continued when I discover how to do Folly with Supper FORTH ! Wich by the way has no ?DO word to inspire me.
For the time being, here is the final version of "Folly" for ComputerOne FORTH owners :
Code: Select all
40-COLS
VOCABULARY folly
folly DEFINITIONS
VARIABLE COLOR
HEX
: black 0000 COLOR ! ;
: blue 0055 COLOR ! ;
: red 00AA COLOR ! ;
: green AA00 COLOR ! ;
: magenta 00FF COLOR ! ;
: cyan AA55 COLOR ! ;
: yellow AAAA COLOR ! ;
: white AAFF COLOR ! ;
AAFF.A8FC 2CONSTANT FC
0 CONSTANT SOUTH
1 CONSTANT EAST
2 CONSTANT NORTH
3 CONSTANT WEST
CREATE TURNS
AAFF , A8FC , AAFF , A8FC , AAFF , A8FC , AAFF , A8FC , AAFF ,
A0F0 , AAFF , A0F0 , AAFF , A0F0 , AAFF , 80C0 , AAFF , 80C0 ,
AAFF , 0000 , A0F0 , 0000 , A8FC , A8FC , A0F0 , A0F0 , 80C0 ,
A0F0 , 0000 , AAFF , 0000 , AAFF , 80C0 , AAFF , 80C0 , AAFF ,
A0F0 , AAFF , A0F0 , AAFF , A0F0 , AAFF , A8FC , AAFF , A8FC ,
AAFF , A8FC , AAFF , A8FC , 80C0 , A0F0 , A0F0 , A8FC , A8FC ,
0000 , 283C , 0203 , A8FC , 0A0F , A8FC , 0A0F , A8FC , 2A3F ,
A8FC , 2A3F , A8FC , 2A3F , A8FC , AAFF , A8FC , AAFF , A8FC ,
AAFF , A8FC , AAFF , A8FC , 080C , 283C , 283C , A8FC , A8FC ,
AAFF , A8FC , AAFF , A8FC , AAFF , A8FC , AAFF , A8FC , 2A3F ,
A8FC , 2A3F , A8FC , 3A3F , A8FC , 0A0F , A8FC , 0A0F , A8FC ,
0203 , A8FC , 0000 , 283C , A8FC , A8FC , 283C , 283C , 080C ,
DECIMAL
: DEFER CREATE ['] NOOP , DOES> @ EXECUTE ; DEFER GRID
: (IS) R@ @ >BODY ! R> 2+ >R ; DEFER PLOT-STEP DEFER PLOT-TURN
: IS STATE @ IF COMPILE (IS) ELSE ' >BODY ! THEN ; IMMEDIATE
( couleur,x,y -- )
: SMALL-STEP
5 0 DO
2DUP 6 * I + 128 *
SWAP 2* + 3 PICK FC DROP AND
SWAP 900 + 2 !L
LOOP
2DROP DROP ;
: BIG-STEP
11 0 DO
2DUP 12 * I + 128 *
SWAP 2* 2* + DUP 4 PICK FC SWAP >R AND
SWAP 900 + 2 !L
3 PICK R> AND SWAP 902 + 2 !L
LOOP
2DROP DROP ;
( couleur,v,x,y -- )
: SMALL-TURN
5 0 DO
2DUP 6 * I + 128 *
SWAP 2* + 3 PICK 2/ 27 * I + 22 + 2*
TURNS + @ 5 PICK AND SWAP 900 + 2 !L
LOOP
2DROP 2DROP ;
: BIG-TURN
11 0 DO
2DUP 12 * I + 128 *
SWAP 2* 2* + I 2* 2* 4 PICK 27 * +
TURNS + 2@ 6 PICK AND 2 PICK 900 + 2 !L
5 PICK AND SWAP 902 + 2 !L
LOOP
2DROP 2DROP ;
VARIABLE AZIMUTH 2VARIABLE XY DEFER MX DEFER MY
60 CONSTANT SMX 34 CONSTANT SMY 30 CONSTANT BMX 17 CONSTANT BMY
: BG 26886 2310 DO 116 0 DO 2 I J + 2 !L 4 +LOOP 1536 +LOOP ;
: SG 26118 1540 DO 118 0 DO 2 I J + 2 !L 2 +LOOP 768 +LOOP ;
ATTACH DIALOG CON_486x42a12x213 ATTACH WORKSP SCR_486x207a12x5
: small ['] SG IS GRID ['] SMX IS MX ['] SMY IS MY
['] SMALL-STEP IS PLOT-STEP ['] SMALL-TURN IS PLOT-TURN ;
: big ['] BG IS GRID ['] BMX IS MX ['] BMY IS MY
['] BIG-STEP IS PLOT-STEP ['] BIG-TURN IS PLOT-TURN ;
: zap WORKSP CHANNEL IS-WORK 0 PAPER 1 7 BORDER CLS DIALOG
IS-IO 2 PAPER 7 INK 1 7 BORDER 2 1 CSIZE CLS GRID ;
: SOUTH>EAST COLOR @ 6 XY 2@ PLOT-TURN
XY 2@ SWAP 1+ MX MOD SWAP XY 2! EAST azimuth ! ;
: EAST>NORTH COLOR @ 0 XY 2@ PLOT-TURN
XY 2@ 1- MY MOD XY 2! NORTH azimuth ! ;
: NORTH>WEST COLOR @ 2 XY 2@ PLOT-TURN
XY 2@ SWAP 1- MX MOD SWAP XY 2! WEST azimuth ! ;
: WEST>SOUTH COLOR @ 4 XY 2@ PLOT-TURN
XY 2@ 1+ MY MOD XY 2! SOUTH azimuth ! ;
: SOUTH>WEST COLOR @ 0 XY 2@ PLOT-TURN
XY 2@ SWAP 1- MX MOD SWAP XY 2! WEST azimuth ! ;
: WEST>NORTH COLOR @ 6 XY 2@ PLOT-TURN
XY 2@ 1- MY MOD XY 2! NORTH azimuth ! ;
: NORTH>EAST COLOR @ 4 XY 2@ PLOT-TURN
XY 2@ SWAP 1+ MX MOD SWAP XY 2! EAST azimuth ! ;
: EAST>SOUTH COLOR @ 2 XY 2@ PLOT-TURN
XY 2@ 1+ MY MOD XY 2! SOUTH azimuth ! ;
: step COLOR @ XY 2@ PLOT-STEP AZIMUTH @ CASE
SOUTH OF XY 2@ 1+ MY MOD XY 2! ENDOF
EAST OF XY 2@ SWAP 1+ MX MOD SWAP XY 2! ENDOF
NORTH OF XY 2@ 1- MY MOD XY 2! ENDOF
WEST OF XY 2@ SWAP 1- MX MOD SWAP XY 2! ENDOF ENDCASE ;
: left AZIMUTH @ CASE
SOUTH OF SOUTH>EAST ENDOF
EAST OF EAST>NORTH ENDOF
NORTH OF NORTH>WEST ENDOF
WEST OF WEST>SOUTH ENDOF ENDCASE ;
: right AZIMUTH @ CASE
SOUTH OF SOUTH>WEST ENDOF
EAST OF EAST>SOUTH ENDOF
NORTH OF NORTH>EAST ENDOF
WEST OF WEST>NORTH ENDOF ENDCASE ;
: times( ?COMP COMPILE 0 COMPILE (?DO) HERE 0 , 3 ; IMMEDIATE
: ) ?COMP 3 ?PAIRS COMPILE (LOOP) DUP 2+ BACK HERE SWAP ! ; IMMEDIATE
: steps times( step ) ;
ATTACH WHOLE CON_492x256a10x0
: vlist WHOLE IS-IO 0 PAPER 4 INK 0 0 CSIZE CLS WORDS ;
: origin ( color,azimuth,x,y --- ) XY 2! AZIMUTH ! step ;
: loleft red NORTH 1 MY 2 - origin ;
: center red NORTH MX 2/ MY 2/ origin ;
big zap
EOF
FCB SOURCE SOURCE FILENAME mdv1_source_fth
: LOAD-SOURCE SOURCE OPEN-FILE 0<> IF
ABORT" File not found" THEN SOURCE CHANNEL IS-INPUT ;
: EOF OUTPUT IS-INPUT SOURCE CLOSE-FILE . ;
: LOAD-FILE SOURCE FILENAME LOAD-SOURCE ;
: PRINT SCR ! 16 0 DO CR I SCR @ .LINE LOOP ;
: MAKE-SOURCE ( n1,n2 --- ) SOURCE FILENAME SOURCE MAKE-FILE .
SOURCE CHANNEL IS-OUTPUT 1+ SWAP DO I PRINT LOOP CR ." EOF"
CR INPUT IS-OUTPUT SOURCE CLOSE-FILE . ;