bare-bones metacircular evaluator in clojurescript

evaluator.cljs

;; Develop your clojurescript program here
(ns metacirc.evaluator (:require [cljs.reader :as reader]))

;; TODO:
;; globals: "let", "do"
;; javascript interop
;; var args or at least get more than 4 for list
;; {} [] #{} '()


(def create-fn )
(def evaluate-form )
(def evaluate-forms )
(def evaluate-args )
(def apply-user-fn )
(def resolve-token )

(defn jserror [m]
 ;; (js/Error m))
  nil)

;; the set of special forms and simple macros we hard-code
(defn special-form? [f]
  (or
    (not (= nil (#{ 'def 'fn 'defn 'if '. '.- } f)))
    (and (symbol? f) 
      (or (= "js/" (subs (str f) 0 3 ))(= "." (subs (str f) 0 1 ))(= ".-" (subs (str f) 0 2 ))))))
;;  #{ "if" "cond" "def" "defn" "fn" "do" })

;; primitive core functions that warm-start the global environment

(def fcnmap-debug
  {
   '*GLOBAL* true
   '+ +
})

(defn remove-first-chars [sy rem] (let [s (str sy)] (if (= rem (subs s 0 (count rem) )) 
                      (subs s (count rem) (count s))
                      sy)))

(defn atosh [a] (if (empty? a)
                 ""
                 (if (= (count a) 1)
                   (first a)
                   (+ (first a) ", " (atosh (rest a)) ))))

(defn atos [a env]
   (atosh (evaluate-args a env)))

(def fcnmap
  {
   '*GLOBAL* true
   "js" (fn [ o m & a] (js/eval  (+ o "." m "(" (atos a) ");" )))
   '+ +
   '- -
   '* *
   '/ /
   'odd? odd?
   'even? even?
   'map map
   'reduce reduce
   'filter filter
   'list list
   'first first
   'rest rest
   'nth nth
   'get get
   'key key
   'val val
   'true true
   'false false
   '= =
   'not= not=
   '== =
   '< <
   '> >
   '<= <=
   '>= >=
   'str str
   'int int
   'float float
   'inc inc
   'count count
   })

(def global-env fcnmap )

(def environment (atom (list {'*GLOBAL* true} global-env)))

(defn global-env [] (deref environment ))

(defn add-to-current-env [ k v ]
  (swap! environment (fn [a k1 v1] (cons (assoc (first a) k1 v1) (rest a))) k v ))

(defn lookup-lib-function-map [lk]
  (lk fcnmap))

(defn apply-special [sf a env]
  (cond
    (= sf 'fn)
        (create-fn a env)
    (= sf 'defn)
        (add-to-current-env (first a) (create-fn a env))
    (= sf 'if)
      (if (evaluate-form (first a) env)
        (evaluate-form (second a) env)
        (evaluate-form (nth a 2) env))
    (= ".-" (subs (str sf) 0 2 ))
      (js/eval (+ (remove-first-chars (first a) "js/") "." (remove-first-chars sf ".-") ))
    (= "." (subs (str sf) 0 1 ))
      (js/eval (+ (remove-first-chars (first a) "js/") "." (remove-first-chars sf ".") "(" (atos (rest a) env) ");" ))
    (= "js/" (subs (str sf) 0 3 ))
      (js/eval (+ (remove-first-chars sf "js/" ) "(" (atos a env) ");" ))
    (= sf 'def)
      (add-to-current-env (first a) (first (evaluate-args (rest a) env )))))

(defn extract-params [a found-open]
  (cond
   (empty? a)
     '()
   (vector? (first a) )
     (seq (first a) )
   (= found-open false)
     (extract-params (rest a) false)
   :else
     '()))

(defn exclude-global [env]
  (let [xenv (filter #(= (% '*GLOBAL*) nil) env)]
    (if (empty? xenv)
      {}
      xenv)))

(defn create-fn [a env]
  (let [ paraml (extract-params a false)
         body (last a)
         f (cons (fn [call-env] (evaluate-form body call-env)) (cons (exclude-global env) paraml))]
    (cond
      (= (count paraml) 0)
         (fn [] (apply-user-fn f '() (global-env)))
      (= (count paraml) 1)
         (fn [p0] (apply-user-fn f (list p0) (global-env)))
      (= (count paraml) 2)
         (fn [p0 p1] (apply-user-fn f (list p0 p1) (global-env)))
      (= (count paraml) 3)
         (fn [p0 p1 p2] (apply-user-fn f (list p0 p1 p2) (global-env)))
      (= (count paraml) 4)
         (fn [p0 p1 p2 p3] (apply-user-fn f (list p0 p1 p2 p3) (global-env)))
      :else
        (throw (jserror, "airity max of 4 only supported")))))


(defn apply-user-fn [fp a env]
  (let [f (first fp)
        create-env (second fp)
        paraml (rest (rest fp))
        frame (reduce conj {} (map (fn [k v] (assoc {} k v)) paraml a))]
    (f (cons frame (concat create-env env)))))

(defn apply-with-args [f a]
  (apply f a)) 

(defn evaluate-forms [tokenl env]
  (cond
    (empty? tokenl)
      '()    
    :else
        (cons (evaluate-form (first tokenl) env ) (evaluate-forms (rest tokenl) env))))

(defn evaluate-args [tokenl env]
   (evaluate-forms tokenl env ))

(defn evaluate-form [tokenl env]
  (cond
    (symbol? tokenl)
      (resolve-token tokenl env)
    (or (string? tokenl) (number? tokenl) ) 
      tokenl
    (list? tokenl)
      (let [fpos (first tokenl)
            args (rest tokenl)]
        (cond
          (empty? tokenl)
             '()
          (special-form? fpos)
            (apply-special fpos args env)
          :else ;; a form where first item is a function
            (apply-with-args (evaluate-form fpos env) (evaluate-args args env) )))
    (or (vector? tokenl) (map? tokenl) (set? tokenl))
      tokenl 
    :else
      nil))
         

(defn lookup-env [k env]
  (cond
    (empty? env)
    (do
      ;;(println "lookup failed " k )
      nil)
    ((first env) k)
      ((first env) k)
    :else
      (lookup-env k (rest env))))

(defn resolve-token [toke env]
  (let [ lookup (lookup-env toke env)]
    (if (nil? lookup )
      toke
      lookup)))


(defn evaluate-all [tokenl]
  (do
    ;;(println "main> " tokenl )
  (cond
    (= (count tokenl) 1)
      (evaluate-form (first tokenl) (deref environment))
    :else
      (do
        (evaluate-form (first tokenl) (deref environment))
        (evaluate-all (rest tokenl) )))))


(defn read-sl [exp-string] 
  (reader/read-string (str "(" exp-string ")")))

;;(defn ^:export evaluate [exp-string]
(defn evaluate [exp-string]
  (let [tokenl (read-sl exp-string)]
    (evaluate-all tokenl )))

(defn tests []
  (do
;;    (println (evaluate "(+ 3 3)"))
;;    (println (evaluate "5"))
;;    (println (evaluate "(defn fact [x] (if (= x 0) (+ 0 1) (* x (fact (- x 1))))) (fact 6)"))
;;    (println (evaluate "(defn noarg [] (+ 5 5))(noarg)"))
;;    (println (evaluate "(defn curry [x] (fn [y] (+ x y)))((curry 10) 12)"))
;;    (println (evaluate "(def x 10)(defn foo [y] (fn [] (+ x y)))(def ff (foo 10))(def x 100)(ff)"))
;;    (println (evaluate "(map (fn [x] (* x x)) (list 1 2 3 4))"))
    ))

;;(evaluate "(js \"document\" \"getElementById\" \"\"game\"\")")
;;(evaluate "(. document getElementById \"game\")")
;;(evaluate "(. document width)")