diff --git a/circle.fs b/circle.fs new file mode 100755 index 0000000..bf46cad --- /dev/null +++ b/circle.fs @@ -0,0 +1,83 @@ +#! /usr/bin/env gforth +( CircleForth ) +vocabulary circleforth circleforth definitions + +( Internal rstack ) +create rstack 1000 cells allot variable rp rstack rp ! +: rp@ rp @ ; : rp! rp ! ; : r@ rp@ @ ; +: >r cell rp +! rp@ ! ; : r> r@ -1 cells rp +! ; +( Internal IP & W ) +variable ip variable w +: run 0 >r begin ip @ @ cell ip +! dup w ! @ execute ip @ 0= until ; + +variable last +( Create dictionary entry: { name-bytes name-len flags link code } ) +: splace ( a n -- ) dup >r 0 do dup c@ c, 1+ loop drop r> , ; +: create-name ( a n -- ) splace 0 , last @ , here 0 , last ! ; +: code! last @ ! ; +: p: ' dup >name name>string create-name code! ; +: >p create-name ' code! ; +( Access dictionary entry ) +: >link ( xt -- a ) 1 cells - @ ; : >flags 2 cells - ; +: >name ( xt -- a n ) dup 3 cells - @ swap over - 3 cells - swap ; +: or! ( n a -- ) dup @ rot or swap ! ; +: immediate 1 last @ >flags or! ; : immediate? >flags @ 1 and 0<> ; + +( Interpreter branching, calling, and literals ) +: docreate: w @ cell+ cell+ ; +: dodoes: docreate: ip @ >r w @ cell+ @ ip ! ; +: docol: ip @ >r w @ cell+ ip ! ; +: dolit: ip @ @ cell ip +! ; +: branch ip @ @ ip ! ; +: 0branch if cell ip +! else ip @ @ ip ! then ; + +( CREATE DOES> ) +: create parse-name create-name ['] docreate: code! 0 , ; +: does> ['] dodoes: code! ip @ last @ cell+ ! r> ip ! ; + +( Words that traverse the dictionary ) +: find ( a n -- xt ) + last @ begin >r 2dup r@ >name str= if 2drop r> exit then + r> >link dup 0= until drop 2drop 0 ; + +( Literal handling ) +p: dolit: s" dolit:" find constant dolit:-xt +: aliteral dolit:-xt , , ; p: aliteral +( Exit & Execute ) +: 'exit r> ip ! ; s" exit" >p 'exit s" exit" find constant exit-xt +: execute ( xt -- ) >r exit-xt >r rp @ 1 cells - ip ! ; p: execute +( Compiling words ) +variable state +: colon parse-name create-name ['] docol: code! -1 state ! ; s" :" >p colon +: semicolon exit-xt , 0 state ! ; s" ;" >p semicolon immediate + +( Pass thru primitives ) +p: 0= p: 0< p: + p: */mod p: and p: or p: xor +p: dup p: swap p: over p: drop p: sp@ p: sp! +p: . p: type p: key +p: @ p: ! p: c@ p: c! +p: parse-name p: parse p: here p: , p: allot +p: base p: depth p: cell +( Reimplemented primitives ) +p: r@ p: >r p: r> p: rp@ p: rp! +p: branch p: 0branch p: find +p: immediate p: create p: does> +p: last p: state + +( Evaluate source ) +: one-word dup immediate? 0= state @ and if , else execute run then ; +: one-number' state @ if aliteral then ; +: one-number s>number? 0= throw drop one-number' ; +: one-name 2dup find dup if nip nip one-word else drop one-number then ; +: prompt source-id 0= if ." ok" cr then ; +: eval-line begin parse-name dup if one-name else 2drop exit then again ; +: boot begin ['] eval-line catch if ." ERROR" cr then prompt refill drop again ; +: include parse-name slurp-file ['] eval-line execute-parsing ; p: include +: ok ." CircleForth" cr ." ok" cr query ; p: ok : bye cr bye ; p: bye + +( Bootstrap ) +boot +: ( 41 parse drop drop ; immediate +( And now we have comments! ) +include compound.fs +ok diff --git a/compound.fs b/compound.fs new file mode 100644 index 0000000..56f5031 --- /dev/null +++ b/compound.fs @@ -0,0 +1,87 @@ +( CircleForth - Compound words ) + +( Useful basic compound words ) +: 2drop ( n n -- ) drop drop ; +: 2dup ( a b -- a b a b ) over over ; +: nip ( a b -- b ) swap drop ; +: rdrop ( r: n n -- ) r> r> drop >r ; +: */ ( n n n -- n ) */mod nip ; +: * ( n n -- n ) 1 */ ; +: /mod ( n n -- n n ) 1 swap */mod ; +: / ( n n -- n ) /mod nip ; +: mod ( n n -- n ) /mod drop ; +: invert ( n -- ~n ) -1 xor ; +: negate ( n -- -n ) invert 1 + ; +: - ( n n -- n ) negate + ; +: rot ( a b c -- c a b ) >r swap r> swap ; +: -rot ( a b c -- b c a ) swap >r swap r> ; +: cell+ ( n -- n ) cell + ; +: cells ( n -- n ) cell * ; +: < ( a b -- a ( a b -- a>b ) swap - 0< ; +: = ( a b -- a!=b ) - 0= ; +: <> ( a b -- a!=b ) = 0= ; +: emit ( n -- ) >r rp@ 1 type rdrop ; +: bl 32 ; : space bl emit ; +: nl 10 ; : cr nl emit ; + +( Compilation State ) +: [ 0 state ! ; immediate +: ] -1 state ! ; immediate + +( Quoting words ) +: ' parse-name find ; +: ['] ' aliteral ; immediate +: char parse-name drop c@ ; +: [char] char aliteral ; immediate +: literal aliteral ; immediate + +( Core Control Flow ) +: begin here ; immediate +: again ['] branch , , ; immediate +: until ['] 0branch , , ; immediate +: ahead ['] branch , here 0 , ; immediate +: then here swap ! ; immediate +: if ['] 0branch , here 0 , ; immediate +: else ['] branch , here 0 , swap here swap ! ; immediate + +( Compound words requiring conditionals ) +: min 2dup < if drop else nip then ; +: max 2dup < if nip else drop then ; + +( Postpone - done here so we have ['] and if ) +: >flags 2 cells - @ ; +: immediate? >flags 1 and 1 - 0= ; +: postpone ' dup immediate? if , else aliteral ['] , , then ; immediate + +( Counted Loops ) +: do postpone swap postpone >r postpone >r here ; immediate +: i postpone r@ ; immediate +: unloop postpone rdrop postpone rdrop ; immediate +: +loop postpone r> postpone + postpone r> + postpone 2dup postpone >r postpone >r + postpone < postpone 0= postpone until + postpone unloop ; immediate +: loop 1 aliteral postpone +loop ; immediate + +( Constants and Variables ) +: constant create , does> @ ; +: variable create 0 , ; + +( Exceptions ) +variable handler +: catch sp@ >r handler @ >r rp@ handler ! execute r> handler ! r> drop 0 ; +: throw handler @ rp! r> handler ! r> swap >r sp! drop r> ; + +( Examine Dictionary ) +: >link ( xt -- a ) 1 cells - @ ; : >flags 2 cells - ; +: >name ( xt -- a n ) dup 3 cells - @ swap over - 3 cells - swap ; +: >body ( xt -- a ) cell+ ; +: see. ( xt -- ) >name type space ; +: see-one ( xt -- xt+1 ) + dup @ dup ['] dolit: = if drop cell+ dup @ . else see. then cell+ ; +: exit= ( xt -- ) ['] exit = ; +: see-loop >body begin see-one dup @ exit= until ; +: see cr ['] : see. ' dup see. see-loop drop ['] ; see. cr ; +: words last @ begin dup >name type space >link dup 0= until drop cr ; +