From: Tim Vaughan <tgvaughan@gmail.com>
Date: Sun, 12 Jun 2016 01:03:05 +0000 (+1200)
Subject: Initial commit.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=96099b1d09aae7cf167efca9fd04406750eb7157;p=scheme.forth.jl.git

Initial commit.
---

96099b1d09aae7cf167efca9fd04406750eb7157
diff --git a/scheme.4th b/scheme.4th
new file mode 100644
index 0000000..5fe8b3e
--- /dev/null
+++ b/scheme.4th
@@ -0,0 +1,179 @@
+\ Scheme interpreter
+
+vocabulary scheme
+scheme definitions
+
+\ Cons cell memory
+1000 constant memsize
+create car memsize allot
+create cdr memsize allot
+create types memsize allot
+
+0 constant symbol-type
+1 constant int-type
+2 constant list-type
+3 constant bool-type
+
+variable nextfree
+0 nextfree !
+
+: stack
+    create here 1+ , allot ;
+
+
+: push ( st v -- )
+    over @ !
+    1 swap +!
+;
+
+: pop ( st -- v )
+    dup @       ( s0 sp )
+    1-          ( so sp' )
+
+    2dup = abort" Stack underflow."
+    
+    dup @       ( s0 sp' v )
+    -rot swap   ( v sp' s0 )
+    !
+;
+
+100 stack parse-stack 
+variable parse-idx
+variable parse-str
+
+
+: inc-parse-idx parse-idx +! ;
+: dec-parse-idx parse-idx -! ;
+
+: ?charavailable ( -- bool )
+    parse-str @ @ parse-idx @ >
+;
+
+: nextchar ( -- char )
+    ?charavailable if
+        parse-str @ 1+ parse-idx @ + @
+    else
+        0
+    then
+;
+
+: ?whitespace ( -- bool )
+    nextchar BL = 
+    nextchar '\n' = or
+;
+
+: ?delim ( -- bool )
+    ?whitespace
+    nextchar [char] ( = or
+    nextchar [char] ) = or
+;
+
+: eatspaces
+    begin
+        ?whitespace
+    while
+            1 parse-idx +!
+    repeat
+;
+
+: parsebool
+
+    nextchar emit cr
+    trace
+
+    false
+    nextchar [char] # <> if exit then
+
+    1 inc-parse-idx
+
+    nextchar dup [char] t = swap [char] f = or
+    not if
+        1 dec-parse-idx
+        exit
+    then
+
+    1 inc-parse-idx
+
+    ?delim not if
+        2 dec-parse-idx
+        exit
+    then
+;
+
+: parsetoken
+
+    eatspaces
+
+    \ Parens
+
+    nextchar [char] ( = if
+        \ todo
+        exit
+    then
+
+    nextchar [char] ) = if
+        \ todo
+        exit
+    then
+
+    parsebool if
+        exit
+    exit
+;
+
+\ Parse a counted string into a scheme expression
+: parseexp ( straddr n -- exp )
+    0 parse-idx !
+
+    begin
+        parsetoken
+    nextchar 0 =
+    until
+;
+
+\ ---- REPL ----
+
+: escape 27 emit [char] [ emit ;
+: escape-end [char] m emit ;
+
+: set-term-colour
+    escape [char] 3 emit [char] 0 + emit escape-end
+;
+
+: reset-term
+    escape [char] 0 escape-end
+;
+
+: colour
+    create ,
+does>
+    @ set-term-colour
+;
+
+1 colour red
+2 colour green
+3 colour yellow
+4 colour blue
+5 colour magenta
+6 colour cyan
+7 colour white
+
+create repl-buffer 161 allot
+
+: repl
+    repl-buffer parse-str !
+
+    cr
+
+    begin
+        green ." => " white
+
+        repl-buffer 1+ 160 expect cr
+        span @ repl-buffer !
+
+        parseexp
+        \ eval
+    again
+;
+
+forth definitions