├── .gitignore ├── README.md ├── examples ├── a.c4 ├── b.c4 ├── bar.c4 ├── baz.c4 ├── dowhile.c4 ├── foo.c4 ├── hello.c4 ├── if1.c4 ├── jump.c4 ├── noop.c4 ├── pushes.c4 └── simple.c4 ├── init.c4 ├── project.clj ├── src └── cloforth │ ├── compiler.clj │ ├── dictionary.clj │ ├── environment.clj │ ├── execute.clj │ ├── primitives.clj │ ├── repl.clj │ └── tokenizer.clj └── test └── cloforth └── test ├── compiler.clj └── execute.clj /.gitignore: -------------------------------------------------------------------------------- 1 | pom.xml 2 | *jar 3 | /lib/ 4 | /classes/ 5 | .lein-deps-sum 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | cloforth 2 | ======== 3 | 4 | A little Forth-like language implemented in Clojure 5 | 6 | For a couple of hundred lines of Clojure, Cloforth 7 | is actually pretty capable. It can do basic arithmetic, 8 | it has if statements, you can define new procedures 9 | (new 'words' in the jaron of Forth). The most 10 | interesting part is that the language is built 11 | around a compile/execute cycle: All Cloforth 12 | code, even the stuff that you type in to the 13 | REPL is compiled into an vector of functions 14 | before it is executed. 15 | 16 | 17 | Cloforth is a stack oriented, postfix language. 18 | What this means is that numbers just get 19 | pushed onto the stack, so: 20 | 21 | 3 22 | 23 | Will simply push 3 onto the stack, while 24 | 25 | 3 5 26 | 27 | Will first push 3 then 5 onto the stack. The 28 | typical operators will pop a couple of numbers 29 | off of the stack, operate on them and then 30 | push the result back on, so that: 31 | 32 | 3 5 + 33 | 34 | Will leave you with 8 on the stack. 35 | 36 | Cloforth commands are called 'words'. So there 37 | is an 'nl' word which just prints a newline. 38 | So do this: 39 | 40 | nl 41 | 42 | And you will see a blank line printed. Another 43 | word is the plain old dot: . Yes, it's not much 44 | of a word, but that is the jargon. The . word 45 | justs prints whatever is on the top of the stack 46 | (popping it off in the process) Thus if you 47 | do this: 48 | 49 | 3 . nl 50 | 51 | You will see a three followed by a newline printed. 52 | 53 | Other handy words are dup, which pushes a copy of 54 | whatever is on top of the stack back onto the 55 | stack, so that 56 | 57 | 3 dup . nl 58 | 59 | Will print the three and also leave it on top of 60 | the stack. 61 | 62 | You can define your own words with : 63 | Colon takes a name and a list of words 64 | enclosed in [ ] and defines a new word. 65 | Thus this: 66 | 67 | : plus1 [ 1 + ] 68 | 69 | Defines a new word called 'plus1' that adds 70 | one to whatever is on the top of the stack. 71 | -------------------------------------------------------------------------------- /examples/a.c4: -------------------------------------------------------------------------------- 1 | 10 10 2 | -------------------------------------------------------------------------------- /examples/b.c4: -------------------------------------------------------------------------------- 1 | .stack 2 | -------------------------------------------------------------------------------- /examples/bar.c4: -------------------------------------------------------------------------------- 1 | 2 | : hello [ 'hello' . ] 3 | 4 | hello 5 | 6 | : bar [ true if [ 'yes!!' . ] 'after' . ] 7 | 8 | 100 101 102 bar 9 | -------------------------------------------------------------------------------- /examples/baz.c4: -------------------------------------------------------------------------------- 1 | 2 | : test [ ifelse [ 'yes' . ] [ 'no' . ] ] 3 | 4 | true test 5 | 6 | false test 7 | -------------------------------------------------------------------------------- /examples/dowhile.c4: -------------------------------------------------------------------------------- 1 | 2 | 4 3 | while [ 1 - dup dup .nl 0 >= ] [ hello ] 4 | .stack 5 | 6 | -------------------------------------------------------------------------------- /examples/foo.c4: -------------------------------------------------------------------------------- 1 | : print2 [ . . ] 2 | 3 | 100 101 print2 nl 4 | 5 | : print-it . 6 | 7 | 10 10 10 999 + + print-it nl 8 | 9 | -------------------------------------------------------------------------------- /examples/hello.c4: -------------------------------------------------------------------------------- 1 | 'hello' . 2 | -------------------------------------------------------------------------------- /examples/if1.c4: -------------------------------------------------------------------------------- 1 | 'hello' . 2 | 3 | : bar [ true if [ 'its true' .nl ] 'done' .nl ] 4 | 5 | bar 6 | 7 | -------------------------------------------------------------------------------- /examples/jump.c4: -------------------------------------------------------------------------------- 1 | 2 | 1 2 10 jump 3 4 5 6 7 .stack 3 | -------------------------------------------------------------------------------- /examples/noop.c4: -------------------------------------------------------------------------------- 1 | ; do nothing 2 | -------------------------------------------------------------------------------- /examples/pushes.c4: -------------------------------------------------------------------------------- 1 | 1 2 3 4 2 | -------------------------------------------------------------------------------- /examples/simple.c4: -------------------------------------------------------------------------------- 1 | 1000000 . nl 2 | 3 | 'hello out there' . nl nl 4 | -------------------------------------------------------------------------------- /init.c4: -------------------------------------------------------------------------------- 1 | 2 | ; Create the : word which is a shortcut for 3 | ; defining other word. Use : like this 4 | ; : [ <> ] 5 | compile [ gettok compile rot set! ] ':' set! 6 | 7 | : true [ 1 1 = ] 8 | 9 | : false [ 1 0 = ] 10 | 11 | ; Print the top of the stack and pop it off 12 | : . [ print drop ] 13 | 14 | ; Print a newline 15 | : nl [ 10 char . ] 16 | 17 | ; Print the top of the stack followed by a newline 18 | : .nl [ . nl ] 19 | 20 | : space [ ' ' . ] 21 | 22 | : .top [ print nl ] 23 | 24 | : .lookup [ lookup . nl ] 25 | 26 | : max [ dup lrot dup lrot rot > ifelse [ drop ] [ rot drop ] ] 27 | 28 | : min [ dup lrot dup lrot rot < ifelse [ drop ] [ rot drop ] ] 29 | 30 | : 0< [ 0 < ] 31 | 32 | : 0= [ 0 = ] 33 | 34 | : >0 [ 0 > ] 35 | 36 | : 1+ [ 1 + ] 37 | 38 | : 1- [ 1 - ] 39 | 40 | : 2* [ 2 * ] 41 | 42 | 43 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject cloforth "1.0.0-SNAPSHOT" 2 | :description "FIXME: write description" 3 | :main cloforth.repl 4 | :dependencies [[org.clojure/clojure "1.3.0"]]) 5 | -------------------------------------------------------------------------------- /src/cloforth/compiler.clj: -------------------------------------------------------------------------------- 1 | (ns cloforth.compiler 2 | [:require [cloforth.environment :as env] 3 | [cloforth.primitives :as prims] 4 | [cloforth.tokenizer :as tok]]) 5 | 6 | (defn pr-program [program] 7 | (if (coll? program) 8 | (doseq [p program] (pr-program p)) 9 | (if (:description (meta program)) 10 | (print (:description (meta program))) 11 | (println (str program " "))))) 12 | 13 | (declare compile-statement) 14 | 15 | 16 | (defn compile-word-reference [name value] 17 | (with-meta 18 | (fn [env] 19 | (let [new-env (env/push-frame env (env/make-frame value))] 20 | #_(println "new env:" (dissoc new-env :dictionary)) 21 | new-env)) 22 | {:description (str "Call to [" name "]")})) 23 | 24 | (defn compile-branch [n] 25 | (with-meta 26 | (partial env/branch n) 27 | {:description (str "Branch " n)})) 28 | 29 | (defn compile-jump [n] 30 | (with-meta 31 | (partial env/jump n) 32 | {:description (str "Jump " n)})) 33 | 34 | ;; experimental 35 | (defn compile-while [r dictionary] 36 | (let [condition (compile-statement r dictionary) 37 | body (compile-statement r dictionary) 38 | len-cond (count condition) 39 | len-body (count body)] 40 | (vec (concat 41 | condition 42 | [prims/primitive-not (compile-branch (+ len-body 1))] 43 | body 44 | [(compile-jump (- 0 len-body 3 len-cond))])))) 45 | 46 | (defn- compile-if [r dictionary] 47 | (let [body (compile-statement r dictionary)] 48 | (vec (concat [prims/primitive-not (partial env/branch (count body))] body)))) 49 | 50 | (defn- compile-ifelse [r dictionary] 51 | (let [true-part (compile-statement r dictionary) 52 | false-part (compile-statement r dictionary)] 53 | (vec 54 | (concat 55 | [prims/primitive-not (partial env/branch (inc (count true-part)))] 56 | true-part 57 | [(fn [env] (env/jump env (count false-part)))] 58 | false-part)))) 59 | 60 | (defn compile-push [value] 61 | (with-meta 62 | (fn [env] (env/stack-push env value)) 63 | {:description (str "Push " value)})) 64 | 65 | (defn- compile-word 66 | "Compile the given word, returning either a function or a vector of functions" 67 | [r dictionary text] 68 | (cond 69 | (= "if" text) (compile-if r dictionary) 70 | (= "ifelse" text) (compile-ifelse r dictionary) 71 | (= "while" text) (compile-while r dictionary) 72 | (dictionary text) (compile-word-reference text (dictionary text)) 73 | (tok/to-int text) (compile-push (tok/to-int text)) 74 | :else (println "Don't know what to do with" text))) 75 | 76 | (defn- compile-token 77 | "Compile the given token, returning a vector of functions" 78 | [r dictionary token] 79 | (let [type (:type token) 80 | text (:text token)] 81 | (case type 82 | :string [(compile-push text)] 83 | :word (compile-word r dictionary text) 84 | :eof nil 85 | (println "don't know what to do with" text)))) 86 | 87 | (defn- compile-until 88 | "Keep compiling words until f-done? is true, returns modified result vector" 89 | [r dictionary f-done? result] 90 | (let [token (tok/get-token r)] 91 | (if (f-done? token) 92 | result 93 | (if-let [compiled (compile-token r dictionary token)] 94 | (recur 95 | r 96 | dictionary 97 | f-done? 98 | (if (coll? compiled) (vec (concat result compiled)) (vec (conj result compiled)))) 99 | result)))) 100 | 101 | (defn- compile-compound 102 | "Compile a compound word (i.e. [ w w w ]), returns vector" 103 | [r dictionary] 104 | (compile-until 105 | r 106 | dictionary 107 | (fn [token] (or (= (:type token) :eof) (= (:type token) :r-bracket))) 108 | [])) 109 | 110 | (defn compile-statement [r dictionary] 111 | #_(println "compile statement: " r) 112 | (let [token (tok/get-token r) 113 | text (:text token)] 114 | (case (:type token) 115 | :eof [] 116 | :string (fn [env] (env/stack-push env text)) 117 | :l-bracket (compile-compound r dictionary) 118 | (compile-token r dictionary token)))) 119 | 120 | (defn primitive-compile [env] 121 | (let [dictionary (:dictionary env) 122 | r (:in env) 123 | body (compile-statement r dictionary)] 124 | (env/stack-push env body))) 125 | 126 | (defn primitive-print-compiled [env] 127 | (let [p (env/stack-peek env)] 128 | (pr-program p) 129 | (env/stack-peek env))) 130 | 131 | (defn primitive-gettok [{r :in :as env}] 132 | (let [token (tok/get-token r)] 133 | (env/stack-push env (:text token)))) -------------------------------------------------------------------------------- /src/cloforth/dictionary.clj: -------------------------------------------------------------------------------- 1 | (ns cloforth.dictionary 2 | [:require [clojure.string :as s]]) 3 | 4 | (defn- to-prim-name [sym] 5 | (s/replace-first (str sym) "primitive-" "" )) 6 | 7 | (defn name-for [value dict] 8 | (some #(if (= (val %) value) (key %)) dict)) 9 | 10 | (defn- to-dictionary [h] 11 | (apply 12 | hash-map 13 | (flatten 14 | (map 15 | (fn [[key value]] [(to-prim-name key) @value]) 16 | h)))) 17 | 18 | (defn create-dictionary [ns] 19 | (to-dictionary (ns-publics ns))) 20 | -------------------------------------------------------------------------------- /src/cloforth/environment.clj: -------------------------------------------------------------------------------- 1 | (ns cloforth.environment 2 | [:require [clojure.pprint :as pp]]) 3 | 4 | ;; Debugging 5 | 6 | (defn prn-env [e] (println (dissoc e :dictionary))) 7 | 8 | 9 | ;; Dictionary functions 10 | 11 | (defn set! [name value env] 12 | (update-in env [:dictionary] assoc name value)) 13 | 14 | ;; Data stack functions 15 | 16 | (defn stack-push [env value] 17 | (update-in env [:stack] conj value)) 18 | 19 | (defn stack-pop-1 [env] 20 | (update-in env [:stack] pop)) 21 | 22 | (defn stack-pop 23 | ([env] 24 | (stack-pop-1 env)) 25 | ([n env] 26 | (last (take (inc n) (iterate stack-pop-1 env))))) 27 | 28 | (defn stack-peek [env] 29 | (peek (:stack env))) 30 | 31 | (defn stack-nth [env n] 32 | (nth (:stack env) n)) 33 | 34 | ;; Execute frame functions 35 | 36 | (defn make-frame [program & [ip]] 37 | (let [ip (if ip ip 0)] 38 | {:program program :ip ip})) 39 | 40 | (defn push-frame [env frame] 41 | (update-in env [:frame-stack] conj frame)) 42 | 43 | (defn x-pop-frame [env] 44 | (update-in env [:frame-stack] pop)) 45 | 46 | (defn pop-frame [env] 47 | (let [result (x-pop-frame env)] 48 | (when (nil? result) 49 | (println "******** nil pop frame:" env)) 50 | result)) 51 | 52 | (defn peek-frame [env] 53 | (peek (:frame-stack env))) 54 | 55 | (defn current-ip [env] 56 | (:ip (peek-frame env))) 57 | 58 | (defn current-program [env] 59 | (:program (peek-frame env))) 60 | 61 | (defn inc-ip [env] 62 | ;; (println "inc ip: env:" env) 63 | (let [top (peek-frame env)] 64 | ;;(println "top:" top) 65 | (push-frame (pop-frame env) (update-in top [:ip] inc)))) 66 | 67 | (defn set-ip [env new-ip] 68 | (let [top (peek-frame env)] 69 | (push-frame (pop-frame env) (assoc-in top [:ip] new-ip)))) 70 | 71 | ;; Jump and branch functions 72 | 73 | (defn jump [env n] 74 | (let [ip (current-ip env)] 75 | (set-ip env (+ ip n)))) 76 | 77 | (defn recur [env] 78 | (set-ip env 0)) 79 | 80 | (defn branch [n env] 81 | (let [top (stack-peek env) 82 | env (stack-pop env)] 83 | (if top 84 | (jump env n) 85 | env))) 86 | 87 | ;; {:in :stack [1 2 3] :dictionary { } :frame-stack [{:program :ip}]} 88 | 89 | (defn make-env [] 90 | {:in *in* :dictionary {} :stack '() :frame-stack []}) 91 | 92 | -------------------------------------------------------------------------------- /src/cloforth/execute.clj: -------------------------------------------------------------------------------- 1 | (ns cloforth.execute 2 | [:require 3 | [cloforth.environment :as env]]) 4 | 5 | (defn execute-primitive [program ip env] 6 | (if-not (map? env) 7 | (throw (Exception. "not a map"))) 8 | (if (> ip 0) 9 | (env/pop-frame env) 10 | (let [new-env (program (env/inc-ip env))] 11 | new-env))) 12 | 13 | (defn execute-one-program-instruction [program ip env] 14 | (if (>= ip (count program)) 15 | (env/pop-frame env) 16 | (let [f (program ip)] 17 | (f (env/inc-ip env))))) 18 | 19 | (defn execute-one 20 | "Execute the next program step, return the new env. 21 | Pops the return stack if there is nothing left to do." 22 | [env] 23 | (let [frame (env/peek-frame env) 24 | ip (:ip frame) 25 | program (:program frame)] 26 | (when frame 27 | (if (fn? program) 28 | (execute-primitive program ip env) 29 | (execute-one-program-instruction program ip env))))) 30 | 31 | (defn execute [env] 32 | (when (env/peek-frame env) 33 | (let [result (execute-one env)] 34 | #_(println "execute: result" (dissoc result :dictionary)) 35 | #_(flush) 36 | (when result 37 | (lazy-seq (cons env (execute result))))))) 38 | 39 | (defn execute-program [env program] 40 | (cons env (execute (env/push-frame env (env/make-frame program))))) 41 | 42 | -------------------------------------------------------------------------------- /src/cloforth/primitives.clj: -------------------------------------------------------------------------------- 1 | (ns cloforth.primitives 2 | [:require [clojure.pprint :as pp] 3 | [cloforth.environment :as env]]) 4 | 5 | (defn dump [env] 6 | (println "======") 7 | (println "stack:" (:stack env)) 8 | (println "frame stack:" (:frame-stack env)) 9 | (println "dict keys:" (sort (keys (:dictionary env)))) 10 | (println "======") 11 | env) 12 | 13 | (defn- binary-op [env f] 14 | (let [b (env/stack-nth env 0) 15 | a (env/stack-nth env 1)] 16 | (env/stack-push (env/stack-pop 2 env) (f a b) ))) 17 | 18 | (defn- unary-op [env f] 19 | (let [x (first (:stack env))] 20 | (env/stack-push (env/stack-pop env) (f x)))) 21 | 22 | (defn primitive-print [env] (print (env/stack-peek env)) env) 23 | 24 | (defn primitive-char [env] (unary-op env char)) 25 | 26 | (defn primitive-not [env] (unary-op env not)) 27 | 28 | (defn primitive-+ [env] (binary-op env +)) 29 | 30 | (defn primitive-- [env] (binary-op env -)) 31 | 32 | (defn primitive-* [env] (binary-op env *)) 33 | 34 | (defn primitive-div [env] (binary-op env /)) 35 | 36 | (defn primitive-> [env] (binary-op env >)) 37 | 38 | (defn primitive-<= [env] (binary-op env <=)) 39 | 40 | (defn primitive->= [env] (binary-op env >=)) 41 | 42 | (defn primitive-< [env] (binary-op env <)) 43 | 44 | (defn primitive-= [env] (binary-op env =)) 45 | 46 | (defn primitive-mod [env] (binary-op mod =)) 47 | 48 | (defn primitive-drop [env] (env/stack-pop env)) 49 | 50 | (defn primitive-dup [env] (env/stack-push env (env/stack-peek env))) 51 | 52 | (defn push-one [env] (env/stack-push env 1)) 53 | 54 | (defn push-two [env] (env/stack-push env 2)) 55 | 56 | (defn rot [env] 57 | (let [a (env/stack-nth env 0) 58 | b (env/stack-nth env 1) 59 | env (env/stack-pop 2 env)] 60 | (-> env 61 | (env/stack-push a) 62 | (env/stack-push b)))) 63 | 64 | (defn lrot [env] 65 | (let [c (env/stack-nth env 0) 66 | b (env/stack-nth env 1) 67 | a (env/stack-nth env 2) 68 | env (env/stack-pop 3 env)] 69 | (-> env 70 | (env/stack-push b) 71 | (env/stack-push c) 72 | (env/stack-push a)))) 73 | 74 | (defn primitive-set! [env] 75 | (let [name (env/stack-nth env 0) 76 | value (env/stack-nth env 1) 77 | env (env/stack-pop 2 env)] 78 | #_(println "set: name:" name "value:" value) 79 | (update-in env [:dictionary] assoc name value))) 80 | 81 | (defn lookup [env] 82 | (unary-op env (fn [name] (get (:dictionary env) name)))) 83 | 84 | (defn ip [env] (env/stack-push (:ip env) env)) 85 | 86 | (defn goto [env] 87 | (let [address (env/stack-peek env)] 88 | (env/stack-pop (assoc env :ip address)))) 89 | 90 | (defn jump [env] 91 | (let [delta (env/stack-peek env)] 92 | (println "in jump, delta: " delta) 93 | (let [new-env (env/jump (env/stack-pop env) delta)] 94 | (println "new env:") 95 | (dump new-env) 96 | new-env))) 97 | 98 | #_(defn recur [env] (assoc env :ip -1)) 99 | 100 | (defn clear [env] (assoc env :stack [])) 101 | 102 | (defn quit [env] (assoc env :quit true)) 103 | 104 | (defn primitive-.dict [env] (pp/pprint (:dictionary env)) env) 105 | 106 | (defn primitive-.def [env] 107 | (let [word (env/stack-nth env 0)] 108 | (pp/pprint (get (:dictionary env) word)) 109 | (env/stack-pop env))) 110 | 111 | (defn primitive-.stack [env] (pp/pprint (:stack env)) env) 112 | 113 | (defn hello [env] (println "HELLO") env) 114 | -------------------------------------------------------------------------------- /src/cloforth/repl.clj: -------------------------------------------------------------------------------- 1 | (ns cloforth.repl 2 | [:require [cloforth.dictionary :as dict] 3 | [cloforth.primitives] 4 | [cloforth.environment :as env] 5 | [cloforth.compiler :as comp] 6 | [cloforth.execute :as exec] 7 | [clojure.pprint :as pp]]) 8 | 9 | (defn repl [env] 10 | #_(println "REPL" (dissoc env :dictionary)) 11 | #_(flush) 12 | (let [dictionary (:dictionary env)] 13 | (if (:quit env) 14 | env 15 | (let [r (:in env) 16 | compiled (comp/compile-statement r dictionary)] 17 | (if (and (coll? compiled) (empty? compiled)) 18 | env 19 | (let [result (exec/execute-program env compiled) 20 | new-env (last result)] 21 | #_(pp/pprint (map :frame-stack result)) 22 | (recur new-env))))))) 23 | 24 | (defn run-reader [{old_in :in :as env} r] 25 | (assoc (repl (assoc env :in r)) :in old_in)) 26 | 27 | (defn run-string [env s] 28 | (let [r (java.io.StringReader. s)] 29 | (run-reader env r))) 30 | 31 | (defn run-file [env file] 32 | (let [r (java.io.FileReader. file)] 33 | (run-reader env r))) 34 | 35 | (defn clean-env [] 36 | (let [ dict 37 | (merge 38 | (dict/create-dictionary 'cloforth.primitives) 39 | (dict/create-dictionary 'cloforth.compiler))] 40 | (run-file 41 | {:in *in* :dictionary dict :stack '() :frame-stack []} 42 | "init.c4"))) 43 | 44 | (defn main [ & files] 45 | (let [env (clean-env)] 46 | (if (or (nil? files) (empty? files)) 47 | (repl env) 48 | (reduce run-file env files)))) 49 | 50 | (defn -main [ & files] 51 | (apply main files) 52 | nil) 53 | -------------------------------------------------------------------------------- /src/cloforth/tokenizer.clj: -------------------------------------------------------------------------------- 1 | (ns cloforth.tokenizer 2 | (:import (clojure.lang LineNumberingPushbackReader)) 3 | (:use [clojure.java.io :as jio])) 4 | 5 | (defn to-int [string] 6 | (try 7 | (Long/parseLong string) 8 | (catch Exception e nil))) 9 | 10 | (defn- to-char [i] 11 | ;;(println "to char:" i) 12 | (if (< i 0) i (char i))) 13 | 14 | (defn- get-ch [r] 15 | ;;(println "get ch: " r) 16 | ;;(flush) 17 | (when (and (instance? LineNumberingPushbackReader r) (.atLineStart r)) 18 | (print "c4>> ") 19 | (flush)) 20 | (to-char (.read r))) 21 | 22 | (defn- ws? [ch] 23 | (or (= ch \space) (= ch \tab) (= ch \newline))) 24 | 25 | (defn- eof? [ch] 26 | (and (number? ch) (< ch 0))) 27 | 28 | (defn- handle-start [r ch token] 29 | (cond 30 | (eof? ch) {:state :complete :type :eof :text nil} 31 | (ws? ch) (recur r (get-ch r) token) 32 | (= ch \;) {:state :comment } 33 | (= ch \') {:state :string :type :string :text ""} 34 | (= ch \[) {:state :complete :type :l-bracket :text "["} 35 | (= ch \]) {:state :complete :type :r-bracket :text "]"} 36 | :else (assoc token :state :word :type :word :text (str ch)))) 37 | 38 | (defn- handle-string [ch token] 39 | (cond 40 | (eof? ch) (assoc token :state :complete :type :premature-eof) 41 | (= ch \') (assoc token :state :complete) 42 | :else (assoc token :text (str (:text token) ch)))) 43 | 44 | (defn- handle-word [ch token] 45 | (cond 46 | (eof? ch) (assoc token :state :complete) 47 | (ws? ch) (assoc token :state :complete) 48 | :else (assoc token :text (str (:text token) ch)))) 49 | 50 | (defn- handle-comment [ch token] 51 | (if (= ch \newline) 52 | (assoc token :state :start) 53 | token)) 54 | 55 | (defn- read-token [r token] 56 | ;; (println "read token: " r) 57 | (case (:state token) 58 | :complete token 59 | :comment (recur r (handle-comment (get-ch r) token)) 60 | :start (recur r (handle-start r (get-ch r) token)) 61 | :string (recur r (handle-string (get-ch r) token)) 62 | :word (recur r (handle-word (get-ch r) token)) 63 | (assoc token :state :error))) 64 | 65 | (defn get-token [r] 66 | (select-keys (read-token r {:state :start}) [:type :text] )) -------------------------------------------------------------------------------- /test/cloforth/test/compiler.clj: -------------------------------------------------------------------------------- 1 | (ns cloforth.test.compiler 2 | (:use [cloforth.compiler :as c]) 3 | (:use [cloforth.execute :as x]) 4 | (:use [clojure.test]) 5 | (:require [cloforth.environment :as env])) 6 | 7 | 8 | (def starting-env (assoc (env/make-env) :counter 0)) 9 | 10 | (defn inc-counter [env] (update-in env [:counter] inc)) 11 | 12 | (defn dec-counter [env] (update-in env [:counter] dec)) 13 | 14 | (deftest execute-one-function 15 | (let [env (last (x/execute-program starting-env inc-counter))] 16 | (is (map? env)) 17 | (is (= 1 (:counter env))))) 18 | 19 | (deftest execute-one-single-element-vector 20 | (let [env (last (x/execute-program starting-env [inc-counter]))] 21 | (is (map? env)) 22 | (is (= 1 (:counter env))))) 23 | 24 | (deftest execute-one-two-element-vector 25 | (let [env (last (x/execute-program starting-env [inc-counter inc-counter]))] 26 | (is (map? env)) 27 | (is (= 2 (:counter env))))) 28 | 29 | 30 | 31 | -------------------------------------------------------------------------------- /test/cloforth/test/execute.clj: -------------------------------------------------------------------------------- 1 | (ns cloforth.test.execute 2 | (:use [cloforth.execute :as x]) 3 | (:use [cloforth.repl :as repl]) 4 | (:use [clojure.test])) 5 | 6 | (defn- x 7 | "Execute a string as a cloforth program" 8 | [s] 9 | (repl/run-string (repl/clean-env) s)) 10 | 11 | (defn- stack-from [s] 12 | (:stack (x s))) 13 | 14 | (defn- output-from [s] 15 | (with-out-str (x s))) 16 | 17 | (deftest nothing-from-nothing 18 | (is (= (stack-from "") []))) 19 | 20 | (deftest simple_push 21 | (is (= (stack-from "100") [100])) 22 | (is (= (stack-from "200 100") [100 200]))) 23 | 24 | (deftest simple_drop 25 | (is (= (stack-from "100 drop") []))) 26 | 27 | (deftest dup 28 | (is (= (stack-from "100 dup") [100 100]))) 29 | 30 | (deftest add 31 | (is (= (stack-from "100 100 +") [200]))) 32 | 33 | (deftest sub 34 | (is (= (stack-from "200 100 -") [100]))) 35 | 36 | (deftest mult 37 | (is (= (stack-from "5 4 *") [20]))) 38 | 39 | (deftest div 40 | (is (= (stack-from "9 3 -") [6]))) 41 | 42 | (deftest gt 43 | (is (= (stack-from "9 3 >") [true])) 44 | (is (= (stack-from "3 9 >") [false]))) 45 | 46 | (deftest lt 47 | (is (= (stack-from "9 3 <") [false])) 48 | (is (= (stack-from "3 9 <") [true]))) 49 | 50 | (deftest is-equals 51 | (is (= (stack-from "9 3 =") [false])) 52 | (is (= (stack-from "3 9 =") [false])) 53 | (is (= (stack-from "1 1 =") [true])) 54 | (is (= (stack-from "2 2 =") [true])) 55 | (is (= (stack-from "3 3 =") [true]))) 56 | 57 | (deftest string-equals 58 | (is (= (stack-from "'xx' 'xx' =") [true]))) 59 | 60 | (deftest simple-not 61 | (is (= (stack-from "true not") [false])) 62 | (is (= (stack-from "false not") [true]))) 63 | 64 | (deftest add-one 65 | (is (= (stack-from "1 1+") [2])) 66 | (is (= (stack-from "2 1+") [3]))) 67 | 68 | (deftest sub-one 69 | (is (= (stack-from "1 1-") [0])) 70 | (is (= (stack-from "2 1-") [1]))) 71 | 72 | (deftest dot 73 | (is (= (output-from "99 .") "99"))) 74 | 75 | (deftest nl 76 | (is (= (output-from "nl") "\n"))) 77 | 78 | (deftest rot 79 | (is (= (stack-from "1 2 3 rot") [2 3 1]))) 80 | 81 | (deftest lrot 82 | (is (= (stack-from "1 2 3 lrot") [1 3 2]))) 83 | 84 | (deftest more-complex-expression 85 | (is (= (stack-from "2 2 + 6 *") [24]))) 86 | 87 | (deftest colon-define 88 | (is (= (stack-from ": ++ [ + + ] 2 3 4 ++") [9]))) 89 | 90 | (deftest nested-calls 91 | (is (= (stack-from ": a [ 10 ] : b [ dup ] a b") [10 10]))) 92 | 93 | (def one-if-true ": w [ if [ 1 ] ]") 94 | 95 | (deftest simple-if 96 | (is (= (stack-from (str one-if-true " true w")) [1])) 97 | (is (= (stack-from (str one-if-true " false w")) [])) 98 | (is (= (stack-from (str one-if-true " false w 99")) [99]))) 99 | 100 | (def one-or-two ": w [ ifelse [ 1 ] [ 2 ] ]") 101 | 102 | (deftest ifelse 103 | (is (= (stack-from (str one-or-two " true w")) [1])) 104 | (is (= (stack-from (str one-or-two " false w")) [2])) 105 | (is (= (stack-from (str one-or-two " false w 99" )) [99 2]))) 106 | 107 | (deftest push-string 108 | (is (= (stack-from "'foo'") ["foo"]))) 109 | --------------------------------------------------------------------------------