Follows forth 83 standard.
100 value xsteps
30 value ysteps
100 value xsteps
30 value ysteps
-: mandelDomain
- -2 0 >scaled -1 0 >scaled 0 5 >scaled 1 0 >scaled
-;
-
( Draw the Mandelbrot Set!)
( Draw the Mandelbrot Set!)
-: mandelDraw ( x1 y1 x2 y2 -- )
+: mandeldraw ( x1 y1 x2 y2 -- )
0 pick 3 pick - ysteps /
1 pick 4 pick do
0 pick 3 pick - ysteps /
1 pick 4 pick do
( Clean up - hide non-standard multiplication def. )
hide *
( Clean up - hide non-standard multiplication def. )
hide *
+
+( Default picture )
+: mandel
+ -2 0 >scaled -1 0 >scaled 0 5 >scaled 1 0 >scaled
+ mandeldraw
+;
+
+." Enter 'mandel' to draw the Mandelbrot Set."
return NEXT
end, flags=F_IMMED)
return NEXT
end, flags=F_IMMED)
-#TICK = defWord("'",
-# [STATE_CFA, FETCH, ZBRANCH, 7,
-# FROMR, DUP, INCR, TOR, FETCH, EXIT,
-# WORD, FIND, TOCFA, EXIT])
-
+ [WORD, FIND, TOCFA, EXIT])
+
+BTICK = defWord("[']",
[FROMR, DUP, INCR, TOR, FETCH, EXIT])
[FROMR, DUP, INCR, TOR, FETCH, EXIT])
-: LITERAL IMMEDIATE ' LIT , , ;
+: LITERAL IMMEDIATE ['] LIT , , ;
: ':' [ CHAR : ] LITERAL ;
: ';' [ CHAR ; ] LITERAL ;
: ':' [ CHAR : ] LITERAL ;
: ';' [ CHAR ; ] LITERAL ;
\ CONTROL STRUCTURES ----------------------------------------------------------------------
: IF IMMEDIATE
\ CONTROL STRUCTURES ----------------------------------------------------------------------
: IF IMMEDIATE
- ' 0BRANCH , \ compile 0BRANCH
+ ['] 0BRANCH , \ compile 0BRANCH
HERE @ \ save location of the offset on the stack
0 , \ compile a dummy offset
;
HERE @ \ save location of the offset on the stack
0 , \ compile a dummy offset
;
- ' BRANCH , \ definite branch to just over the false-part
+ ['] BRANCH , \ definite branch to just over the false-part
HERE @ \ save location of the offset on the stack
0 , \ compile a dummy offset
SWAP \ now back-fill the original (IF) offset
HERE @ \ save location of the offset on the stack
0 , \ compile a dummy offset
SWAP \ now back-fill the original (IF) offset
- ' 0BRANCH , \ compile 0BRANCH
+ ['] 0BRANCH , \ compile 0BRANCH
HERE @ - \ calculate the offset from the address saved on the stack
, \ compile the offset here
;
: AGAIN IMMEDIATE
HERE @ - \ calculate the offset from the address saved on the stack
, \ compile the offset here
;
: AGAIN IMMEDIATE
- ' BRANCH , \ compile BRANCH
+ ['] BRANCH , \ compile BRANCH
HERE @ - \ calculate the offset back
, \ compile the offset here
;
: WHILE IMMEDIATE
HERE @ - \ calculate the offset back
, \ compile the offset here
;
: WHILE IMMEDIATE
- ' 0BRANCH , \ compile 0BRANCH
+ ['] 0BRANCH , \ compile 0BRANCH
HERE @ \ save location of the offset2 on the stack
0 , \ compile a dummy offset2
;
: REPEAT IMMEDIATE
HERE @ \ save location of the offset2 on the stack
0 , \ compile a dummy offset2
;
: REPEAT IMMEDIATE
- ' BRANCH , \ compile BRANCH
+ ['] BRANCH , \ compile BRANCH
SWAP \ get the original offset (from BEGIN)
HERE @ - , \ and compile it after BRANCH
DUP
SWAP \ get the original offset (from BEGIN)
HERE @ - , \ and compile it after BRANCH
DUP
- ' NOT , \ compile NOT (to reverse the test)
+ ['] NOT , \ compile NOT (to reverse the test)
[COMPILE] IF \ continue by calling the normal IF
;
: DO IMMEDIATE
[COMPILE] IF \ continue by calling the normal IF
;
: DO IMMEDIATE
- ' LIT , -1 , [COMPILE] IF
- ' >R , ' >R ,
- ' LIT , HERE @ 0 , ' >R ,
+ ['] LIT , -1 , [COMPILE] IF
+ ['] >R , ['] >R ,
+ ['] LIT , HERE @ 0 , ['] >R ,
- ' 2DUP , ' - , [COMPILE] IF
- ' >R , ' >R ,
- ' LIT , HERE @ 0 , ' >R ,
+ ['] 2DUP , ['] - , [COMPILE] IF
+ ['] >R , ['] >R ,
+ ['] LIT , HERE @ 0 , ['] >R ,
: J RSP@ 6 - @ ;
: ?LEAVE IMMEDIATE
: J RSP@ 6 - @ ;
: ?LEAVE IMMEDIATE
- ' 0BRANCH , 13 ,
- ' R> , ' RDROP , ' RDROP ,
- ' LIT , HERE @ 7 + , ' DUP , ' -ROT , ' - , ' SWAP , ' ! ,
- ' BRANCH ,
+ ['] 0BRANCH , 13 ,
+ ['] R> , ['] RDROP , ['] RDROP ,
+ ['] LIT , HERE @ 7 + , ['] DUP , ['] -ROT , ['] - , ['] SWAP , ['] ! ,
+ ['] BRANCH ,
[COMPILE] ?LEAVE
;
: +LOOP IMMEDIATE
[COMPILE] ?LEAVE
;
: +LOOP IMMEDIATE
- ' DUP , \ Store copy of increment
+ ['] DUP , \ Store copy of increment
- ' R> , ' SWAP , ' R> , ' SWAP , ' R> , ' SWAP , ' + , ' 2DUP , ' - ,
- ' SWAP , ' >R , ' SWAP , ' >R , ' SWAP , ' >R ,
+ ['] R> , ['] SWAP , ['] R> , ['] SWAP , ['] R> , ['] SWAP , ['] + , ['] 2DUP , ['] - ,
+ ['] SWAP , ['] >R , ['] SWAP , ['] >R , ['] SWAP , ['] >R ,
\ Condition differently depending on sign of increment
\ Condition differently depending on sign of increment
- ' SWAP , ' 0>= , [COMPILE] IF
- ' 0<= ,
+ ['] SWAP , ['] 0>= , [COMPILE] IF
+ ['] 0<= ,
[COMPILE] THEN
\ Branch back to begining of loop kernel
[COMPILE] THEN
\ Branch back to begining of loop kernel
+ ['] 0BRANCH , HERE @ - ,
- ' RDROP , ' RDROP , ' RDROP ,
+ ['] RDROP , ['] RDROP , ['] RDROP ,
\ Record address of loop end for any LEAVEs to use
HERE @ SWAP !
[COMPILE] ELSE
\ Record address of loop end for any LEAVEs to use
HERE @ SWAP !
[COMPILE] ELSE
- ' 2DROP , \ Clean up if loop was entirely skipped (?DO)
+ ['] 2DROP , \ Clean up if loop was entirely skipped (?DO)
[COMPILE] THEN
;
: LOOP IMMEDIATE
[COMPILE] THEN
;
: LOOP IMMEDIATE
: S" IMMEDIATE ( -- addr len )
STATE @ IF ( compiling? )
: S" IMMEDIATE ( -- addr len )
STATE @ IF ( compiling? )
- ' LITSTRING , ( compile LITSTRING )
+ ['] LITSTRING , ( compile LITSTRING )
HERE @ ( save the address of the length word on the stack )
0 , ( dummy length - we don't know what it is yet )
KEY DROP
HERE @ ( save the address of the length word on the stack )
0 , ( dummy length - we don't know what it is yet )
KEY DROP
: ." IMMEDIATE ( -- )
STATE @ IF ( compiling? )
[COMPILE] S" ( read the string, and compile LITSTRING, etc. )
: ." IMMEDIATE ( -- )
STATE @ IF ( compiling? )
[COMPILE] S" ( read the string, and compile LITSTRING, etc. )
- ' TELL , ( compile the final TELL )
+ ['] TELL , ( compile the final TELL )
ELSE
( In immediate mode, just read characters and print them until we get
to the ending double quote. )
ELSE
( In immediate mode, just read characters and print them until we get
to the ending double quote. )
WORD ( get the name (the name follows CONSTANT) )
CREATE ( make the dictionary entry )
DOCOL , ( append DOCOL (the codeword field of this word) )
WORD ( get the name (the name follows CONSTANT) )
CREATE ( make the dictionary entry )
DOCOL , ( append DOCOL (the codeword field of this word) )
- ' LIT , ( append the codeword LIT )
-\ , ( append the value on the top of the stack )
- ' EXIT , ( append the codeword EXIT )
+ ['] LIT , ( append the codeword LIT )
+ , ( append the value on the top of the stack )
+ ['] EXIT , ( append the codeword EXIT )
1 CELLS ALLOT ( allocate 1 cell of memory, push the pointer to this memory )
WORD CREATE ( make the dictionary entry (the name follows VARIABLE) )
DOCOL , ( append DOCOL (the codeword field of this word) )
1 CELLS ALLOT ( allocate 1 cell of memory, push the pointer to this memory )
WORD CREATE ( make the dictionary entry (the name follows VARIABLE) )
DOCOL , ( append DOCOL (the codeword field of this word) )
- ' LIT , ( append the codeword LIT )
+ ['] LIT , ( append the codeword LIT )
, ( append the pointer to the new memory )
, ( append the pointer to the new memory )
- ' EXIT , ( append the codeword EXIT )
+ ['] EXIT , ( append the codeword EXIT )
;
: VALUE ( n -- )
WORD CREATE ( make the dictionary entry (the name follows VALUE) )
DOCOL , ( append DOCOL )
;
: VALUE ( n -- )
WORD CREATE ( make the dictionary entry (the name follows VALUE) )
DOCOL , ( append DOCOL )
- ' LIT , ( append the codeword LIT )
+ ['] LIT , ( append the codeword LIT )
, ( append the initial value )
, ( append the initial value )
- ' EXIT , ( append the codeword EXIT )
+ ['] EXIT , ( append the codeword EXIT )
;
: TO IMMEDIATE ( n -- )
;
: TO IMMEDIATE ( n -- )
>DFA ( get a pointer to the first data field (the 'LIT') )
1+ ( increment to point at the value )
STATE @ IF ( compiling? )
>DFA ( get a pointer to the first data field (the 'LIT') )
1+ ( increment to point at the value )
STATE @ IF ( compiling? )
- ' LIT , ( compile LIT )
+ ['] LIT , ( compile LIT )
, ( compile the address of the value )
, ( compile the address of the value )
ELSE ( immediate mode )
! ( update it straightaway )
THEN
ELSE ( immediate mode )
! ( update it straightaway )
THEN
>DFA ( get a pointer to the first data field (the 'LIT') )
1+ ( increment to point at the value )
STATE @ IF ( compiling? )
>DFA ( get a pointer to the first data field (the 'LIT') )
1+ ( increment to point at the value )
STATE @ IF ( compiling? )
- ' LIT , ( compile LIT )
+ ['] LIT , ( compile LIT )
, ( compile the address of the value )
, ( compile the address of the value )
+ ['] +! , ( compile +! )
ELSE ( immediate mode )
+! ( update it straightaway )
THEN
ELSE ( immediate mode )
+! ( update it straightaway )
THEN
- ' OVER , ( compile OVER )
- ' = , ( compile = )
+ ['] OVER , ( compile OVER )
+ ['] = , ( compile = )
[COMPILE] IF ( compile IF )
[COMPILE] IF ( compile IF )
- ' DROP , ( compile DROP )
+ ['] DROP , ( compile DROP )
- ' DROP , ( compile DROP )
+ ['] DROP , ( compile DROP )
( keep compiling THEN until we get to our zero marker )
BEGIN
( keep compiling THEN until we get to our zero marker )
BEGIN
DUP @ ( end start codeword )
CASE
DUP @ ( end start codeword )
CASE
- ' LIT OF ( is it LIT ? )
+ ['] LIT OF ( is it LIT ? )
1+ DUP @ ( get next word which is the integer constant )
. ( and print it )
ENDOF
1+ DUP @ ( get next word which is the integer constant )
. ( and print it )
ENDOF
- ' LITSTRING OF ( is it LITSTRING ? )
+ ['] LITSTRING OF ( is it LITSTRING ? )
[ CHAR S ] LITERAL EMIT '"' EMIT SPACE ( print S"<space> )
1+ DUP @ ( get the length word )
SWAP 1+ SWAP ( end start+1 length )
[ CHAR S ] LITERAL EMIT '"' EMIT SPACE ( print S"<space> )
1+ DUP @ ( get the length word )
SWAP 1+ SWAP ( end start+1 length )
+ ( end start+1+len, aligned )
1- ( because we're about to add 4 below )
ENDOF
+ ( end start+1+len, aligned )
1- ( because we're about to add 4 below )
ENDOF
- ' 0BRANCH OF ( is it 0BRANCH ? )
+ ['] 0BRANCH OF ( is it 0BRANCH ? )
." 0BRANCH ( "
1+ DUP @ ( print the offset )
.
." ) "
ENDOF
." 0BRANCH ( "
1+ DUP @ ( print the offset )
.
." ) "
ENDOF
- ' BRANCH OF ( is it BRANCH ? )
+ ['] BRANCH OF ( is it BRANCH ? )
." BRANCH ( "
1+ DUP @ ( print the offset )
.
." ) "
ENDOF
." BRANCH ( "
1+ DUP @ ( print the offset )
.
." ) "
ENDOF
- ' ' OF ( is it ' (TICK) ? )
+ ['] ['] OF ( is it ['] ? )
[ CHAR ' ] LITERAL EMIT SPACE
1+ DUP @ ( get the next codeword )
CFA> ( and force it to be printed as a dictionary entry )
ID. SPACE
ENDOF
[ CHAR ' ] LITERAL EMIT SPACE
1+ DUP @ ( get the next codeword )
CFA> ( and force it to be printed as a dictionary entry )
ID. SPACE
ENDOF
- ' EXIT OF ( is it EXIT? )
+ ['] EXIT OF ( is it EXIT? )
( We expect the last word to be EXIT, and if it is then we don't print it
because EXIT is normally implied by ;. EXIT can also appear in the middle
of words, and then it needs to be printed. )
( We expect the last word to be EXIT, and if it is then we don't print it
because EXIT is normally implied by ;. EXIT can also appear in the middle
of words, and then it needs to be printed. )