#!/usr/bin/pl ; Print with a newline (def prnl (fn (_txt) ( (prn _txt) (pch 10) ))) ; Initialize an empty stack (def stack ()) ; Add the given num to the stack (def stkadd (fn (a) (def stack (pre stack a)))) ; Silently remove the top of the stack (def _pop (fn (_) (def stack (rest stack)))) ; Remove and return the stack top (def bop (fn (_) ( (def _a (at 0 stack)) (_pop 0) _a ))) ; Loud, checked version of _pop (def pop (fn (_) (if (> (len stack 0) 0) ( (prn (at 0 stack)) (_pop 0)) (prnl "pop: STACK EMPTY") ))) ; Takes a two-parameter operation and ; applies it to the top two stack elements (def twop (fn (_op) ( (if (> (len stack) 1) ( (def (_b _a) ((bop 0) (bop 0))) (stkadd (_op _a _b))) (prnl "twop: STACK TOO SMALL") )))) ; Define important symbols/functions ; An annoying hack for right now (def . ".") (def : ":") (def ^ "^") (def $ "$") (def swap "swap") (def dup "dup") (def rot "rot") (def over "over") ; Duplicate the top element of the stack (def _dup (fn (_) ( (def _top (at 0 stack)) (if (iserr _top) (prnl "dup: STACK EMPTY") (stkadd _top)) ))) ; Swap the top two elements of the stack, if possible (def _swap (fn (_) ( (if (> (len stack) 1) ( (def (_b _a) ((bop 0) (bop 0))) (stkadd _b) (stkadd _a)) (prnl "swap: STACK TOO SMALL") )))) ; Rotate the third element to be above the first and second elements (def _rot (fn (_) ( (if (> (len stack) 2) ( (def (_c _b _a) ((bop 0) (bop 0) (bop 0))) (stkadd _b) (stkadd _c) (stkadd _a)) (prnl "rot: STACK TOO SMALL") )))) ; Rotate the third element to be above the first and second elements (def _over (fn (_) ( (if (> (len stack) 1) ( (def _a (at 1 stack)) (stkadd _a)) (prnl "over: STACK TOO SMALL") )))) ; Defines a given symbol using a given list of Forth inputs (def compile (fn (func sym) ( (def _x (at 0 func)) (if (= _x "$") (rest func) (at 1 ( (defe sym (ap (eval sym) _x)) (compile (rest func) sym)) ))))) ; Evaluate a list of Forth inputs (def feval (fn (list) ( (if (> (len list) 0) ( (def _x (at 0 list)) (if (isnum _x) (stkadd _x) ; Push to the stack if it's a number (if (= "." _x) (pop 0) ; Pop if it's a dot (if (= + _x) (twop +) ; Try basic arithmetic (if (= - _x) (twop -) (if (= * _x) (twop *) (if (= / _x) (twop /) (if (= "swap" _x) (_swap 0) (if (= "dup" _x) (_dup 0) (if (= "rot" _x) (_rot 0) (if (= "over" _x) (_over 0) (if (= "^" _x) (pch (bop 0)) (if (= ":" _x) ( ; Compile a phrase into the next symbol (def var (at 1 list)) ; Collect the symbol to define, as a string (defe var (+ "_" var)) ; Add an underscore for the internal storage (defe (+ "_" var) ()) ; Define internally as an empty list (def list (compile ; Overwrite list with output of (compile) (rest (rest list)) ; Current list, not including ':' or the symbol (+ "_" var)))) ; The internal variable name ( ; If none of the above hit, try to interpret as a compiled symbol (def _e (eval _x)) (if (iserr (len _e)) () (feval _e)) ) )))))))))))) ; A switch/case operator might be good, to avoid huge closing-paren chains ; If any list is left, recurse into it (if (> (len list) 0) (feval (rest list)) ()) ) () ; Meow! )))) ; A simple test of the built-in arithmetic (def test (fn (_) ( (prnl "Should match:") (prnl "18 33 4 -4") (feval ( 6 3 * . 32 ^ 100 3 / . 32 ^ 2 2 + . 32 ^ 5 9 - . )) (pch 10) (pch 10) ))) ;; Example Compilations ; Basic imperial distances (feval (: "ft" 12 * $)) (feval (: "yd" ft 3 * $)) (feval (: "in" $)) (feval (: "i>f" 1 ft / $)) (feval (: "i>y" 1 yd / $)) ; Convert between Farenheit and Celcius (feval (: "f>c" 32 - 5 * 9 /$)) (feval (: "c>f" 9 * 5 / 32 + $)) ; Math (feval (: "sq" dup * $)) ; Gets next Fibonacci number from two on stack (feval (: "fib" swap over + dup . $)) ; A simple REPL. Exits on 'q' (def repl (fn (_) ( (prn "forbble::> ") (def _inp (inp 0 0)) (if (= "q" _inp) () ( (def _str (+ "(feval (" _inp "))" )) (eval _str) (pch 10) (repl 0) ))))) ; Run the REPL (repl 0)