Re-root site.

attic/circleforth/README.md

@@ -0,0 +1,6 @@
+# Circleforth
+
+Created as an example of a minimalist Forth in the style of typical "toy" Lisp implementations.
+
+Similar to classic "Eval-Apply" style Lisps, the core problem of reimplementing the core interpreter
+is approached on top of an existing Forth. Primitives are reused, and crucially parsing is reused.

attic/circleforth/circle.fs

@@ -0,0 +1,99 @@
+#! /usr/bin/env gforth
+
+\ Copyright 2021 Bradley D. Nelson
+\
+\ Licensed under the Apache License, Version 2.0 (the "License");
+\ you may not use this file except in compliance with the License.
+\ You may obtain a copy of the License at
+\
+\     http://www.apache.org/licenses/LICENSE-2.0
+\
+\  Unless required by applicable law or agreed to in writing, software
+\  distributed under the License is distributed on an "AS IS" BASIS,
+\  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+\  See the License for the specific language governing permissions and
+\  limitations under the License.
+
+( 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
+: \   10 parse drop drop ; immediate
+( And now we have comments! )
+include compound.fs
+ok

attic/circleforth/compound.fs

@@ -0,0 +1,101 @@
+( CircleForth - Compound words )
+
+\ Copyright 2021 Bradley D. Nelson
+\
+\ Licensed under the Apache License, Version 2.0 (the "License");
+\ you may not use this file except in compliance with the License.
+\ You may obtain a copy of the License at
+\
+\     http://www.apache.org/licenses/LICENSE-2.0
+\
+\  Unless required by applicable law or agreed to in writing, software
+\  distributed under the License is distributed on an "AS IS" BASIS,
+\  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+\  See the License for the specific language governing permissions and
+\  limitations under the License.
+
+( 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<b ) - 0< ;
+: > ( 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 ;
+