test.toc

toccata

(def true)
(def false)
(def abort)
(def get-type)
(def type=)
(def subs)
(def number-str)
(def number=)
(def number-less-than)
(def add-numbers)
(def subtract-numbers)
(def mult-numbers)
(def empty-list)
(def cons)
(def list-count)
(def car)
(def cdr)
(def fn-name)
(def new-list)
(def snoc)
(def char)
(def str-count)
(def str=)
(def symkey=)
(def str-malloc)
(def str-append)
(def pr*)
(def pr-err*)
(def slurp)
(def fn-apply)
(def print-err)

(defprotocol Monad
  (flat-map [mval func]
    (print-err "*** 'flat-map' not implemented")
    (abort)))

(defprotocol Comonad
  (extract [wv])
  (extend [wv f]))

(def comprehend)

(defprotocol Applicative
  (wrap [x v]
    (print-err "*** 'wrap' not implemented"))
  (apply* [fv args]
    (cond
     (number= 0 (list-count args)) (flat-map fv (fn [f] (wrap fv (f))))
     (flat-map fv (fn [f] (comprehend f args))))))

(defn apply [fv & args]
  (apply* fv args))

(defn apply-to [f & args]
  (cond
   (number= 0 (list-count args)) (f)
   (apply* (wrap (car args) f) args)))

(defn list [& l]
  l)

(defprotocol Functor
  (map [v f]
    (apply* (wrap v f) (list v))))

(defprotocol Named
  (name [value]
    (print-err "'name' not implemented for type " (get-type value))
    (abort)))

(defprotocol Stringable
  (string-list [value]
    (print-err "*** 'string-list' not implemented for type" (get-type value))
    (abort)))

(defprotocol Serializable
  (serialize [value]
    (print-err "*** 'serialize' not implemented for type" (get-type value))
    (abort)))

(defn list-empty? [coll]
  (number= 0 (list-count coll)))

(defn interpose [coll sep]
  (cond
   (list-empty? coll) coll
   (cons (car coll)
         (flat-map (cdr coll)
                   (fn [x]
                     (list sep x))))))

(defn prn [& vs]
  (map (interpose (flat-map vs serialize) " ")
        pr*)
  (pr* "\\n"))

(defn print [& vs]
  (map (flat-map (interpose vs " ") string-list)
        pr*))

(defn println [& vs]
  (map (flat-map (interpose vs " ") string-list) pr*)
  (pr* "\\n"))

(defn print-err [& vs]
  (pr-err* "\\n*** ")
  (map (flat-map (interpose vs " ") string-list) pr-err*)
  (pr-err* "\\n"))

(defprotocol Eq
  (=* [x y]
    (print-err "'=*' not implemented:" x)
    (abort)))

(defprotocol Ord
  (<* [value values]
    (print-err "'<*' not implemented:" value)
    (abort)))

(defprotocol Collection
  (empty? [coll])
  (empty [coll])
  (count [coll]
    (print-err "'count' not implemented for " coll)
    (abort))
  (conj [coll value]))

(defprotocol Seqable
  (seq? [coll] 0)
  (seq [coll])
  (first [coll])
  (rest [coll]))

(defprotocol Monoid
  (zero [_])
  (comp* [mval mvals]))

(defn comp [coll & colls]
  (cond
   (empty? colls) coll
   (comp* coll colls)))

(defprotocol Associative
  (assoc [m k v])
  (get [m k not-found]
    (print-err "'get' not implemented: " :m m :k k)
    (abort))
  (keys [m])
  (vals [m]))

(defn not [b-val]
  (cond
   b-val 0
   1))

(defn and [& b-vals]
  (cond
   (empty? b-vals) 1
   (first b-vals) (apply and (rest b-vals))
   0))

(defn or [& b-vals]
  (cond
   (empty? b-vals) 0
   (first b-vals) 1
   (apply or (rest b-vals))))

(defn =
  ([x y] (=* x y))
  ([v & vs]
     (cond
      (empty? vs) 1
      (not (=* v (first vs))) 0
      (number= 1 (count vs)) 1
      (apply = vs))))

(defn <
  ([x y] (<* x y))
  ([v & vs]
     (cond
      (empty? vs) 1
      (not (<* v (first vs))) 0
      (number= 1 (count vs)) 1
      (apply < vs))))

(defn -list* [arg args]
  (cond
   (empty? args) arg
   (cons arg (-list* (first args) (rest args)))))

(defn list* [arg & args]
  (-list* arg args))

(extend-type Function
  ;; Stringable
  ;; (string-list [f] (list "<Fn: " (fn-name f) ">"))

  ;; Serializable
  ;; (serialize [f] (list "<Fn: " (fn-name f) ">"))

  Applicative
  (apply* [f args]
    (cond
     (empty? args) (f)
     (let [new-args (-list* (first args) (rest args))]
       (fn-apply f new-args)))))

(extend-type Number
  Eq
  (=* [x y]
    (number= x y))

  Ord
  (<* [x y] (number-less-than x y))

  Stringable
  (string-list [v] (list (number-str v)))

  ;; Serializable
  ;; (serialize [v] (list (number-str v)))
  )

(defn symkey-name [v]
  (inline-text
     "return(stringValue(((SymKey *)arg0)->name));"))

(extend-type Symbol
  Eq
  (=* [x y]
    (symkey= x y))

  Named
  (name [v]
    (symkey-name v))

  Stringable
  (string-list [v] (list (name v)))

  ;; Serializable
  ;; (serialize [v] (list (name v)))
  )

(extend-type Keyword
  Eq
  (=* [x y]
    (symkey= x y))

  Named
  (name [v]
    (symkey-name v))

  Stringable
  (string-list [v] (list (name v)))

  ;; Serializable
  ;; (serialize [v] (list (name v)))
  )

(defn any? [pred coll]
  (cond
   (empty? coll) 0
   (pred (first coll)) 1
   (any? pred (rest coll))))

(defn ZipList [v]
  (reify
    Applicative
    (apply* [zv arg-lists]
      (cond
       (any? empty? arg-lists) empty-list
       (let [cars (map arg-lists (fn [l] (cond
                                          (empty? l) :nil
                                          (first l))))
             cdrs (map arg-lists rest)]
         (cons (apply v cars)
               (apply* zv cdrs)))))))

(defn reduce [l result f]
  (cond
   (empty? l) result
   (let [head (first l)
         tail (rest l)
         mapped-val (f result head)]
     (cond
      (empty? tail) mapped-val
      (reduce tail mapped-val f)))))

(defn filter [l f]
  (cond
   (empty? l) l
   (let [head (new-list)]
     (reduce l head
             (fn [tail v]
               (cond
                (f v) (snoc head tail v)
                tail)))
     head)))

(defn remove [l f]
  (filter l (fn [v] (not (f v)))))

(defn partial [f & args]
  (fn [& more-args]
    (apply f (comp args more-args))))

(defn reverse [l]
  (reduce l empty-list
          (fn [new-l x]
            (cons x new-l))))

(defn comprehend [f mvs]
  (cond
   (empty? mvs) (f)
   (let [mv (first mvs)
         rest-steps (reduce (reverse (rest mvs))
                            (fn [acc x]
                              (wrap mv (apply f (reverse (cons x acc)))))
                            (fn [steps new-mv]
                              (fn [acc x]
                                (flat-map new-mv (partial steps (cons x acc))))))]
     (cond
      (number= 1 (count mvs)) (flat-map (first mvs) (fn [x]
                                                           (wrap mv (f x))))
      (flat-map mv (partial rest-steps empty-list))))))

(defn list-concat [l1 l2]
  (cond
   (list-empty? l1) l2
   (list-empty? (cdr l1)) (cons (car l1) l2)
   (cons (car l1) (list-concat (cdr l1) l2))))

(defn list=* [ls]
  (cond
   (empty? ls) 1
   (empty? (first ls)) 1
   (not (apply = (map ls (fn [l] (first l))))) 0
   (list=* (map ls rest))))

(extend-type List
  Eq
  (=* [x y]
    (cond
     (not (= (get-type x) (get-type y))) 0
     (not (number= (count x) (count y))) 0
     (list=* (list x y))))

  Stringable
  (string-list [l]
    (comp (list "(")
          (flat-map (interpose l ", ") string-list)
          (list ")")))

  ;; Serializable
  ;; (serialize [l]
  ;;   (comp (list "(")
  ;;         (flat-map (interpose l ", ") string-list)
  ;;         (list ")")))

  Collection
  (empty? [coll] (number= 0 (list-count coll)))
  (empty [coll] empty-list)
  (conj [l v] (cons v l))
  (count [l] (list-count l))

  Seqable
  (seq? [l]
    true)
  (seq [l] l)
  (first [l] (car l))
  (rest [l] (cdr l))

  Monoid
  (zero [_] empty-list)
  (comp* [l ls]
    (cond
     (list-empty? ls) l
     (list-concat l (comp* (first ls)
                           (rest ls)))))

  Functor
  (map [l f]
    (cond
     (empty? l) l
     (let [head (new-list)]
       (reduce l head
               (fn [tail v]
                 (snoc head tail (f v))))
       head)))

  Monad
  (wrap [x v] (list v))
  (flat-map [mv mf]
    (let [l (map mv mf)]
      (cond
       (empty? l) empty-list
       (comp* (car l) (cdr l))))))

(defn some [f coll]
  (cond
   (empty? coll) 0
   (f (first coll)) 1
   (some f (rest coll))))

(defn inc [x]
  (add-numbers x 1))

(defn + [& xs]
  (cond
   (empty? xs) 0
   (reduce xs 0 add-numbers)))

(defn * [& xs]
  (cond
   (empty? xs) 1
   (reduce xs 1 mult-numbers)))

(defn dec [x]
  (subtract-numbers x 1))

(defn - [& xs]
  (cond
   (empty? xs) 0
   (let [h (first xs)
         t (rest xs)]
     (cond
      (empty? t) h
      (reduce t h subtract-numbers)))))

(extend-type String
  Eq
  (=* [x y] (str= x y))

  Collection
  (empty? [s]
    (= 0 (str-count s)))
  (empty [s]
    "")
  (count [s]
    (str-count s))
  (conj [s value]
    (apply comp (flat-map (list s value) string-list)))

  Seqable
  (seq [s]
    (cond
     (= s "") empty-list
     (cons (subs s 0 1) (seq (subs s 1)))))
  (first [s]
    (cond
     (= s "") (abort)
     (subs s 0 1)))
  (rest [s]
    (subs s 1))

  Stringable
  (string-list [v] (list v))

  ;; Serializable
  ;; (serialize [v] (list (char 34) v (char 34)))

  Monoid
  (comp* [s ss]
    (cond
     (list-empty? ss) s
     (let [ss-list (flat-map (cons s ss) string-list)
           new-len (apply + (map ss-list str-count))]
       (reduce ss-list (str-malloc new-len)
               str-append)))))

(extend-type SubStr
  Stringable
  (string-list [v] (list v))

  ;; Serializable
  ;; (serialize [v] (list (char 34) v (char 34)))

  Eq
  (=* [x y] (str= x y))

  Collection
  (empty? [s]
    (= 0 (str-count s)))
  (empty [s]
    "")
  (count [s]
    (str-count s))
  (conj [s value]
    (apply comp (flat-map (list s value) string-list)))

  Seqable
  (seq [s]
    (cond
     (= s "") empty-list
     (cons (subs s 0 1) (seq (subs s 1)))))
  (first [s]
    (cond
     (= s "") (abort)
     (subs s 0 1)))
  (rest [s]
    (subs s 1))

  Monoid
  (comp* [s ss]
    (cond
     (list-empty? ss) s
     (let [ss-list (flat-map (cons s ss) string-list)
           new-len (apply + (map ss-list str-count))]
       (reduce ss-list (str-malloc new-len)
               str-append)))))

(defn str [& vs]
  (cond
   (empty? vs) ""
   (comp* "" (flat-map vs string-list))))

(defn take [l n]
  (cond
   (empty? l) l
   (= 0 n) empty-list
   (cons (first l)
         (take (rest l) (dec n)))))

(defn drop [coll n]
  (cond
   (< n 1) coll
   (drop (rest coll) (dec n))))

(defn partition [coll n]
  (cond
   (< (count coll) n) empty-list
   (cons (take coll n)
         (partition (drop coll n) n))))

(defn partition-all [coll n]
  (cond
   (< (count coll) n) (list coll)
   (cons (take coll n)
         (partition-all (drop coll n) n))))

(defn nth
  ([coll n]
     (cond
      (empty? coll) (let [_ (print-err "'nth' from empty seq")]
                      (abort))
      (= n 0) (first (seq coll))
      (nth (rest (seq coll)) (dec n))))
  ([coll n not-found]
     (cond
      (empty? coll) not-found
      (= n 0) (first (seq coll))
      (nth (rest (seq coll)) (dec n) not-found))))

(defn last [coll last-val]
  (nth coll (dec (count coll))))

(defn butlast [coll]
  (cond
   (empty? coll) coll
   (= 1 (count coll)) empty-list
   (cons (first coll) (butlast (rest coll)))))

(defn map-assoc [m k v]
  (cond
   (list-empty? m) (list (list k v))
   (= (car (car m)) k) (cons (list k v) (cdr m))
   (cons (car m) (map-assoc (cdr m) k v))))

(defn map-get [m k not-found]
  (cond
   (list-empty? m)
   not-found

   (= (car (car m)) k)
   (car (cdr (car m)))

   (map-get (cdr m) k not-found)))

(defn hash-map= [a-list m]
  (cond
   (empty? a-list) 1
   (let [kv-pair (first a-list)
         k (first kv-pair)
         v (first (rest kv-pair))]
     (cond
      (= :hm-nf k) 0
      (= :hm-nf v) 0
      (not (= v (get m k :hm-nf))) 0
      (hash-map= (rest a-list) m)))))

(defn HashMap [a-list]
  (reify
    Seqable
    (seq [_]
      a-list)
    (first [_]
      (car a-list))
    (rest [_]
      (cdr a-list))

    Eq
    (=* [x y]
      (cond
       (not (= (count a-list) (count (seq y)))) 0
       (hash-map= a-list y)))

    Stringable
    (string-list [m]
      (cond
       (list-empty? a-list) (list "{}")
       (let [kv-strs (map a-list
                           (fn [kv]
                             (apply comp (interpose (map kv string-list)
                                                    (list " ")))))
             body-list (apply comp (interpose kv-strs (list ", ")))]
         (comp (list "{")
               body-list
               (list "}")))))

    ;; Serializable
    ;; (serialize [m]
    ;;   (cond
    ;;    (list-empty? a-list) (list "{}")
    ;;    (let [kv-strs (map a-list
    ;;                        (fn [kv]
    ;;                          (apply comp (interpose (map kv string-list)
    ;;                                                 (list " ")))))
    ;;          body-list (apply comp (interpose kv-strs (list ", ")))]
    ;;      (comp (list "{")
    ;;            body-list
    ;;            (list "}")))))

    Collection
    (empty? [_]
      (empty? a-list))

    Associative
    (assoc [_ k v]
      (HashMap (map-assoc a-list k v)))

    (get [_ k not-found]
      (map-get a-list k not-found))

    (keys [m]
      (map a-list (fn [x] (first x))))

    (vals [m]
      (map a-list (fn [x] (nth x 1))))))

(defn hash-map [& kv-pairs]
  (HashMap (partition kv-pairs 2)))

(defn merge [hm & ms]
  (cond
   (empty? ms) hm
   (reduce ms hm
           (fn [hm m]
             (reduce (seq m) hm
                     (fn [hm kv]
                       (assoc hm (nth kv 0) (nth kv 1))))))))

(defn merge-with [merge-fn hm & ms]
  (cond
   (empty? ms) hm
   (reduce ms hm
           (fn [hm m]
             (reduce (seq m) hm
                     (fn [hm kv]
                       (cond
                        (not (= 2 (count kv))) hm
                        (let [k (nth kv 0)
                              v (nth kv 1)
                              old-v (get hm k :not-found)]
                          (cond
                           (= :not-found old-v) (assoc hm k v)
                           (assoc hm k (merge-fn old-v v)))))))))))

(defn get-in [m path nf]
  (cond
   (= (count path) 0) nf
   (= (count path) 1) (get m (first path) nf)
   (let [v (get m (first path) :get-in-not-found)]
     (cond
      (= :get-in-not-found v) nf
      (get-in v (rest path) nf)))))

(defn update-in [m path f]
  (cond
   (= (count path) 0) m
   (= (count path) 1) (let [k (first path)
                            curr-v (get m k :update-in-nil)]
                        (cond
                         (= :update-in-nil curr-v) m
                         (assoc m k (f curr-v))))
   (let [k (first path)
         v (get m k :update-in-nil)]
     (cond
      (= :update-in-nil v) m
      (assoc m k (update-in v (rest path) f))))))

(defn assoc-in [m path v]
  (cond
   (= (count path) 0) m
   (= (count path) 1) (assoc m (first path) v)
   (let [k (first path)
         curr-v (get m k :assoc-in-nil)]
     (cond
      (= :assoc-in-nil curr-v) (assoc m k (assoc-in {} (rest path) v))
      (assoc m k (assoc-in curr-v (rest path) v))))))

(def identity-m
  (reify
   Eq
   (=* [x y] (type= x y))

   ;; Stringable
   ;; (string-list [_]
   ;;   (list "<Id> "))

   Fn
   (invoke [_ v]
     (reify
       ;; Stringable
       ;; (string-list [_]
       ;;   (comp (list "<Id: ")
       ;;         (string-list v)
       ;;         (list ">")))

       Applicative
       (wrap [ev v] (invoke ev v))

       Monad
       (flat-map [mv f] (f v))

       Comonad
       (extract [wv] v)))))

(defn symbol [sym-str]
  (inline-text
   "SymKey *sym = (SymKey *)GC_malloc(sizeof(SymKey));
    sym->type = SymbolType;
    if(arg0->type == StringType)
      sym->name = ((String *)arg0)->buffer;
    else if (arg0->type == SubStringType)
      sym->name = ((SubString *)arg0)->buffer;
    return((Value *)sym);"))

(defn symbol? [sym]
  (= Symbol (get-type sym)))

(defn new-keyword [kw-str]
  (inline-text
   "SymKey *sym = (SymKey *)GC_malloc(sizeof(SymKey));
    sym->type = KeywordType;
    if(arg0->type == StringType)
      sym->name = ((String *)arg0)->buffer;
    else if (arg0->type == SubStringType)
      sym->name = ((SubString *)arg0)->buffer;
    return((Value *)sym);"))

(defn keyword [kw-name]
  (new-keyword (str ":" kw-name)))

(defn keyword? [kw]
  (= Keyword (get-type kw)))

(defn number? [n]
  (= Number (get-type n)))

(defn string? [s]
  (or (= String (get-type s))
      (= SubStr (get-type s))))

(defn range* [n]
  (cond
   (= 0 n) (list 0)
   (cons n (range* (dec n)))))

(defn range [n]
  (reverse (range* (dec n))))


;; parser effect

(defn new-sm [invoke-fn]
  (reify
    ;; Stringable
    ;; (string-list [_]
    ;;   (cond
    ;;    (= identity-m effect) (comp (list "<State: ")
    ;;                                val-string-list
    ;;                                (list ">"))
    ;;    (comp (list "<State ")
    ;;          (string-list effect)
    ;;          (list ": ")
    ;;          val-string-list
    ;;          (list ">"))))

    Fn
    (invoke [ev s]
      (invoke-fn s))

    Applicative
    (wrap [_ v]
      (new-sm (fn [s]
                (list v s))))
    (apply* [fv args]
      (new-sm (fn [s]
                (let [vs-v (reduce args (list empty-list (fv s))
                                   (fn [vs-v arg]
                                     (let [vs (nth vs-v 0)
                                           v-s (nth vs-v 1)]
                                       (cond
                                        (empty? v-s) vs-v
                                        (let [v (nth v-s 0)
                                              s (nth v-s 1)]
                                          (list (cons v vs) (arg s)))))))
                      vs (nth vs-v 0)
                      v-s (nth vs-v 1)]
                  (cond
                   (empty? v-s) v-s
                   (let [v (nth v-s 0)
                         s (nth v-s 1)
                         f-args (reverse (cons v vs))]
                     (list (apply (first f-args) (rest f-args)) s)))))))

    Monad
    (flat-map [ev f]
      (new-sm (fn [s]
                (let [v-ss (ev s)]
                  (cond
                   (empty? v-ss) v-ss
                   (let [v (nth v-ss 0)
                         ss (nth v-ss 1)]
                     ((f v) ss)))))))

    Monoid
    (zero [_]
      (new-sm (fn [s]
                empty-list)))
    (comp* [mv mvs]
      (new-sm (fn [s]
                (let [x (mv s)]
                  (cond
                   (empty? mvs) x
                   (empty? x) ((comp* (first mvs) (rest mvs)) s)
                   x)))))))

(defprotocol FreeEval
  (evaluate [free-val eval-endo]))

(def free-val)
(def free-app)

(def free-zero
  (reify
   ;; Stringable
   ;; (string-list [_] (list "<FreeZero>"))

   Eq
   (=* [x y] (type= x y))

   Applicative
   (wrap [_ v] (free-val v))
   (apply* [fv args]
           (free-app fv args))

   Monoid
   (zero [ev] ev)
   (comp* [_ mvs] mvs)))

(def free-plus
  (reify
   ;; Stringable
   ;; (string-list [_] (list "<FreePlus>"))

   Eq
   (=* [x y] (type= x y))

   Fn
   (invoke [free-plus alts]
           (reify
             ;; Stringable
             ;; (string-list [_]
             ;;   (comp (list "<FreePlus: ")
             ;;         (string-list alts)
             ;;         (list ">")))

             FreeEval
             (evaluate [free-val eval-endo]
               (apply comp
                      (map alts (fn [alt]
                                  (evaluate alt eval-endo)))))

             Applicative
             (wrap [_ v] (free-val v))
             (apply* [fv args]
               (free-app fv args))

             Comonad
             (extract [_] alts)

             Monoid
             (zero [ev] free-zero)
             (comp* [mv mvs]
               (invoke free-plus (cons mv mvs)))))))

(defn pure [arg]
  (reify
    ;; Stringable
    ;; (string-list [_]
    ;;   (comp (list "<Pure: ")
    ;;         (string-list arg)
    ;;         (list ">")))

    FreeEval
    (evaluate [pure-val eval-endo]
      (eval-endo arg))

    Eq
    (=* [x y]
      (and (type= x y)
           (= arg (extract y))))

    Applicative
    (wrap [_ v] (pure v))
    (apply* [fv args]
      (free-app fv args))

    Comonad
    (extract [_] arg)

    Monoid
    (zero [ev] free-zero)
    (comp* [mv mvs]
      (free-plus (cons mv mvs)))))

(defn free-app [fv args]
  (reify
    ;; Stringable
    ;; (string-list [_]
    ;;   (comp (list "<FreeApp: ")
    ;;         (string-list fv)
    ;;         (list " ")
    ;;         (string-list args)
    ;;         (list ">")))

    FreeEval
    (evaluate [free-val eval-endo]
      (let [args (map args (fn [arg]
                             (evaluate arg eval-endo)))
            f (evaluate fv eval-endo)]
        (apply* f args)))

    Eq
    (=* [x y]
      (and (type= x y)
           (= (list fv args)
              (extract y))))

    Applicative
    (wrap [_ v] (free-val v))
    (apply* [fv args]
      (free-app fv args))

    Comonad
    (extract [_]
      (list fv args))

    Monoid
    (zero [ev]
      free-zero)
    (comp* [mv mvs]
      (free-plus (cons mv mvs)))))

(defn free [v]
  (reify
    ;; Stringable
    ;; (string-list [_]
    ;;   (comp (list "<Free: ")
    ;;         (string-list v)
    ;;         (list ">")))

    FreeEval
    (evaluate [free-val eval-endo]
      (eval-endo v))

    Eq
    (=* [x y]
      (and (type= x y)
           (= v (extract y))))

    Applicative
    (wrap [_ v]
      (free v))
    (apply* [fv args]
      (free-app fv args))

    Comonad
    (extract [_] v)

    ;; Monad
    ;; (flat-map [ev f]
    ;;   (println :v v)
    ;;   (invoke effect (map v (fn [inner-v]
    ;;                           (println :inner-v inner-v)
    ;;                           (flat-map inner-v f)))))

    Monoid
    (zero [_]
      free-zero)
    (comp* [mv mvs]
      (free-plus (cons mv mvs)))))

(defn free-val [v] (free v))

(defn state-maybe [v]
  (new-sm (fn [s]
            (list v s))))

(defn update-state [f]
  (new-sm (fn [s]
            (list s (f s)))))

(defn get-val
  ([k]
     (new-sm (fn [s]
               ;; TODO: rewrite this to not use the reify
               (let [nf (reify
                          Eq
                          (=* [x y]
                            (= (get-type x) (get-type y))))
                     v (get s k nf)]
                 (cond
                  (= nf v) empty-list
                  (list v s))))))
  ([k nf]
     (new-sm (fn [s]
               (list (get s k nf) s)))))

(defn set-val [k v]
  (new-sm (fn [s]
            (list (get s k :not-found) (assoc s k v)))))

(defn get-in-val
  ([path]
     (new-sm (fn [s]
               ;; TODO: rewrite this to not use the reify
               (let [nf (reify
                          Eq
                          (=* [x y]
                            (= (get-type x) (get-type y))))
                     v (get-in s path nf)]
                 (cond
                  (= nf v) empty-list
                  (list v s))))))
  ([path nf]
     (new-sm (fn [s]
               (list (get-in s path nf) s)))))

(defn assoc-in-val [path v]
  (new-sm (fn [s]
            (list v (assoc-in s path v)))))

(defn update-in-val [path f]
  (new-sm (fn [s]
            (list (get-in s path :not-found) (update-in s path f)))))

(defprotocol Parser
  (recursive-descent [f]
    (state-maybe (fn [& args]
                   (list (apply f (map (remove args empty?)
                                       first)))))))

(defn term [term-str]
  (free (reify
          Parser
          (recursive-descent [_]
            (let [s-len (count term-str)]
              (for [text (get-val :text "")
                    :when (and (not (< (count text) s-len))
                               (= term-str (subs text 0 s-len)))
                    _ (set-val :text (subs text s-len))]
                (list term-str)))))))

(defn recur [rule]
  (for [a rule
        as (comp (recur rule)
                 (state-maybe empty-list))]
    (cons a as)))

(defn one-or-more [rule]
  (free (reify
          Parser
          (recursive-descent [_]
            (let [rule (evaluate rule recursive-descent)]
              (flat-map (recur rule)
                        (fn [v]
                          (state-maybe (list (apply comp v))))))))))

(defn ignore [rule]
  (free (reify
          Parser
          (recursive-descent [_]
            (flat-map (evaluate rule recursive-descent)
                      (fn [_]
                        (state-maybe empty-list)))))))

(defn always [v]
  (free (reify
          Parser
          (recursive-descent [_]
            (state-maybe (list v))))))

(defn all [& rules]
  (apply* (pure comp) rules))

(defn optional [rule]
  (comp rule (always "")))

(defn none-or-more [rule]
  (comp (one-or-more rule)
        (always empty-list)))

(defn char-code [c]
  (inline-text "if (arg0->type == StringType) {
                  String *s = (String *)arg0;
                  return(numberValue((int)s->buffer[0]));
                } else if (arg0->type == SubStringType) {
                  SubString *s = (SubString *)arg0;
                  return(numberValue((int)s->buffer[0]));
                } else
                  abort();\n "))

(defn char-test [pred]
  (for [txt (get-val :text "")
        :let [c (subs txt 0 1)]
        :when (cond
               (< 0 (count txt)) (pred c)
               false)
        _ (set-val :text (subs txt 1))]
    (list c)))

(defn lower-alpha []
  (free (reify
          Parser
          (recursive-descent [_]
            (char-test (fn [c]
                         (< (dec (char-code "a")) (char-code c) (inc (char-code "z")))))))))

(defn upper-alpha []
  (free (reify
          Parser
          (recursive-descent [_]
            (char-test (fn [c]
                         (< (dec (char-code "A")) (char-code c) (inc (char-code "Z")))))))))

(defn alpha []
  (comp (lower-alpha)
        (upper-alpha)))

(defn digit []
  (free (reify
          Parser
          (recursive-descent [_]
            (char-test (fn [c]
                         (< (dec (char-code "0")) (char-code c) (inc (char-code "9")))))))))

(defn one-of [coll]
  (let [coll (seq coll)]
    (comp* (term (first coll))
           (map (rest coll) term))))

(defn to-string [rule]
  (apply-to (fn [chars]
              (apply str chars))
            rule))

(defn symbol-start []
  (comp (alpha) (one-of "_<>=+-*/")))

(defn symbol-punct [] (one-of "_<>=*/+!-?"))

(defn symbol-char [] (comp (alpha) (digit) (symbol-punct)))

(defn rest-of-symbol []
  (none-or-more (symbol-char)))

(defn read-symbol []
  (apply-to (fn [start the-rest]
              (symbol (apply str (cons start the-rest))))
            (symbol-start)
            (rest-of-symbol)))

(defn read-keyword []
  (apply-to (fn [start the-rest]
              (keyword (apply str (cons start the-rest))))
            (ignore (term ":"))
            (symbol-start)
            (rest-of-symbol)))

(defn backslash []
  (term (char 92)))

(defn read-string-newline []
  (all (ignore (backslash))
       (ignore (term "n"))
       (always (char 10))))

(defn read-string-tab []
  (all (ignore (backslash))
       (ignore (term "t"))
       (always (char 9))))

(defn read-string-backspace []
  (all (ignore (backslash))
       (ignore (term "b"))
       (always (char 8))))

(defn read-string-return []
  (all (ignore (backslash))
       (ignore (term "r"))
       (always (char 13))))

(defn read-string-formfeed []
  (all (ignore (backslash))
       (ignore (term "f"))
       (always (char 12))))

(defn read-string-doublequote []
  (all (ignore (backslash))
       (ignore (term (char 34)))
       (always (char 34))))

(defn read-string-backslash []
  (all (ignore (backslash))
       (ignore (backslash))
       (always (char 92))))

(defn not-backslash []
  (free (reify
          Parser
          (recursive-descent [_]
            (for [txt (get-val :text "")
                  :let [x (subs txt 0 1)]
                  :when (cond
                         (= x (char 92)) false
                         (= x (char 34)) false
                         true)
                  _ (set-val :text (subs txt 1))]
              (list x))))))

(defn read-const-string []
  (all (ignore (term (char 34)))
       (to-string
        (none-or-more
         (comp (not-backslash)
               (read-string-backslash)
               (read-string-doublequote)
               (read-string-tab)
               (read-string-backspace)
               (read-string-return)
               (read-string-formfeed)
               (read-string-newline))))
       (ignore (term (char 34)))))

(defn str-to-int [negate? int-str]
  (let [magnitude (reduce int-str 0
                          (fn [n c]
                            (+ (* n 10)
                               (cond
                                (= c "1") 1
                                (= c "2") 2
                                (= c "3") 3
                                (= c "4") 4
                                (= c "5") 5
                                (= c "6") 6
                                (= c "7") 7
                                (= c "8") 8
                                (= c "9") 9
                                0))))]
    (cond
     (= "-" negate?) (* -1 magnitude)
     magnitude)))

;; only reads integers
(defn read-number []
  (apply-to str-to-int
            (optional (term "-"))
            (one-or-more (digit))))

(def read-form)

(defn read-sub-form []
  (free (reify
          Parser
          (recursive-descent [_]
            (for [parser-fn (get-in-val (list :parser-fns "form") :blah)
                  result (new-sm parser-fn)]
              result)))))

(defn read-list []
  (all (ignore (term "("))
       (none-or-more (read-sub-form))
       (ignore (term ")"))))

(defn read-hash-map []
  (apply-to cons
            (ignore (term "{"))
            (always 'hash-map)
            (none-or-more (read-sub-form))
            (ignore (term "}"))))

(defn read-vector []
  (apply-to cons
            (ignore (term "["))
            (always 'vector)
            (none-or-more (read-sub-form))
            (ignore (term "]"))))

(defn not-eol []
  (free (reify
          Parser
          (recursive-descent [_]
            (for [txt (get-val :text "")
                  :let [x (subs txt 0 1)]
                  :when (not (= x (char 10)))
                  _ (set-val :text (subs txt 1))]
              (list x))))))

(defn read-comment []
  (all (term ";")
       (ignore (none-or-more (not-eol)))
       (term (char 10))))

(defn whitespace []
  (comp (one-of " ,")
        (term (char 9))
        (term (char 13))
        (term (char 10))
        (read-comment)))

(defn read-var-arg []
  (apply-to list
            (ignore (none-or-more (whitespace)))
            (term "&")
            (ignore (one-or-more (whitespace)))
            (read-symbol)))

(defn read-arg []
  (all (ignore (none-or-more (whitespace)))
       (read-symbol)
       (ignore (none-or-more (whitespace)))))

(defn read-args []
  (apply-to comp
            (ignore (none-or-more (whitespace)))
            (ignore (term "["))
            (none-or-more (read-arg))
            (comp (read-var-arg)
                  (always empty-list))
            (ignore (term "]"))))

(defn read-main []
  (apply-to list*
            (ignore (term "("))
            (ignore (none-or-more (whitespace)))
            (ignore (term "main"))
            (always 'main)
            (ignore (one-or-more (whitespace)))
            (read-args)
            (one-or-more (read-sub-form))
            (ignore (none-or-more (whitespace)))
            (ignore (term ")"))))

(defn read-single-arity []
  (apply-to (fn [& vs]
              (list vs))
            (always 'fn-arity)
            (read-args)
            (none-or-more (read-sub-form))))

(defn read-multi-arity []
  (apply-to list
            (ignore (none-or-more (whitespace)))
            (ignore (term "("))
            (ignore (none-or-more (whitespace)))
            (always 'fn-arity)
            (read-args)
            (none-or-more (read-sub-form))
            (ignore (none-or-more (whitespace)))
            (ignore (term ")"))))

(defn read-arities []
  (comp (read-single-arity)
        (one-or-more (read-multi-arity))))

(defn read-defn []
  (apply-to (fn [name arities]
              (list 'def name (list 'fn name arities)))
            (ignore (term "("))
            (ignore (none-or-more (whitespace)))
            (ignore (term "defn"))
            (ignore (one-or-more (whitespace)))
            (read-symbol)
            (ignore (one-or-more (whitespace)))
            (read-arities)
            (ignore (none-or-more (whitespace)))
            (ignore (term ")"))))

(defn read-fn []
  (apply-to list
            (ignore (term "("))
            (ignore (none-or-more (whitespace)))
            (ignore (term "fn"))
            (always 'fn)
            (ignore (one-or-more (whitespace)))
            (comp (read-symbol)
                  (always 'anon))
            (ignore (none-or-more (whitespace)))
            (read-arities)
            (ignore (none-or-more (whitespace)))
            (ignore (term ")"))))

(defn read-let-binding []
  (apply-to list
            (ignore (none-or-more (whitespace)))
            (read-symbol)
            (ignore (none-or-more (whitespace)))
            (read-sub-form)))

(defn read-let []
  (apply-to list*
            (ignore (term "("))
            (ignore (none-or-more (whitespace)))
            (ignore (term "let"))
            (always 'let)
            (ignore (one-or-more (whitespace)))
            (ignore (term "["))
            (none-or-more (read-let-binding))
            (ignore (term "]"))
            (one-or-more (read-sub-form))
            (ignore (none-or-more (whitespace)))
            (ignore (term ")"))))

(defn read-for-let []
  (apply-to list
            (ignore (none-or-more (whitespace)))
            (ignore (term ":let"))
            (always :let)
            (ignore (one-or-more (whitespace)))
            (ignore (term "["))
            (none-or-more (read-let-binding))
            (ignore (term "]"))))

(defn read-for-when []
  (apply-to list
            (ignore (none-or-more (whitespace)))
            (ignore (term ":when"))
            (always :when)
            (ignore (one-or-more (whitespace)))
            (read-sub-form)))

(defn read-for-binding []
  (comp (read-for-let)
        (read-for-when)
        (read-let-binding)))

(defn read-for []
  (apply-to (fn [bound val bindings body]
              (let [bindings (cons (list bound 'some-unique-var) bindings)]
                (list 'let (list (list 'some-unique-var val))
                      (reduce (reverse bindings) (list 'wrap 'some-unique-var body)
                              (fn [expr sym-val]
                                (let [sym (first sym-val)
                                      val (first (rest sym-val))]
                                  (cond
                                   (= sym :let) (list 'let val expr)
                                   (= sym :when) (list 'cond val expr (list 'zero 'some-unique-var))
                                   (list 'flat-map val
                                         (list 'fn 'anon
                                               (list (list 'fn-arity (list sym) (list expr))))))))))))
            (ignore (term "("))
            (ignore (none-or-more (whitespace)))
            (ignore (term "for"))
            (ignore (one-or-more (whitespace)))
            (ignore (term "["))
            (ignore (none-or-more (whitespace)))
            (read-symbol)
            (ignore (one-or-more (whitespace)))
            (read-sub-form)
            (none-or-more (read-for-binding))
            (ignore (term "]"))
            (read-sub-form)
            (ignore (none-or-more (whitespace)))
            (ignore (term ")"))))

(defn read-quoted []
  (apply-to list
            (ignore (term "'"))
            (always 'quote)
            (read-symbol)))

(defn rule [name grammar]
  (free (reify
          Parser
          (recursive-descent [_]
            (let [parser (evaluate grammar recursive-descent)
                  parser-fn (fn [s] (parser s))]
              (for [_ (assoc-in-val (list :parser-fns name) parser-fn)
                    result (new-sm parser-fn)]
                result))))))

(defn read-form []
  (rule "form"
        (all (ignore (none-or-more (whitespace)))
             (comp (read-number)
                   (read-keyword)
                   (read-symbol)
                   (read-quoted)
                   (read-const-string)
                   (read-let)
                   (read-main)
                   (read-defn)
                   (read-fn)
                   (read-for)
                   ;; (read-character)
                   (read-hash-map)
                   (read-vector)
                   (read-list))
             (ignore (none-or-more (whitespace))))))

(defn make-parser [rule]
  (let [p (evaluate rule recursive-descent)]
    (flat-map p (fn [v]
                  (state-maybe (first v))))))


;; code analyzer

(defn set-expr [expr]
  (set-val :expr expr))

(defn is-expr [pred]
  (for [expr (get-val :expr)
        :when (pred expr)]
    expr))

(def analyze-expr)

(def inline-ast)
(def symbol-ast)
(def keyword-ast)
(def const-number-ast)
(def const-string-ast)
(def variadic-arity-ast)
(def fn-arity-ast)
(def main-ast)
(def call-ast)
(def binding-ast)
(def let-ast)
(def fn-ast)
(def quoted-ast)
(def definition-ast)
(def cond-ast)
(def extend-ast)
(def reify-ast)
(def protocol-ast)
(def bootstrap-ast)

(defn analyze-inline-text []
  (for [expr (is-expr (fn [x]
                       (cond
                        (not (seq? x)) false
                        (empty? x) false
                        (= (first x) 'inline-text))))]
    (inline-ast (nth expr 1 ""))))

(defn sym-already-defined? [sym]
  (get-in-val (list :symbols sym)))

(defn sym-recently-defined? [sym]
  (get-in-val (list :new-symbols sym)))

(defn make-static-symbol [sym]
  (for [sym-idx (get-val :sym-count 0)
        _ (set-val :sym-count (inc sym-idx))
        _ (assoc-in-val (list :new-symbols sym)
                        (str "_sym_" sym-idx))]
    ""))

(defn analyze-symbol []
  (for [sym (is-expr symbol?)
        _ (comp (sym-already-defined? sym)
                (sym-recently-defined? sym)
                (make-static-symbol sym))]
    (symbol-ast sym)))

(defn keyword-already-defined? [kw]
  (get-in-val (list :keywords kw)))

(defn keyword-recently-defined? [kw]
  (get-in-val (list :new-keywords kw)))

(defn make-static-keyword [kw]
  (for [kw-idx (get-val :kw-count 0)
        _ (set-val :kw-count (inc kw-idx))
        _ (assoc-in-val (list :new-keywords kw)
                        (str "_kw_" kw-idx))]
    ""))

(defn analyze-keyword []
  (for [kw (is-expr keyword?)
        _ (comp (keyword-already-defined? kw)
                (keyword-recently-defined? kw)
                (make-static-keyword kw))]
    (keyword-ast kw)))

(defn number-already-defined? [num]
  (get-in-val (list :numbers num)))

(defn number-recently-defined? [num]
  (get-in-val (list :new-numbers num)))

(defn make-static-number [num]
  (for [num-idx (get-val :num-count 0)
        _ (set-val :num-count (inc num-idx))
        _ (assoc-in-val (list :new-numbers num)
                        (str "_num_" num-idx))]
    ""))

(defn analyze-number []
  (for [num (is-expr number?)
        _ (comp (number-already-defined? num)
                (number-recently-defined? num)
                (make-static-number num))]
    (const-number-ast num)))

(defn string-already-defined? [str-val]
  (get-in-val (list :strings str-val)))

(defn string-recently-defined? [str-val]
  (get-in-val (list :new-strings str-val)))

(defn make-static-string [str-val]
  (for [str-idx (get-val :str-count 0)
        _ (set-val :str-count (inc str-idx))
        _ (assoc-in-val (list :new-strings str-val)
                        (str "_str_" str-idx))]
    ""))

(defn analyze-string []
  (for [str-val (is-expr string?)
        _ (comp (string-already-defined? str-val)
                (string-recently-defined? str-val)
                (make-static-string str-val))]
    (const-string-ast str-val)))

(defn analyze-call []
  (for [expr (is-expr (fn [s] (not (empty? s))))
        ast (apply* (state-maybe list) (map expr analyze-expr))]
    (call-ast (first ast) (rest ast))))

(defn analyze-let-binding [binding-pair]
  (cond
   (not (= 2 (count binding-pair))) empty-list
   (let [binding (nth binding-pair 0)
         expr (nth binding-pair 1)]
     (for [curr-expr (get-val :expr)
           _ (set-expr binding)
           binding (is-expr symbol?)
           ast (analyze-expr expr)
           _ (set-val :expr curr-expr)]
       (binding-ast binding ast)))))

(defn analyze-let []
  (for [expr (is-expr (fn [x]
                        (cond
                         (not (seq? x)) false
                         (not (< 2 (count x))) false
                         (= (nth x 0 :not-let) 'let))))
        bindings (apply* (state-maybe list) (map (nth expr 1 empty-list)
                                                 analyze-let-binding))
        body (apply* (state-maybe list) (map (drop expr 2)
                                             analyze-expr))]
    (let-ast (apply* (pure list) bindings)
             (apply* (pure list) body))))

(defn variadic? [expr]
  (let [args (nth expr 1 empty-list)]
    (apply or (map args (fn [arg] (= "&" arg))))))

(defn analyze-variadic []
  (for [expr (is-expr (fn [x]
                        (cond
                         (not (< 1 (count x))) false
                         (not (= (first x) 'fn-arity)) false
                         (variadic? x))))
        body (apply* (state-maybe list) (map (nth expr 2 empty-list) analyze-expr))]
    (variadic-arity-ast (filter (nth expr 1 empty-list) (fn [arg]
                                                          (not (= "&" arg))))
                        (apply* (pure list) body))))

(defn analyze-fn-arity []
  (for [expr (is-expr (fn [x]
                        (cond
                         (not (< 1 (count x))) false
                         (not (= (first x) 'fn-arity)) false
                         (not (variadic? x)))))
        file-name (get-val :file-name "")
        body (apply* (state-maybe list) (map (nth expr 2 empty-list) analyze-expr))]
    (fn-arity-ast (nth expr 1 empty-list)
                  (apply* (pure list) body))))

;; TODO: let anonymous function closures reference themselves by name
(defn analyze-fn []
  (for [expr (is-expr (fn [x]
                        (cond
                         (not (seq? x)) false
                         (not (< 1 (count x))) false
                         (= (first x) 'fn))))
        arities (apply* (state-maybe list) (map (nth expr 2 empty-list) analyze-expr))]
    (fn-ast (nth expr 1 "no-name") arities)))

(defn analyze-arity [args]
  (cond
   (< (count args) 2) empty-list
   (let [fn-name (nth args 0)
         params (rest (nth args 1))
         body (drop args 2)
         default-fn-expr (list 'fn fn-name (list (list 'fn-arity params body)))]
     (cond
      (< 0 (count body)) (for [default (analyze-expr default-fn-expr)]
                           {fn-name {(count params) {:default default}}})
      (state-maybe {fn-name {(count params) {}}})))))

(defn analyze-quoted []
  (for [expr (is-expr (fn [x]
                        (cond
                         (not (= 2 (count x))) false
                         (= (first x) 'quote))))
        _ (let [sym (nth expr 1)]
            (comp (sym-already-defined? sym)
                  (sym-recently-defined? sym)
                  (make-static-symbol sym)))]
    (quoted-ast (nth expr 1))))

(defn analyze-def []
  (for [curr-expr (get-val :expr :no-expr)
        expr (is-expr (fn [x]
                        (cond
                         (not (seq? x)) false
                         (< 1 (count x)))))
        :let [def (nth expr 0 :not-def)
              name (nth expr 1 'no-name)
              value (nth expr 2 :no-value)]
        :when (and (= def 'def) (symbol? name))
        val-ast (cond
                 (= value :no-value) (state-maybe :no-value)
                 (analyze-expr value))]
    (definition-ast name val-ast)))

(defn analyze-cond []
  (for [expr (is-expr seq?)
        :when (cond
               (empty? expr) false
               (= (first expr) 'cond))
        clause-pairs (apply* (state-maybe list) (map (rest expr) analyze-expr))]
    (let [clauses (partition-all clause-pairs 2)
          default (last clauses empty-list)]
      (cond
       (= 1 (count default)) (cond-ast (butlast clauses)
                                       (first default))
       (print-err "cond must have a default clause")))))

(defn next-form []
  (for [expr (get-val :expr empty-list)
        _ (set-val :expr (rest expr))
        :when (< 0 (count expr))]
    (first expr)))

(defn is-form? [pred]
  (for [frm (next-form)
        :when (pred frm)]
    frm))

(defn analyze-proto-fn []
  (for [expr (is-form? (fn [x]
                         (cond
                          (not (seq? x)) false
                          (< 2 (count x)))))
        arg-vec (apply* (state-maybe list)
                        (map (nth expr 1 empty-list) analyze-expr))
        body (apply* (state-maybe list) (map (drop expr 2) analyze-expr))]
    (list (nth expr 0 'no-name)
          (fn-ast (str (nth expr 0 'no-name) "_impl")
                  (list (fn-arity-ast (rest (nth expr 1 empty-list))
                                      (apply* (pure list) body)))))))

(defn analyze-proto-impl []
  (for [name (is-form? symbol?)
        fn-impls (recur (analyze-proto-fn))]
    (list name fn-impls)))

(defn analyze-extensions [exts]
  (for [curr-expr (get-val :expr empty-list)
        _ (set-val :expr exts)
        proto-impls (recur (analyze-proto-impl))
        _ (set-val :expr curr-expr)]
    (HashMap proto-impls)))

(defn analyze-extend-type []
  (for [expr (is-expr (fn [x]
                        (cond
                         (not (seq? x)) false
                         (not (< 1 (count x))) false
                         (= 'extend-type (first x)))))
        proto-specs (analyze-extensions (drop expr 2))]
    (extend-ast (nth expr 1 :no-type) proto-specs)))

(defn analyze-reify []
  (for [expr (is-expr (fn [x]
                        (cond
                         (not (seq? x)) false
                         (= 'reify (nth x 0 :not-reify)))))
        proto-specs (analyze-extensions (rest expr))]
    (reify-ast proto-specs)))

(defn analyze-protocol []
  (for [expr (is-expr (fn [x]
                        (cond
                         (not (seq? x)) false
                         (not (< 2 (count x))) false
                         (= 'defprotocol (first x)))))
        ;; TODO: make this only accept fixed arities
        arities (apply* (state-maybe list)
                        (map (drop expr 2) analyze-arity))]
    (protocol-ast (nth expr 1 :no-name)
                  (apply merge-with merge arities))))

(defn analyze-main []
  (for [expr (is-expr (fn [x]
                        (cond
                         (not (seq? x)) false
                         (not (< 2 (count x))) false
                         (= 'main (first x)))))
        body (apply* (state-maybe list) (map (drop expr 2) analyze-expr))]
    (main-ast (nth expr 1 empty-list)
              (apply* (pure list) body))))

(defn analyze-bootstrap []
  (flat-map (is-expr (fn [x] (= x 'toccata)))
            (fn [expr]
              (state-maybe (bootstrap-ast)))))

(defn expr->ast []
  (comp (analyze-symbol)
        (analyze-keyword)
        (analyze-number)
        (analyze-string)
        (analyze-fn)
        (analyze-protocol)
        (analyze-main)
        (analyze-def)
        (analyze-cond)
        (analyze-extend-type)
        (analyze-reify)
        (analyze-inline-text)
        (analyze-fn-arity)
        (analyze-variadic)
        (analyze-let)
        (analyze-quoted)
        (analyze-call)
        (flat-map (get-val :expr :expr-nil)
                  (fn [e]
                    (print-err "could not analyze" e)
                    empty-list))))

(defn analyze-expr [expr]
  (for [curr-expr (get-val :expr :no-expr)
        file-name (get-val :file-name "")
        _ (set-expr expr)
        ast (expr->ast)
        _ (set-val :expr curr-expr)]
    ast))

(defn analyze [expr]
  (first (expr->ast {:expr expr})))

;; code emitter

(defn types []
  ;; type numbers must start at 1 and be contiguous
  {'String 1
   'Number 2
   'Function 3
   'List 4
   'Keyword 5
   'SubStr 6
   'Symbol 7
   })

(def VoidT "void")
(def Int8 "char")
(def Int8* "char *")
(def Int32 "int")
(def Int64 "int64_t")
(def ValueType Int64)  ;; type of boxed values
(def Value "typedef struct {int64_t type;} Value;\\n")
(def Value* "Value *")
(def NumberVal "typedef struct {int64_t type; int64_t numVal;} Number;\\n")
(def NumberVal* "Number *")
(def SymKey "typedef struct {int64_t type; char *name;} SymKey;\\n")
(def StringVal "typedef struct {int64_t type; int64_t len; char buffer[0];} String;\\n")
(def StringVal* "String *")
(def SubStringVal "typedef struct {int64_t type; int64_t len; Value *source; char *buffer;} SubString;\\n")
(def SubStringVal* "SubString *")
(def ListVal "typedef struct List {int64_t type; int64_t len; Value* head; struct List *tail;} List;\\n")
(def ListVal* "List *")
(def FnArity "typedef struct {int count; List *closures; int variadic; void *fn;} FnArity;\\n")
(def FnArity* "FnArity *")
(def FunctionVal "typedef struct {int64_t type; char *name; int64_t arityCount; FnArity *arities[];} Function;\\n")
(def ProtoImpl "typedef struct {int64_t type; Value *implFn;} ProtoImpl;\\n")
(def ProtoImpls "typedef struct {int64_t implCount; Value *defaultImpl; ProtoImpl impls[];} ProtoImpls;\\n")
(def ReifiedVal "typedef struct {int64_t type; int implCount; Value* impls[];} ReifiedVal;\\n")
(def ReifiedVal* "ReifiedVal *")

(def true (inline-text "(Value *)&trueVal;"))
(def false (inline-text "(Value *)&falseVal;"))

(defn abort []
  (inline-text
   "abort();
    return(true);\n"))

(defn get-type [value]
  (inline-text
   "return(numberValue(arg0->type));"))

(defn type= [x y]
  (inline-text "if (arg0->type == arg1->type)
                   return((Value *)&trueVal);
                else
                   return((Value *)&falseVal);\n"))

(defn subs
  ([src index]
     (inline-text "int64_t idx = ((Number *)arg1)->numVal;
                   if (arg0->type == StringType) {
                     String *s = (String *)arg0;
                     SubString *subStr = (SubString *)GC_malloc(sizeof(SubString));
                     subStr->type = SubStringType;
                     if (idx < s->len) {
                       subStr->len = s->len - idx;
                       subStr->source = arg0;
                       subStr->buffer = s->buffer + idx;
                     }
                     else {
                       subStr->len = 0;
                       subStr->source = (Value *)0;
                       subStr->buffer = (char *)0;
                     }
                     return((Value *)subStr);
                   } else if (arg0->type == SubStringType) {
                     SubString *s = (SubString *)arg0;
                     SubString *subStr = (SubString *)GC_malloc(sizeof(SubString));
                     subStr->type = SubStringType;
                     if (idx < s->len) {
                       subStr->len = s->len - idx;
                       subStr->source = arg0;
                       subStr->buffer = s->buffer + idx;
                     }
                     else {
                       subStr->len = 0;
                       subStr->source = (Value *)0;
                       subStr->buffer = (char *)0;
                     }
                     return((Value *)subStr);
                   } else
                     abort();\n"))
  ([src index length]
     (inline-text "int64_t idx = ((Number *)arg1)->numVal;
                   int64_t len = ((Number *)arg2)->numVal;
                   if (arg0->type == StringType) {
                     String *s = (String *)arg0;
                     SubString *subStr = (SubString *)GC_malloc(sizeof(SubString));
                     subStr->type = SubStringType;
                     if (idx + len <= s->len) {
                       subStr->len = len;
                       subStr->source = arg0;
                       subStr->buffer = s->buffer + idx;
                     }
                     else {
                       subStr->len = 0;
                       subStr->source = (Value *)0;
                       subStr->buffer = (char *)0;
                     }
                     return((Value *)subStr);
                   } else if (arg0->type == SubStringType) {
                     SubString *s = (SubString *)arg0;
                     SubString *subStr = (SubString *)GC_malloc(sizeof(SubString));
                     subStr->type = SubStringType;
                     if (idx + len <= s->len) {
                       subStr->len = len;
                       subStr->source = arg0;
                       subStr->buffer = s->buffer + idx;
                     }
                     else {
                       subStr->len = 0;
                       subStr->source = (Value *)0;
                       subStr->buffer = (char *)0;
                     }
                     return((Value *)subStr);
                   } else
                     abort();\n")))

;; this function assumes the type of 'n' has already been checked
(defn number-str [n]
  (inline-text
   "char *buffer = (char *)GC_malloc(10);
    snprintf(buffer, 9, \"%lld\", ((Number *)arg0)->numVal);
    return(stringValue(buffer));\n"))

(defn number= [x y]
  (inline-text
   "if (arg0->type != arg1->type) {
      return(false);
   } else if (((Number *)arg0)->numVal != ((Number *)arg1)->numVal)
      return(false);
   else
      return(true);\n"))

;; this function assumes the type of 'x' has already been checked
(defn number-less-than [x y]
  (inline-text
   "if (arg0->type != arg1->type) {
      printf(\"\\ninvalid types for 'number-less-than'\\n\");
      abort();
   } else if (((Number *)arg0)->numVal < ((Number *)arg1)->numVal)
      return(true);
   else
      return(false);\n"))

;; this function assumes the type of 'x' has already been checked
(defn add-numbers [x y]
  (inline-text
   "if (arg0->type != arg1->type) {
      printf(\"\\ninvalid types for 'add-numbers'\\n\");
      abort();
    } else
      return(numberValue(((Number *)arg0)->numVal + ((Number *)arg1)->numVal));\n"))

;; this function assumes the type of 'x' has already been checked
(defn subtract-numbers [x y]
  (inline-text
   "if (arg0->type != arg1->type) {
      printf(\"\\ninvalid types for 'subtract-numbers'\\n\");
      abort();
    } else
      return(numberValue(((Number *)arg0)->numVal - ((Number *)arg1)->numVal));\n"))

;; this function assumes the type of 'x' has already been checked
(defn mult-numbers [x y]
  (inline-text
   "if (arg0->type != arg1->type) {
      printf(\"\\ninvalid types for 'mult-numbers'\\n\");
      abort();
    } else
      return(numberValue(((Number *)arg0)->numVal * ((Number *)arg1)->numVal));\n"))

(def empty-list
  (inline-text "(Value *)&(List){4,0,0,0};"))

(defn cons
  ([x]
     (inline-text "return((Value *)listCons(arg0, empty_list));"))
  ([x l]
     (inline-text "return((Value *)listCons(arg0, (List *)arg1));")))

(defn list-count [l]
  (inline-text
   "if (arg0->type != ListType)
      abort();
    else
      return(numberValue(((List *)arg0)->len));"))

(defn car [l]
  (inline-text
   "List *lst = (List *)arg0;
    if (arg0->type != ListType) {
      printf(\"'car' requires a list\\n\");
      abort();
    } else if (lst->len == 0) {
       printf(\"Cannot get head of empty list!!\\n\");
       abort();
    } else
       return(((List *)arg0)->head);"))

(defn cdr [l]
  (inline-text
   "List *lst = (List *)arg0;
    if (arg0->type != ListType) {
      printf(\"'cdr' requires a list\\n\");
      abort();
    } else if (lst->len == 0) {
       return(arg0);
    } else {
       List *tail = ((List *)arg0)->tail;
       tail->len = lst->len - 1;
       return((Value *)tail);
    }\n"))

(defn fn-name [f]
  (inline-text
   "if (arg0->type != FunctionType) {
      printf(\"\\ninvalid type for 'fn-name'\\n\");
      abort();
    } else
      return(stringValue(((Function *)arg0)->name));\n"))

(defn new-list []
  (inline-text
   "List *newList = (List *)GC_malloc(sizeof(List));
    newList->type = ListType;
    newList->len = 0;
    newList->head = (Value *)0;
    newList->tail = (List *)0;
    return((Value *)newList);\n"))

(defn snoc [head tail v]
  (inline-text
   "if (arg1->type != ListType || arg0->type != ListType) {
      printf(\"\\ninvalid type for 'snoc'\\n\");
      abort();
    }

    List *newTail = (List *)GC_malloc(sizeof(List));
    newTail->type = ListType;
    newTail->len = 0;
    newTail->head = (Value *)0;
    newTail->tail = (List *)0;

    List *t = (List *)arg1;
    t->head = (Value *)arg2;
    t->tail = newTail;

    ((List *)arg0)->len++;
    return((Value *)newTail);\n"))

(defn char [n]
  (inline-text
   "if (arg0->type != NumberType) {
      printf(\"\\ninvalid type for 'char'\\n\");
      abort();
    }
    String *strVal = (String *)GC_malloc(sizeof(String) + 2);
    strVal->type = StringType;
    strVal->len = 1;
    strVal->buffer[0] = ((Number *)arg0)->numVal;
    strVal->buffer[1] = 0;
    return((Value *)strVal);\n"))

(defn str-count [str]
  (inline-text
   "if (arg0->type != StringType && arg0->type != SubStringType ) {
      printf(\"\\ninvalid type for 'char'\\n\");
      abort();
    }
   return (numberValue(((String *)arg0)->len));\n"))

(defn str= [str1 str2]
  (inline-text
   "if (arg0->type == StringType && arg1->type == StringType) {
      String *s1 = (String *)arg0;
      String *s2 = (String *)arg1;
      if (s1->len == s2->len && strncmp(s1->buffer,s2->buffer,s1->len) == 0)
        return(true);
      else
        return(false);
    } else if (arg0->type == SubStringType && arg1->type == SubStringType) {
      SubString *s1 = (SubString *)arg0;
      SubString *s2 = (SubString *)arg1;
      if (s1->len == s2->len && strncmp(s1->buffer,s2->buffer,s1->len) == 0)
        return(true);
      else
        return(false);
    } else if (arg0->type == StringType &&
               arg1->type == SubStringType) {
      String *s1 = (String *)arg0;
      SubString *s2 = (SubString *)arg1;
      if (s1->len == s2->len && strncmp(s1->buffer,s2->buffer,s1->len) == 0)
        return(true);
      else
        return(false);
    } else if (arg0->type == SubStringType &&
               arg1->type == StringType) {
      SubString *s1 = (SubString *)arg0;
      String *s2 = (String *)arg1;
      if (s1->len == s2->len && strncmp(s1->buffer,s2->buffer,s1->len) == 0)
        return(true);
      else
        return(false);
    } else
       return(false);\n"))

(defn symkey= [v1 v2]
  (inline-text
   "if (arg0->type != arg1->type)
      return(false);
    else {
      SymKey *s1 = (SymKey *)arg0;
      SymKey *s2 = (SymKey *)arg1;
      if (s1->type == s2->type && strcmp(s1->name,s2->name) == 0) {
        return(true);
      } else
        return(false);
    }\n"))

(defn str-malloc [len]
  (inline-text
   "String *strVal = (String *)GC_malloc(sizeof(String) + ((Number *)arg0)->numVal);
    strVal->type = StringType;
    strVal->len = 0;
    strVal->buffer[0] = 0;
    return((Value *)strVal);\n"))

(defn str-append [dest src]
  (inline-text
   "String *s1 = (String *)arg0;
    if (arg0->type != StringType) {
      printf(\"\\ninvalid type for 'str-append'\\n\");
      abort();
    }

    if (arg1->type == StringType) {
      String *s2 = (String *)arg1;
      strncat(s1->buffer, s2->buffer, s2->len);
      s1->len += s2->len;
    } else if (arg1->type == SubStringType) {
      SubString *s2 = (SubString *)arg1;
      strncat(s1->buffer, s2->buffer, s2->len);
      s1->len += s2->len;
    }
    return(arg0);\n"))

(defn pr* [str]
  (inline-text
   "if (arg0->type == StringType)
      printf(\"%-.*s\", (int)((String *)arg0)->len, ((String *)arg0)->buffer);
    else if (arg0->type == SubStringType)
      printf(\"%-.*s\", (int)((SubString *)arg0)->len, ((SubString *)arg0)->buffer);
    else {
      printf(\"\\ninvalid type for 'pr*'\\n\");
      abort();
    }
    return(true);\n"))

(defn pr-err* [str]
  (inline-text
   "if (arg0->type == StringType)
      fprintf(stderr, \"%-.*s\", (int)((String *)arg0)->len, ((String *)arg0)->buffer);
    else if (arg0->type == SubStringType)
      fprintf(stderr, \"%-.*s\", (int)((SubString *)arg0)->len, ((SubString *)arg0)->buffer);
    else {
      fprintf(stderr, \"\\ninvalid type for 'pr-err*'\\n\");
      abort();
    }
    return(true);\n"))

(defn slurp [fileName]
  (inline-text
   "char *arg0Str = (char *)GC_malloc(((String *)arg0)->len + 5);
    if (arg0->type == StringType)
      snprintf(arg0Str, ((String *)arg0)->len + 1, \"%s\", ((String *)arg0)->buffer);
    else if (arg0->type == SubStringType)
      snprintf(arg0Str, ((String *)arg0)->len + 1, \"%s\", ((SubString *)arg0)->buffer);
    else {
      printf(\"\\ninvalid type for 'slurp'\\n\");
      abort();
    }

    FILE *file = fopen(arg0Str, \"r\");
    fseek(file, 0, SEEK_END);
    int64_t buffSize = ftell(file);
    fseek(file, 0, SEEK_SET);
    String *strVal = (String *)GC_malloc(sizeof(String) + buffSize + 10);
    strVal->type = StringType;
    strVal->len = buffSize;
    fread(strVal->buffer, 1, buffSize, file);
    fclose(file);
    return((Value *)strVal);\n"))

;; should definitely generate this programmatically
(defn fn-apply [x args]
  (inline-text "List *argList = (List *)arg1;
                     FnArity *_arity = findFnArity(arg0, argList->len);

                     if (_arity == (FnArity *)0) {
                       fprintf(stderr, \"\\n*** no arity found to apply\\n\");
                       abort();
                     } else if(_arity->variadic) {
                       FnType1 *_fn = (FnType1 *)_arity->fn;
                       return(_fn(_arity->closures, arg1));
                   ")
  (inline-text "} else if (argList->len == 1) {
                       FnType1 *_fn = (FnType1 *)_arity->fn;
                       Value *appArg0 = argList->head;
                       return(_fn(_arity->closures, appArg0));
                   ")
  (inline-text "} else if (argList->len == 2) {
                       FnType2 *_fn = (FnType2 *)_arity->fn;
                       Value *appArg0 = argList->head;
                       argList = argList->tail;
                       Value *appArg1 = argList->head;
                       return(_fn(_arity->closures, appArg0, appArg1));
                   ")
  (inline-text "} else if (argList->len == 3) {
                       FnType3 *_fn = (FnType3 *)_arity->fn;
                       Value *appArg0 = argList->head;
                       argList = argList->tail;
                       Value *appArg1 = argList->head;
                       argList = argList->tail;
                       Value *appArg2 = argList->head;
                       return(_fn(_arity->closures, appArg0, appArg1, appArg2));
                   ")
  (inline-text "} else if (argList->len == 4) {
                       FnType4 *_fn = (FnType4 *)_arity->fn;
                       Value *appArg0 = argList->head;
                       argList = argList->tail;
                       Value *appArg1 = argList->head;
                       argList = argList->tail;
                       Value *appArg2 = argList->head;
                       argList = argList->tail;
                       Value *appArg3 = argList->head;
                       return(_fn(_arity->closures, appArg0, appArg1, appArg2, appArg3));
                   ")
  (inline-text "} else if (argList->len == 5) {
                       FnType5 *_fn = (FnType5 *)_arity->fn;
                       Value *appArg0 = argList->head;
                       argList = argList->tail;
                       Value *appArg1 = argList->head;
                       argList = argList->tail;
                       Value *appArg2 = argList->head;
                       argList = argList->tail;
                       Value *appArg3 = argList->head;
                       argList = argList->tail;
                       Value *appArg4 = argList->head;
                       return(_fn(_arity->closures, appArg0, appArg1, appArg2, appArg3,
                                                    appArg4));
                   ")
  (inline-text "} else if (argList->len == 6) {
                       FnType6 *_fn = (FnType6 *)_arity->fn;
                       Value *appArg0 = argList->head;
                       argList = argList->tail;
                       Value *appArg1 = argList->head;
                       argList = argList->tail;
                       Value *appArg2 = argList->head;
                       argList = argList->tail;
                       Value *appArg3 = argList->head;
                       argList = argList->tail;
                       Value *appArg4 = argList->head;
                       argList = argList->tail;
                       Value *appArg5 = argList->head;
                       return(_fn(_arity->closures, appArg0, appArg1, appArg2, appArg3,
                                                    appArg4, appArg5));
                   ")
  (inline-text "} else if (argList->len == 7) {
                       FnType7 *_fn = (FnType7 *)_arity->fn;
                       Value *appArg0 = argList->head;
                       argList = argList->tail;
                       Value *appArg1 = argList->head;
                       argList = argList->tail;
                       Value *appArg2 = argList->head;
                       argList = argList->tail;
                       Value *appArg3 = argList->head;
                       argList = argList->tail;
                       Value *appArg4 = argList->head;
                       argList = argList->tail;
                       Value *appArg5 = argList->head;
                       argList = argList->tail;
                       Value *appArg6 = argList->head;
                       return(_fn(_arity->closures, appArg0, appArg1, appArg2, appArg3,
                                                    appArg4, appArg5, appArg6));
                   ")
  (inline-text "} else if (argList->len == 8) {
                       FnType8 *_fn = (FnType8 *)_arity->fn;
                       Value *appArg0 = argList->head;
                       argList = argList->tail;
                       Value *appArg1 = argList->head;
                       argList = argList->tail;
                       Value *appArg2 = argList->head;
                       argList = argList->tail;
                       Value *appArg3 = argList->head;
                       argList = argList->tail;
                       Value *appArg4 = argList->head;
                       argList = argList->tail;
                       Value *appArg5 = argList->head;
                       argList = argList->tail;
                       Value *appArg6 = argList->head;
                       argList = argList->tail;
                       Value *appArg7 = argList->head;
                       return(_fn(_arity->closures, appArg0, appArg1, appArg2, appArg3,
                                                    appArg4, appArg5, appArg6, appArg7));
                   ")
  (inline-text "} else if (argList->len == 9) {
                       FnType9 *_fn = (FnType9 *)_arity->fn;
                       Value *appArg0 = argList->head;
                       argList = argList->tail;
                       Value *appArg1 = argList->head;
                       argList = argList->tail;
                       Value *appArg2 = argList->head;
                       argList = argList->tail;
                       Value *appArg3 = argList->head;
                       argList = argList->tail;
                       Value *appArg4 = argList->head;
                       argList = argList->tail;
                       Value *appArg5 = argList->head;
                       argList = argList->tail;
                       Value *appArg6 = argList->head;
                       argList = argList->tail;
                       Value *appArg7 = argList->head;
                       argList = argList->tail;
                       Value *appArg8 = argList->head;
                       return(_fn(_arity->closures, appArg0, appArg1, appArg2, appArg3,
                                                    appArg4, appArg5, appArg6, appArg7,
                                                    appArg8));
                     } else {
                       printf(\"error in 'fn-apply'\\n\");
                       abort();
                     }
                   "))

(defn write [str]
  (new-sm (fn [s]
            (list (print str) s))))

(defn write-strs [str-list]
  (cond
   (= 0 (count str-list)) (state-maybe "")
   (new-sm (fn [s]
             (list (map str-list print) s)))))

(defn gensym [pre]
  (for [sym-count (get-val :gensym-count 0)
        _ (set-val :gensym-count (inc sym-count))]
    (symbol (str pre sym-count))))

(defn genlocal [pre]
  (for [sym-count (get-val :local-sym-count 0)
        _ (set-val :local-sym-count (inc sym-count))]
    (symbol (str pre sym-count))))

(defprotocol AST
  (emit-c [ast]
    (state-maybe ast)))

(defn inline-ast [txt]
  (free (reify
          AST
          (emit-c [_]
            (state-maybe (list "" (list txt)))))))

(defn local-sym [sym]
  (for [sym-val (get-in-val (list :local-syms sym))]
    (list sym-val empty-list)))

(defn closed-over-sym [sym]
  (for [sym-val (get-in-val (list :context sym))
        closed-over (get-val :closed-over empty-list)
        :let [closure-sym (reduce closed-over :not-found
                                  (fn [found? c]
                                    (cond
                                     (= sym (nth c 1)) (nth c 0)
                                     found?)))]
        closure-sym (cond
                     (= closure-sym :not-found) (for [closure-sym (genlocal "val")
                                                      _ (update-in-val (list :closed-over)
                                                                       (fn [closures]
                                                                         (cons (list closure-sym sym)
                                                                               closures)))]
                                                  closure-sym)
                     (state-maybe closure-sym))]
    (list closure-sym empty-list)))

(defn defined-sym [sym]
  (for [sym-val (get-in-val (list :defined-syms sym))]
    (list (nth sym-val 1) empty-list)))

(defn core-sym [sym]
  (for [ext-ref (get-in-val (list :core-defined-syms sym))
        _ (assoc-in-val (list :defined-syms sym) ext-ref)
        _ (update-in-val (list :new-externs)
                         (fn [externs]
                           (cons (nth ext-ref 0) externs)))]
    (list (nth ext-ref 1) empty-list)))

;; A symbol can be a local, from the context, from the dictionary or
;; from the core
(defn lookup-sym [sym]
  (comp (local-sym sym)
        (closed-over-sym sym)
        (defined-sym sym)
        (core-sym sym)
        (new-sm (fn [s]
                  (print-err "Undefined symbol:" sym "at" (get s :file-name "") ":" (get s :line-num ""))
                  (abort)))))

(defn symbol-ast [sym]
  (free (reify
          AST
          (emit-c [_]
            (lookup-sym sym)))))

(defn keyword-ast [kw]
  (free (reify
          AST
          (emit-c [_]
            ;; TODO: check to see if the keyword was defined in the core
            (for [static-kw (get-in-val (list :keywords kw))]
              (list (str "(Value *)&" static-kw) empty-list))))))

(defn const-number-ast [num]
  (free (reify
          AST
          (emit-c [_]
            ;; TODO: check to see if the number was defined in the core
            (for [static-num (get-in-val (list :numbers num))]
              (list (str "(Value *)&" static-num) empty-list))))))

(defn const-string-ast [const-str]
  (free (reify
          AST
          (emit-c [ast]
            ;; TODO: check to see if the string was defined in the core
            (for [static-str (get-in-val (list :strings const-str) :no-static-str)]
              (list (str "(Value *)&" static-str) empty-list))))))

(defn reset-fn-context []
  (for [locals (get-val :local-syms {})
        _ (set-val :local-syms {})
        local-sym-count (get-val :local-sym-count 0)
        _ (set-val :local-sym-count 0)
        context (get-val :context {})
        _ (set-val :context (merge context locals))
        closed-over (get-val :closed-over empty-list)
        _ (set-val :closed-over empty-list)]
    (list locals local-sym-count context closed-over)))

(defn restore-fn-context [fn-context]
  (let [locals (nth fn-context 0 {})
        local-sym-count (nth fn-context 1 0)
        context (nth fn-context 2 {})
        closed-over (nth fn-context 3 empty-list)]
    (apply-to list
              (set-val :context context)
              (set-val :local-syms locals)
              (set-val :local-sym-count local-sym-count)
              (set-val :closed-over closed-over))))

(defn emit-closures []
  (for [closures (get-val :closed-over empty-list)
        _ (write-strs (flat-map (reverse closures)
                                (fn [closure]
                                  (list "Value *" (first closure)
                                        " = closures->head;\\n"
                                        "if (closures->tail)\\nclosures->tail->len = closures->len - 1;\\n"
                                        "closures = closures->tail;\\n"))))]
    ""))

(defn emit-body [body-exprs]
  (let [result-sym (nth body-exprs 0 "")
        stmts (nth body-exprs 1 empty-list)]
    (apply-to list
              (write-strs stmts)
              (cond
               (= result-sym "") (state-maybe "")
               (write (str "return (" result-sym ");\\n"))))))

(defn static-arity [arity-fn-sym arg-syms variadic]
  (state-maybe (list (str "&(FnArity){" (count arg-syms) ", (List *)0, " variadic ", " arity-fn-sym "}")
                     empty-list
                     (cond
                      variadic {:variadic arity-fn-sym}
                      {(count arg-syms) arity-fn-sym}))))

(defn arity-closes-over [arity-sym arity-fn-sym arg-syms closures variadic]
  (for [closed-over (apply* (state-maybe list)
                            (map closures
                                 (fn [closure]
                                   (for [c-sym (lookup-sym (nth closure 1 ""))]
                                     (str arity-sym "->closures = listCons((Value *)"
                                          (first c-sym)
                                          ", (List *)" arity-sym "->closures);\\n")))))]
    (list arity-sym
          (list* (str "FnArity *" arity-sym " = (FnArity *)GC_malloc(sizeof(FnArity));\\n")
                 (str arity-sym "->count = " (count arg-syms) ";\\n")
                 (str arity-sym "->closures = empty_list;\\n")
                 (str arity-sym "->variadic = " variadic ";\\n")
                 (str arity-sym "->fn = " arity-fn-sym ";\\n")
                 closed-over))))

(defn emit-externs []
  (for [externs (get-val :new-externs empty-list)
        _ (write-strs (map externs (fn [ext] (str "extern " ext ";\\n"))))
        _ (set-val :new-externs empty-list)

        static-fns (get-in-val (list :statics :new-static-fns) empty-list)
        _ (write-strs static-fns)
        _ (assoc-in-val (list :statics :new-static-fns) empty-list)]
    ""))

(defn eval-exprs [ast]
  (for [exprs (evaluate ast emit-c)]
    (reduce exprs empty-list
            (fn [result expr]
              (let [result-stmts (nth result 1 empty-list)
                    expr-sym (nth expr 0 "")
                    expr-stmts (nth expr 1 empty-list)]
                (list expr-sym (comp result-stmts expr-stmts)))))))

(defn gen-arg-syms [args]
  (cond
   (< 0 (count args))
   (apply* (state-maybe list)
           (map (range (count args))
                (fn [arg-index]
                  (let [c-sym (str "arg" arg-index)]
                    (for [_ (assoc-in-val (list :local-syms (nth args arg-index "")) c-sym)]
                      c-sym)))))

   (state-maybe empty-list)))

(defn variadic-arity-ast [args body]
  (free (reify
          AST
          (emit-c [_]
            (let [c-args (list "closures" "varArgs")
                  arg-count (count args)]
              (for [arity-fn-sym (gensym "arityImpl_")
                    arity-sym (genlocal "arity_")
                    fn-context (reset-fn-context)
                    arg-syms (gen-arg-syms args)
                    body-exprs (eval-exprs body)
                    _ (emit-externs)
                    _ (write-strs (list*
                                   (str "Value *" arity-fn-sym "(List *closures, Value *varArgs) {\\n")
                                   "List *argsList = (List *)varArgs;\\n"
                                   (map (range arg-count)
                                        (fn [index]
                                          (let [c-sym (nth arg-syms index "")]
                                            (cond
                                             (< (inc index) arg-count)
                                             (str "Value *" c-sym
                                                  " = argsList->head;\\n"
                                                  "if (argsList->tail) argsList->tail->len = argsList->len - 1;\\n"
                                                  "argsList = argsList->tail;\\n")

                                             (str "Value *" c-sym " = (Value *)argsList;\\n")))))))

                    _ (apply-to list
                                (emit-closures)
                                (emit-body body-exprs)
                                (write "};\\n"))
                    closures (get-val :closed-over empty-list)
                    _ (restore-fn-context fn-context)
                    result (cond
                            (< 0 (count closures)) (arity-closes-over arity-sym arity-fn-sym
                                                                      c-args closures 1)
                            (static-arity arity-fn-sym c-args 1))]
                result))))))

(defn fn-arity-ast [args body]
  (free (reify
          AST
          (emit-c [_]
            (for [arity-fn-sym (gensym "arityImpl_")
                  arity-sym (genlocal "arity_")
                  fn-context (reset-fn-context)
                  arg-syms (gen-arg-syms args)
                  body-exprs (eval-exprs body)

                  _ (emit-externs)
                  _ (apply-to list
                              (write (str "Value *" arity-fn-sym "("))
                              (write-strs (interpose (cons "List *closures"
                                                           (map arg-syms (fn [arg] (str "Value *" arg))))
                                                     ", "))
                              (write ") {\\n")
                              (emit-closures)
                              (emit-body body-exprs)
                              (write "};\\n\\n"))
                  closures (get-val :closed-over empty-list)
                  _ (restore-fn-context fn-context)
                  result (cond
                          (< 0 (count closures)) (arity-closes-over arity-sym arity-fn-sym
                                                                    arg-syms closures 0)
                          (static-arity arity-fn-sym arg-syms 0))]
              result)))))

(defn main-ast [args body]
  (free (reify
          AST
          (emit-c [_]
            (for [main-sym (gensym "main_")
                  _ (set-val :main-sym main-sym)
                  arg-syms (gen-arg-syms args)
                  _ (set-val :local-sym-count 0)
                  body (eval-exprs body)
                  _ (write (str "\\nint " main-sym " ("))
                  _ (write-strs (interpose (map arg-syms (fn [arg] (str "Value *" arg)))
                                            ", "))
                  _ (write ") {\\n")
                  _ (write-strs (nth body 1 empty-list))
                  _ (write "\\nreturn(0);\\n}\\n\\n")]
              "")))))

(defn eval-args [args]
  (for [evalled (apply* (state-maybe list) (map args (fn [arg-ast]
                                                       (evaluate arg-ast emit-c))))]
    (reduce evalled (list empty-list empty-list)
            (fn [results evalled]
              (let [syms (nth results 0 empty-list)
                    stmts (nth results 1 empty-list)
                    sym (nth evalled 0 :no-arg-sym)
                    evalled-stmts (nth evalled 1 empty-list)]
                (list (comp syms (list sym))
                      (comp stmts evalled-stmts)))))))

(defn get-core-sym [fn-sym]
  (comp (get-in-val (list :defined-syms fn-sym))
        (for [v (get-in-val (list :core-defined-syms fn-sym))
              _ (assoc-in-val (list :defined-syms fn-sym) v)
              _ (update-in-val (list :new-externs)
                               (fn [externs]
                                 (cons (first v) externs)))]
          v)))

(defn core-static-fn [target-sym num-args]
  (let [args (cons "List *" (cond
                             (= 0 num-args) empty-list
                             (= :variadic num-args) (list "Value *")
                             (map (range num-args)
                                  (fn [index]
                                    "Value *"))))
        args (apply str (interpose args ", "))]
    (for [arity-sym (get-in-val (list :core-static-fns target-sym num-args))
          _ (update-in-val (list :statics :new-static-fns)
                           (fn [s-fns]
                             (cons (str "Value *" arity-sym "(" args ");\\n") s-fns)))]
      arity-sym)))

(defn lookup-static-fn [target-sym num-args]
  (comp (get-in-val (list :static-fns target-sym num-args))
        (core-static-fn target-sym num-args)))

(defn call-dynamic-fn [target args]
  (let [target-sym (nth target 0 "")
        target-stmts (nth target 1 empty-list)
        arg-stmts (nth args 1 empty-list)
        args (nth args 0 empty-list)
        num-args (count args)]
    (for [arity-sym (genlocal "arity")
          variadic-sym (genlocal "varArgs")
          fn-sym (genlocal "fn")
          result-sym (genlocal "rslt")
          invoke-sym (get-core-sym 'invoke)
          invoke-arity-sym (lookup-static-fn (nth invoke-sym 1) 2)]
      (let [arg-syms (cons (str arity-sym "->closures") args)]
        (list result-sym
              (comp target-stmts
                    arg-stmts
                    (list (str "Value *" result-sym ";\\n"
                               "if((" target-sym ")->type != " (get (types) 'Function :no-fn-type) ") {\\n"

                               ;; TODO: currently hard coded for just 2
                               ;; arguments to 'invoke'
                               (cond
                                (< 0 num-args)
                                (str result-sym " = " invoke-arity-sym "(empty_list, " target-sym ", (Value *)"
                                     (nth arg-syms 1 "") ");\\n")

                                (str "printf(\\\"calling a non-function\\\\n\\\");\\n abort();\\n"))
                               "} else {\\n"

                               "FnArity *" arity-sym " = findFnArity(" target-sym ", " num-args ");\\n"
                               "if(" arity-sym " != (FnArity *)0 && !" arity-sym "->variadic) {\\n"
                               "FnType" num-args " *" fn-sym " = (FnType" num-args " *)" arity-sym "->fn;\\n"
                               result-sym " = " fn-sym "(" (apply str (interpose arg-syms ", ")) ");\\n"
                               "} else if(" arity-sym " != (FnArity *)0 && " arity-sym "->variadic) {\\n"
                               "FnType1 *" fn-sym " = (FnType1 *)" arity-sym "->fn;\\n"
                               "List *" variadic-sym " = (List *)GC_malloc(sizeof(List));\\n"
                               variadic-sym "->type  = ListType;\\n"
                               variadic-sym "->len = 0;\\n"
                               variadic-sym "->head = (Value *)0;\\n"
                               variadic-sym "->tail = (List *)0;\\n"
                               (reduce (reverse (rest arg-syms)) ""
                                       (fn [arg-list arg-sym]
                                         (str arg-list
                                              variadic-sym " = (List *)listCons("
                                              "(Value *)" arg-sym
                                              ", " variadic-sym ");\\n")))
                               result-sym " = " fn-sym "(" (first arg-syms) ", (Value *)" variadic-sym ");\\n"
                               "} else {\\nfprintf(stderr, \\\"\\\\n*** no arity found for '%s'.\\\\n\\\", "
                               "((Function *)" target-sym ")->name"
                               ");\\n  abort();\\n}\\n}\\n"))))))))

(defn call-static-fixed [target args]
  (let [target-sym (nth target 0 "")
        target-stmts (nth target 1 empty-list)
        arg-stmts (nth args 1 empty-list)
        args (nth args 0 empty-list)
        num-args (count args)]
    (for [arity-sym (lookup-static-fn target-sym num-args)
          empty-list (get-core-sym 'empty-list)
          result-sym (genlocal "rslt")]
      (let [arg-syms (cons (str "(List *)" (nth empty-list 1)) args)]
        (list result-sym
              (comp target-stmts
                    arg-stmts
                    (list (str Value* result-sym " = " arity-sym "("
                               (apply str (interpose arg-syms ", ")) ");\\n"))))))))

(defn call-static-variadic [target args]
  (let [target-sym (nth target 0 "")
        target-stmts (nth target 1 empty-list)
        arg-stmts (nth args 1 empty-list)
        args (nth args 0 empty-list)
        num-args (count args)]
    (for [arity-sym (lookup-static-fn target-sym :variadic)
          empty-list (get-core-sym 'empty-list)
          variadic-sym (genlocal "varArgs")
          result-sym (genlocal "rslt")]
      (let [arg-syms (cons (str "(List *)" (nth empty-list 1)) args)]
        (list result-sym
              (comp target-stmts
                    arg-stmts
                    (list (str "List *" variadic-sym " = (List *)GC_malloc(sizeof(List));\\n"
                               variadic-sym "->type  = ListType;\\n"
                               variadic-sym "->len = 0;\\n"
                               variadic-sym "->head = (Value *)0;\\n"
                               variadic-sym "->tail = (List *)0;\\n"
                               (reduce (reverse (rest arg-syms)) ""
                                       (fn [arg-list arg-sym]
                                         (str arg-list
                                              variadic-sym " = (List *)listCons("
                                              "(Value *)" arg-sym
                                              ", " variadic-sym ");\\n")))
                               Value* result-sym " = " arity-sym "(" (first arg-syms) ", (Value *)"
                               variadic-sym ");\\n"))))))))

(defn call-ast [callee params]
  (free (reify
          AST
          (emit-c [_]
            ;; TODO: check for recursive call to same arity
            (for [target (evaluate callee emit-c)
                  args (eval-args params)
                  result (comp (call-static-fixed target args)
                               (call-static-variadic target args)
                               (call-dynamic-fn target args))]
              result)))))

(defn binding-ast [binding val]
  (free (reify
          AST
          (emit-c [_]
            (for [evalled (evaluate val emit-c)
                  _ (assoc-in-val (list :local-syms binding) (nth evalled 0 ""))]
              (list "" (nth evalled 1 empty-list)))))))

(defn let-ast [bindings body]
  (free (reify
          AST
          (emit-c [_]
            (for [locals (get-val :local-syms {})
                  bindings (evaluate bindings emit-c)
                  body-exprs (eval-exprs body)
                  _ (set-val :local-syms locals)]
              (let [binding-stmts (apply comp (map bindings
                                                   (fn [binding]
                                                     (nth binding 1 empty-list))))
                    result-sym (nth body-exprs 0 "")
                    body-stmts (nth body-exprs 1 empty-list)]
                (list result-sym (comp binding-stmts body-stmts))))))))

(defn fn-ast [name arities]
  (free (reify
          AST
          (emit-c [_]
            (let [arity-count (count arities)]
              (for [fn-sym (gensym "fn_")
                    _ (write (str "\\n// --------- " name " --------------\\n"))
                    _ (write (str "Function " fn-sym ";\\n"))
                    ;; TODO: check for anan fn, save previous value of
                    ;; :defined-sym and restore at end
                    _ (assoc-in-val (list :defined-syms name) (list (str "Function " fn-sym)
                                                                    (str "(Value *)&" fn-sym)))
                    arity-vals (apply* (state-maybe list)
                                       (map arities
                                            (fn [arity]
                                              (evaluate arity emit-c))))
                    :let [arity-syms (map arity-vals (fn [av]
                                                       (nth av 0 "")))
                          arity-init (apply comp (map arity-vals
                                                      (fn [av]
                                                        (nth av 1 empty-list))))
                          static-arities (apply merge (map arity-vals
                                                           (fn [av]
                                                             (nth av 2 {}))))]
                    _ (cond
                       (= 0 (count arity-init))
                       (apply-to list
                                 (write (str "\\n// --------- " name " main body --------------\\n"))
                                 (write (str "Function " fn-sym " = {"
                                             (get (types) 'Function :no-fn-type) ", \\\""
                                             name "\\\", " arity-count ", "
                                             "{" (apply str (interpose arity-syms ", ")) "}};\\n"))
                                 (assoc-in-val (list :static-fns (str "(Value *)&" fn-sym)) static-arities))

                       (state-maybe ""))]
                (cond
                 (= 0 (count arity-init))
                 (list (str "(Value *)&" fn-sym) empty-list (str "Function " fn-sym))

                 (list (str "(Value *)" fn-sym)
                       (comp arity-init
                             (list* (str "Function *" fn-sym " = (Function *)GC_malloc(sizeof(Function)"
                                         " + sizeof(FnArity *) * " arity-count ");\\n")
                                    (str fn-sym "->type = " (get (types) 'Function :no-fn-type) ";\\n")
                                    (str fn-sym "->name = \\\"" name "\\\";\\n")
                                    (str fn-sym "->arityCount = " arity-count ";\\n")
                                    (map (range arity-count)
                                         (fn [index]
                                           (str fn-sym "->arities[" index "] = "
                                                (nth arity-syms index "") ";\\n")))))
                       (str "Function " fn-sym)))))))))

(defn emit-static-sym [sym]
  (for [sym-val (get-in-val (list :symbols sym) :no-static-sym)]
    (let [_ (cond
             (= :no-static-sym sym-val) (print-err "// not found" sym)
             "")]
      (list (str "(Value *)&" sym-val) empty-list))))

(defn quoted-ast [sym]
  (free (reify
          AST
          (emit-c [_]
            (emit-static-sym sym)))))

(defn forward-decl [name value]
  (cond
   (= :no-value value)
   (for [c-name (gensym "var_")
         _ (write-strs (list (str "// forward declaration for '" name "'\\n")
                             (str Value* c-name ";\\n\\n")))
         _ (assoc-in-val (list :defined-syms name) (list "" c-name))]
     "")

   empty-list))

(defn define-fwd-decl [name value]
  (for [c-name (get-in-val (list :defined-syms name))
        evalled-expr (evaluate value emit-c)
        :let [c-name (nth c-name 1)
              result-sym (nth evalled-expr 0 "")
              initialization (nth evalled-expr 1 empty-list)
              init-count (count initialization)
              initialization (cond
                              (empty? initialization) (list "")
                              initialization)]
        _ (cond
           (= result-sym "") (write (str "Value *" c-name " = " (first initialization)))
           (< 1 init-count) (state-maybe (let [_ (print-err (str "invalid definition: " name))]
                                           (abort)))
           (apply-to list
                     (write (first initialization))
                     (write (str Value* c-name " = " result-sym ";\\n"))))]
    ""))

(defn inline-text-definition [name initialization]
  (for [c-name (gensym "var_")
        _ (write (str Value* c-name " = " (first initialization) ";\\n"))
        _ (assoc-in-val (list :defined-syms name) (list (str "Value *" c-name ";")
                                                        c-name))]
    c-name))

(defn expression-definition [name result-sym initialization extern-def]
  (let [extern-def (cond
                    (= :no-extern extern-def) ""
                    extern-def)]
    (for [c-name (gensym "var_")
          _ (cond
             (< 0 (count initialization)) (write (first initialization))
             (state-maybe ""))
          _ (assoc-in-val (list :defined-syms name) (list extern-def result-sym))]
      c-name)))

(defn define-value [name value]
  (for [evalled-expr (evaluate value emit-c)
        :let [result-sym (nth evalled-expr 0 "")
              initialization (nth evalled-expr 1 empty-list)
              extern-def (nth evalled-expr 2 :no-extern)]
        _ (cond
           (= result-sym "") (inline-text-definition name initialization)
           (< 1 (count initialization)) (state-maybe (let [_ (print-err (str "invalid definition: " name))]
                                                       (abort)))
           (expression-definition name result-sym initialization extern-def))]
    ""))

(defn definition-ast [name value]
  (free (reify
          AST
          (emit-c [_]
            (cond
             (= :no-value value) (forward-decl name value)
             (comp (define-fwd-decl name value)
                   (define-value name value)))))))

(defn eval-cond-clause [clauses default cond-result]
  (cond
   (empty? clauses)
   (state-maybe
    (let [clause-result (nth default 0 "")
          default-stmts (nth default 1 empty-list)]
      (list cond-result
            (comp default-stmts
                  (list (str cond-result " = " (nth default 0 "") ";\\n"))))))

   (let [clause (first clauses)]
     (for [test (evaluate (first clause) emit-c)
           clause-result (evaluate (nth clause 1) emit-c)
           cond-rest (eval-cond-clause (rest clauses) default cond-result)]
       (let [test-sym (nth test 0 "")
             test-stmts (nth test 1 empty-list)
             clause-sym (nth clause-result 0 "")
             clause-stmts (nth clause-result 1 empty-list)]
         (list cond-result
               (comp test-stmts
                     (list (str "\\nif (isTrue(" test-sym ")) {\\n"))
                     clause-stmts
                     (list (str cond-result " = " clause-sym ";\\n} else {\\n"))
                     (nth cond-rest 1 empty-list)
                     (list "}\\n"))))))))

(defn cond-ast [clauses default]
  (free (reify
          AST
          (emit-c [_]
            (for [cond-result (genlocal "cond")
                  default (evaluate default emit-c)
                  evalled-clauses (eval-cond-clause clauses default cond-result)]
              (let [cond-stmts (nth evalled-clauses 1 empty-list)]
                (list cond-result (cons (str "Value *" cond-result ";\\n")
                                        cond-stmts))))))))

(defn emit-extension [type-num proto]
  (for [_ (apply* (state-maybe list)
                  (map (nth proto 1 empty-list)
                       (fn [impl]
                         (let [impl-fn (nth impl 1 "")]
                           (for [ext-fn (evaluate impl-fn emit-c)
                                 _ (write-strs (nth ext-fn 1 empty-list))
                                 _ (assoc-in-val (list :protocols (first impl)
                                                       :impls type-num)
                                                 (first ext-fn))]
                             "")))))]
    (list "" empty-list)))

(defn extend-ast [type impls]
  (free (reify
          AST
          (emit-c [_]
            (for [type-num (get-in-val (list :types type) :no-type)
                  _ (apply* (state-maybe list)
                            (map (seq impls)
                                 (partial emit-extension type-num)))]
              "")))))

(defn emit-reified-fn [name-asts type-num index]
  (let [name-ast (nth name-asts index :no-name-ast)
        name (nth name-ast 0 "")
        ast (nth name-ast 1 :no-ast)]
    (for [evalled (evaluate ast emit-c)
          num-args (get-in-val (list :protocols name :num-args) 0)
          impl-sym (gensym "protoImpl_")
          fn-sym (gensym "protoFn_")
          :let [_ (cond (= 0 num-args)
                        (let [_ (print-err "invalid protocol fn spec for" name)]
                          (abort))
                        :nothing)
                args (map (range num-args) (fn [idx] (str "arg" idx)))
                arg-decls (apply str (interpose (cons (str ListVal* "closures")
                                                      (map args (fn [arg] (str Value* arg))))
                                                ", "))
                args (apply str (interpose (cons "closures" args) ", "))]
          _ (write (str Value* impl-sym "(" arg-decls ") {\\n"
                        FnArity* "arityPtr = ((Function *)((ReifiedVal *)arg0)->impls["
                        index "])->arities[0];\\n"
                        "return (((FnType" num-args " *)arityPtr->fn)(arityPtr->" args "));\\n};\\n\\n"))
          _ (write (str "Function " fn-sym " = {3, \\\"" name
                        "\\\", 1, {&(FnArity){" num-args
                        ", (List *)0, 0, " impl-sym"}}};\\n\\n"))
          _ (assoc-in-val (list :protocols name :impls type-num) (str "(Value *)&" fn-sym))]
      evalled)))

(defn reified-type [type-num impl-fns]
  (for [reified-sym (genlocal "reified_")
        _ (state-maybe "")]
    (let [inits (apply comp (map impl-fns (fn [sym-inits]
                                            (nth sym-inits 1 empty-list))))
          impls-syms (map impl-fns (fn [sym-inits] (nth sym-inits 0 "")))
          reify-init (list* (str ReifiedVal* reified-sym " = (ReifiedVal *)GC_malloc(sizeof("
                                 "ReifiedVal) + sizeof(Function *) * "
                                 (count impls-syms) ");\\n")
                            (str reified-sym "->type = " type-num ";\\n")
                            (str reified-sym "->implCount = " (count impl-fns) ";\\n")
                            (map (range (count impl-fns))
                                 (fn [index]
                                   (let [sym-init (nth impl-fns index empty-list)
                                         sym (nth sym-init 0 "")]
                                     (str reified-sym "->impls[" index "] = " sym ";\\n")))))]
      (list (str "(Value *)" reified-sym)
            (comp inits reify-init)))))

(defn static-reified [type-num impl-fns]
  (for [reified-sym (gensym "reified_")
        :let [fns-init (map impl-fns (fn [impl-fn]
                                       (first impl-fn)))
              reify-init (list (str "ReifiedVal " reified-sym " = {"
                                    type-num ", " (count impl-fns) ", {"
                                    (apply str (interpose fns-init ", "))
                                    "}};\\n"))]
        _ (write (first reify-init))]
    (list (str "(Value *)&" reified-sym) empty-list (list "ReifiedVal " reified-sym))))

(defn reify-ast [impls]
  (free (reify
          AST
          (emit-c [_]
            (let [protos (seq impls)
                  name-asts (apply comp (map protos (fn [proto]
                                                      (nth proto 1 empty-list))))]
              (for [types (get-val :types {})
                    :let [type-num (inc (count (seq types)))]
                    _ (assoc-in-val (list :types type-num) type-num)
                    impl-fns (apply* (state-maybe list)
                                     (map (range (count name-asts))
                                          (partial emit-reified-fn name-asts type-num)))
                    reified-result (let [inits (apply comp (map impl-fns (fn [sym-inits]
                                                                           (nth sym-inits 1 empty-list))))]
                                     (cond
                                      (= 0 (count inits))
                                      (static-reified type-num impl-fns)

                                      (reified-type type-num impl-fns)))]
                reified-result))))))

(defn write-default [default-impl]
  (cond
   (= :no-default default-impl) (state-maybe {})

   (for [default-fn (evaluate default-impl emit-c)
         _ (write-strs (nth default-fn 1 empty-list))]
     {:default (nth default-fn 0 "")})))

(defn emit-proto-fn [proto]
  (let [name (nth proto 0 "")
        arities (first (seq (nth proto 1 {0 {}})))
        num-args (nth arities 0 0)
        args (map (range num-args) (fn [idx] (str "arg" idx)))
        default-fn-ast (get (nth arities 1 {}) :default :no-default)
        args (map (range num-args) (fn [idx]
                                     (str "arg" idx)))]
    (for [c-name (gensym "protoFnImpl_")
          impls-sym (gensym "protoImpls_")
          fn-sym (gensym "protoFn_")
          _ (write (str "ProtoImpls *" impls-sym ";\\n"))
          default-impl (write-default default-fn-ast)
          arity-sym (gensym "protoFnArity_")
          _ (apply-to list
                      (write (str "Value *" c-name "("))
                      (write-strs (interpose (cons "List *closures" (map args (fn [arg] (str "Value *" arg))))
                                             ", "))
                      (write-strs (list ") {\\n"
                                        "  Function *implFn = (Function *)findProtoImpl(arg0->type, "
                                        impls-sym ");\\n"
                                        "  if(implFn == (Function *)0) {\\n"
                                        "   fprintf(stderr, \\\"\\\\n*** Could not find proto impl for '"
                                        name "' %lld\\\\n\\\", arg0->type);\\nabort();\\n}\\n"
                                        "  FnArity *_arity = findFnArity((Value *)implFn, " num-args ");\\n"
                                        "  if(_arity == (FnArity *)0 || _arity->variadic) {\\n"
                                        "    fprintf(stderr, \\\"\\\\n*** Invalid number of args in call to '"
                                        name "'\\\");\\n"
                                        "    abort();\\n}\\n"
                                        "  FnType" num-args " *_fn = (FnType" num-args " *)_arity->fn;\\n"
                                        "  return(_fn("))
                      (write-strs (interpose (cons "_arity->closures" args) ", "))
                      (write-strs (list "));\\n}\\n"
                                        "FnArity "
                                        (str arity-sym) " = {" (str num-args) ", (List *)0, 0, "
                                        (str c-name) "};\\n"
                                        "Function " (str fn-sym)  " = {3, \\\"" (str name)
                                        "\\\", 1, {&" (str arity-sym) "}};\\n\\n"))
                      (assoc-in-val (list :static-fns (str "(Value *)&" fn-sym) num-args) c-name)
                      (assoc-in-val (list :defined-syms name) (list (str "Function " fn-sym)
                                                                    (str "(Value *)&" fn-sym)))
                      (assoc-in-val (list :protocols name) {:impls-sym impls-sym
                                                            :extern-def (str "extern Function " fn-sym ";")
                                                            :impls default-impl
                                                            :num-args num-args}))]
      fn-sym)))

(defn protocol-ast [name prototypes]
  (free (reify
          AST
          (emit-c [ast]
            (apply* (state-maybe list)
                    (map (seq prototypes)
                         emit-proto-fn))))))

(defn fixed-fn-types []
  (apply* (state-maybe list)
          (map (range 10)
               (fn [arg-count]
                 (cond
                  (= arg-count 0)
                  (write (str "typedef Value *(FnType0)(List *);\\n"))

                  (apply* (state-maybe list)
                          (list (write (str "typedef Value *(FnType" arg-count ")("))
                                (write-strs (interpose (cons "List *"
                                                             (map (range arg-count)
                                                                  (fn [_] "Value *")))
                                                        ", "))
                                (write ");\\n"))))))))

(defn extern-fn [name variadic return-type & arg-types]
  (let [arg-types (comp arg-types
                        (cond
                         variadic (list "...")
                         empty-list))]
    (apply* (state-maybe list)
            (list (write (str "extern " return-type " " name "("))
                  (write-strs (interpose arg-types ", "))
                  (write ");\\n")))))

(defn extern-functions []
  (apply (state-maybe list)
         (write "\\n")
         (extern-fn 'abort 0 VoidT)
         ;; (extern-fn 'strncpy 0 Int8* Int8* Int8* Int32)
         (extern-fn 'printf 1 Int32 "const char *")
         ;; (extern-fn 'sprintf 1 Int32 Int8* Int8*)
         ;; (extern-fn 'strncmp 0 Int32 Int8* Int8* Int32)
         (extern-fn 'GC_init 0 VoidT)
         (extern-fn 'GC_malloc 0 Value* Int64)
         (extern-fn 'SHA1 0 Int8* Int8* Int32 Int8*)))

(defn core-base-fns []
  (write-strs (list "\\n"
                    "int isTrue(Value *boolVal);\\n"
                    "Value *findProtoImpl(int64_t type, ProtoImpls *impls);\\n"
                    "FnArity *findFnArity(Value *fnVal, int argCount);\\n"
                    "Value *symbolValue(char *s);\\n"
                    "Value *keywordValue(char *s);\\n"
                    "Value *stringValue(char *s);\\n"
                    "Value *makeSubstr(int64_t len, Value *str, char *subsStart);\\n"
                    "Value *numberValue(int64_t n);\\n"
                    "List *listCons(Value *x, List *l);\\n"
                    "Value *counts();\\n"
                    "Value *protocols();\\n"
                    "Value *static_fns();\\n"
                    "Value *defined_syms();\\n")))

(defn base-fns []
  (write-strs (list "\\n"
                    "Number trueVal = {NumberType, 1};\\n"
                    "Value* true = (Value *)&trueVal;\\n"
                    "Number falseVal = {NumberType, 0};\\n"
                    "Value* false = (Value *)&falseVal;\\n"
                    "\\n"
                    "int isTrue(Value *boolVal) {\\n"
                    "if (boolVal->type != " (get (types) 'Number 99) ") {\\n"
                    "printf(\\\"Invalid boolean value\\\\n"
                    "\\\");\\nabort();\\n}\\nelse\\nreturn (((Number *)boolVal)->numVal);\\n}\\n"
                    "\\n"
                    "Value *findProtoImpl(int64_t type, ProtoImpls *impls) {\\n"
                    "int64_t implIndex = 0;\\n"
                    "while(implIndex < impls->implCount) {\\n"
                    "if (type != impls->impls[implIndex].type) {\\n"
                    "implIndex++;\\n"
                    "} else\\n"
                    "return(impls->impls[implIndex].implFn);\\n"
                    "}\\n"
                    "return(impls->defaultImpl);\\n"
                    "};\\n\\n"
                    "FnArity *findFnArity(Value *fnVal, int argCount) {\\n"
                    "Function *fn = (Function *)fnVal;\\n"
                    "int arityIndex = 0;\\n"
                    "FnArity *arity = (FnArity *)fn->arities[arityIndex];\\n"
                    "FnArity *variadic = (FnArity *)0;\\n"
                    "while(arityIndex < fn->arityCount) {\\n"
                    "arity = (FnArity *)fn->arities[arityIndex];\\n"
                    "if (arity->variadic) {\\n"
                    "variadic = arity;\\n"
                    "arityIndex++;\\n"
                    "} else if (arity->count != argCount) {\\n"
                    "arityIndex++;\\n"
                    "} else\\n"
                    "return(arity);\\n"
                    "}\\n"
                    "return(variadic);\\n"
                    "};\\n\\n"
                    "\\n"
                    "Value *symbolValue(char *s) {\\n"
                    "SymKey *sym = (SymKey *)GC_malloc(sizeof(SymKey));\\n"
                    "sym->type = SymbolType;\\n"
                    "sym->name = s;\\n"
                    "return((Value *)sym);\\n"
                    "};\\n"
                    "\\n"
                    "Value *keywordValue(char *s) {\\n"
                    "SymKey *kw = (SymKey *)GC_malloc(sizeof(SymKey));\\n"
                    "kw->type = KeywordType;\\n"
                    "kw->name = s;\\n"
                    "return((Value *)kw);\\n"
                    "};\\n"
                    "\\n"
                    "Value *stringValue(char *s) {\\n"
                    "int64_t len = strlen(s);\\n"
                    "String *strVal = (String *)GC_malloc(sizeof(String) + len + 4);\\n"
                    "strVal->type = StringType;\\n"
                    "strVal->len = strlen(s);\\n"
                    "strncpy(strVal->buffer, s, len);\\n"
                    "return((Value *)strVal);\\n"
                    "};\\n"
                    "\\n"
                    "Value *makeSubstr(int64_t len, Value *str, char *subsStart) {\\n"
                    "SubString *subStr = (SubString *)GC_malloc(sizeof(SubString));\\n"
                    "subStr->type = SubStringType;\\n"
                    "subStr->len = len;\\n"
                    "subStr->source = str;\\n"
                    "subStr->buffer = subsStart;\\n"
                    "return((Value *)subStr);}\\n"
                    "\\n"
                    "Value *numberValue(int64_t n) {\\n"
                    "Number *numVal = (Number *)GC_malloc(sizeof(Number));\\n"
                    "numVal->type = NumberType;\\n"
                    "numVal->numVal = n;\\n"
                    "return((Value *)numVal);\\n"
                    "};\\n"
                    "\\n"
                    "List *listCons(Value *x, List *l) {\\n"
                    "if (l->type != ListType) {\\n"
                    "printf(\\\"'cons' requires a list\\\n\\\");\\n"
                    "abort();\\n"
                    "}\\n"
                    "List *newList = (List *)GC_malloc(sizeof(List));\\n"
                    "List *oldList = (List *)l;\\n"
                    "newList->type = ListType;\\n"
                    "newList->len = oldList->len + 1;\\n"
                    "newList->head = (Value *)x;\\n"
                    "newList->tail = oldList;\\n"
                    "return(newList);\\n"
                    "};\\n"
                    "Value *counts();\\n"
                    "Value *protocols();\\n"
                    "Value *static_fns();\\n"
                    "Value *defined_syms();\\n")))

(defn bootstrap-ast []
  (free (reify
          AST
          (emit-c [_]
            (apply-to list
                      (fixed-fn-types)
                      (flat-map (get-val :types {})
                                (fn [types]
                                  (write-strs
                                   (list
                                    (str "const int64_t NumberType = " (get types 'Number 0) ";\\n")
                                    (str "const int64_t KeywordType = " (get types 'Keyword 0) ";\\n")
                                    (str "const int64_t SymbolType = " (get types 'Symbol 0) ";\\n")
                                    (str "const int64_t StringType = " (get types 'String 0) ";\\n")
                                    (str "const int64_t SubStringType = " (get types 'SubStr 0) ";\\n")
                                    (str "const int64_t ListType = " (get types 'List 0) ";\\n")
                                    (str "const int64_t FunctionType = " (get types 'Function 0) ";\\n")
                                    "List *empty_list = &(List){4,0,0,0};\\n"))))
                      (base-fns)
                      (emit-proto-fn (list 'invoke {2 {}}))
                      (write "\\nValue *counts();\\n")
                      (write "\\nValue *protocols();\\n")
                      (write "\\nValue *defined_syms();\\n")
                      (write "\\nValue *static_fns();\\n"))))))

(defn emit-impl [default impls]
  (let [default-sym (cond
                     (= default :no-default) "(Value *)0"
                     default)
        impls-strs (map impls (fn [impl]
                                (str "{" (apply str (interpose impl ", ")) "}")))]
    (apply* (state-maybe list)
            (list (write (str "{" (count impls-strs) ", " default-sym ", {"))
                  (write-strs (interpose impls-strs ", "))
                  (write "}};\\n")))))

(defn finalize-protocols []
  (for [protocols (get-val :protocols {})
        result (apply* (state-maybe list)
                       (map (seq protocols)
                            (fn [proto]
                              (let [proto-fn (nth proto 0 "")
                                    proto-impls (nth proto 1 {})
                                    impls-sym (get proto-impls :impls-sym "")
                                    impls (get proto-impls :impls {})
                                    default (get impls :default :no-default)
                                    impls (filter (seq impls)
                                                  (fn [impl]
                                                    (let [type (first impl)]
                                                      (cond
                                                       (= type :default) 0
                                                       (= type :no-type) 0
                                                       1))))]
                                (for [local-sym (gensym "localImpls_")
                                      _ (write (str "ProtoImpls " local-sym " = "))
                                      _ (emit-impl default impls)]
                                  (list impls-sym local-sym))))))]
    result))

(defn compile-expr [parser]
  (for [expr parser
        ast (analyze-expr expr)]
    ast))

(defn base-types []
  (let [types (types)]
    (write-strs (list
                 "#include <sys/types.h>\\n"
                 "#include <stdio.h>\\n"
                 "#include <string.h>\\n\\n"
                 Value
                 NumberVal
                 SymKey
                 StringVal
                 SubStringVal
                 ListVal
                 FnArity
                 FunctionVal
                 ProtoImpl
                 ProtoImpls
                 ReifiedVal
                 "List *listCons(Value *x, List *l);\\n"
                 "Value *stringValue(char *s);\\n"
                 "const int64_t NumberType;\\n"
                 "const int64_t KeywordType;\\n"
                 "const int64_t SymbolType;\\n"
                 "const int64_t StringType;\\n"
                 "const int64_t SubStringType;\\n"
                 "const int64_t ListType;\\n"
                 "const int64_t FunctionType;\\n"
                 "List *empty_list;\\n"
                 "\\n"))))

(defn const-strings [strs type]
  (let [strs (seq strs)]
    (cond
     (< 0 (count strs))
     (apply* (state-maybe list)
             (map strs (fn [const-str]
                         (let [str-ptr (nth const-str 1 "noString_ptr")
                               str-val (nth const-str 0 "noString_name")]
                           (write (str "struct {int64_t type;\\n   int64_t len;\\n   char buffer["
                                       (inc (count str-val))
                                       "];} " str-ptr " = {" type ","
                                       (count str-val) ",\\\"" str-val "\\\"};\\n"))))))

     (state-maybe ""))))

(defn static-syms [syms sym-type]
  (let [syms (seq syms)]
    (cond
     (< 0 (count syms))
     (apply* (state-maybe list)
             (map syms
                  (fn [sym]
                    (write (str "SymKey "
                                (nth sym 1 "no_symbol_val")
                                " = {"
                                sym-type
                                ",\\\""
                                (nth sym 0 "no_symbol_name")
                                "\\\"};\\n")))))

     (state-maybe ""))))

(defn static-numbers [nums num-type]
  (let [nums (seq nums)]
    (cond
     (< 0 (count nums))
     (apply* (state-maybe list)
             (map nums
                  (fn [num]
                    (write (str "Number "
                                (nth num 1 "noNumber_sym")
                                " = {"
                                num-type
                                ","
                                (nth num 0 "noNumber_val")
                                "};\\n")))))

     (state-maybe ""))))

(defn static-values []
  (let [types (types)]
    (for [strs (get-in-val (list :new-strings) empty-list)
          _ (apply-to list
                      (const-strings strs (get types 'String "no_String_type"))
                      (update-in-val (list :strings)
                                     (fn [old-strs]
                                       (merge old-strs strs)))
                      (assoc-in-val (list :new-strings) {}))

          nums (get-in-val (list :new-numbers) empty-list)
          _ (apply-to list
                      (static-numbers nums (get types 'Number "no_Number_type"))
                      (update-in-val (list :numbers)
                                     (fn [old-nums]
                                       (merge old-nums nums)))
                      (assoc-in-val (list :new-numbers) {}))

          syms (get-in-val (list :new-symbols) empty-list)
          _ (apply-to list
                      (static-syms syms (get types 'Symbol "no_Symbol_type"))
                      (update-in-val (list :symbols)
                                     (fn [old-sys]
                                       (merge old-sys syms)))
                      (assoc-in-val (list :new-symbols) {}))

          kws (get-in-val (list :new-keywords) empty-list)
          _ (apply-to list
                      (static-syms kws (get types 'Keyword "no_Keyword_type"))
                      (update-in-val (list :keywords)
                                     (fn [old-kws]
                                       (merge old-kws kws)))
                      (assoc-in-val (list :new-keywords) {}))]
      "")))

(defn emit-main []
  (for [_ (set-val :local-sym-count 0)
        main-sym (get-val :main-sym :no-main)
        :when (not (= :no-main main-sym))
        proto-syms (finalize-protocols)
        _ (write-strs (list "int main(int argc, char *argv[]) {\\n"
                            "    GC_init();"
                            "     List *argList = (List *)GC_malloc(sizeof(List));\\n"
                            "      argList->type = ListType;\\n"
                            "      argList->len = 0;\\n"
                            "      argList->head = (Value *)0;\\n"
                            "      argList->tail = (List *)0;\\n"
                            "      List *tail = argList;\\n"
                            "      for(int i = 0; i < argc; i++) {\\n"
                            "         tail->head = stringValue(argv[i]);\\n"
                            "         List *newTail = (List *)GC_malloc(sizeof(List));\\n"
                            "         newTail->type = ListType;\\n"
                            "         newTail->len = 0;\\n"
                            "         newTail->tail = (List *)0;\\n"
                            "         newTail->head = (Value *)0;\\n"
                            "         tail->head = stringValue(argv[i]);\\n"
                            "         tail->tail = newTail;\\n"
                            "         tail = newTail;\\n"
                            "         argList->len++;\\n}\\n"))
        _ (apply* (state-maybe list)
                  (map proto-syms
                       (fn [proto-sym]
                         (let [impls-sym (nth proto-sym 0 "")
                               local-sym (nth proto-sym 1 "")]
                           (write (str "  " impls-sym " = &" local-sym ";\\n"))))))
        _ (write (str "  return(" main-sym "((Value *)argList));\\n};\\n"))]
    ""))

(defn emit-exprs [s parser]
  (let [result ((for [expr (compile-expr parser)
                      _ (static-values)
                      _ (evaluate expr emit-c)]
                  "") s)]
    (cond
     (empty? result) (list "" s)
     (emit-exprs (nth result 1 {}) parser))))

(defn protocols []
  (inline-text "return(protocols());"))

(defn load-protocols []
  (let [protos (protocols)
        protos (map protos
                    (fn [proto-info]
                      (let [proto-name (nth proto-info 0)
                            impls-sym (nth proto-info 1)
                            num-args (nth proto-info 2)
                            extern-def (nth proto-info 3)
                            impls (HashMap (nth proto-info 4))]
                        (list proto-name {:impls-sym impls-sym
                                          :num-args num-args
                                          :extern-def extern-def
                                          :impls impls}))))]
    (apply* (state-maybe list)
            (comp (list (set-val :protocols (HashMap protos)))
                  (flat-map protos
                            (fn [proto]
                              (let [proto-fn-name (first proto)
                                    num-args (get (nth proto 1) :num-args 1)
                                    extern-def (get (nth proto 1) :extern-def "")
                                    impls (get (nth proto 1) :impls {})]
                                (list* (write extern-def)
                                       (map (seq impls)
                                            (fn [impl]
                                              (write "")))))))))))

(defn serialize-protocols []
  (for [protos (get-val :protocols {})
        _ (write "Value *protocols() {\\n")
        _ (write "List *protos = empty_list;\\n")
        _ (write "List *protoInfo;\\n")
        _ (write "List *impls;\\n")
        _ (write "List *impl;\\n")
        _ (write-strs (map (seq protos)
                           (fn [proto-inf]
                             (let [impls-info (nth proto-inf 1 empty-list)
                                   num-args (get impls-info :num-args 1)
                                   impls-sym (get impls-info :impls-sym "")
                                   extern-def (get impls-info :extern-def "")
                                   impls (seq (get impls-info :impls empty-list))]
                               (str "protoInfo = empty_list;\\n"
                                    "impls = empty_list;\\n"
                                    (apply str (map (seq impls)
                                                    (fn [impl]
                                                      (let [impl-type (nth impl 0 0)]
                                                        (str "impl = empty_list;\\n"
                                                             "impl = listCons(stringValue(\\\"" (nth impl 1 "")
                                                             "\\\"), impl);\\n"
                                                             "impl = listCons("
                                                             (cond
                                                              (= :default impl-type)
                                                              "keywordValue(\\\":default\\\")"

                                                              (str "numberValue(" impl-type ")"))
                                                             ", impl);\\n"
                                                             "impls = listCons((Value *)impl, impls);\\n"
                                                             )))))
                                    "protoInfo = listCons((Value *)impls, protoInfo);\\n"
                                    "protoInfo = listCons(stringValue(\\\"" extern-def "\\\"), protoInfo);\\n"
                                    "protoInfo = listCons(numberValue(" num-args "), protoInfo);\\n"
                                    "protoInfo = listCons(stringValue(\\\"" impls-sym "\\\"), protoInfo);\\n"
                                    "protoInfo = listCons(stringValue(\\\"" (first proto-inf)
                                    "\\\"), protoInfo);\\n"
                                    "protos = listCons((Value *)protoInfo, protos);\\n")))))
        _ (write "return((Value *)protos);\\n")
        _ (write "}\\n\\n")]
    ""))

(defn static-fns []
  (inline-text "return(static_fns());"))

(defn load-static-fns []
  (let [s-funs (static-fns)
        s-funs (map s-funs
                    (fn [fn-info]
                      (let [fn-name (nth fn-info 0)
                            arities (nth fn-info 1)]
                        (list fn-name (HashMap arities)))))]
    (set-val :core-static-fns (HashMap s-funs))))

(defn serialize-static-fns []
  (for [s-fns (get-val :static-fns {})
        _ (write "Value *static_fns() {\\n")
        _ (write "List *staticFns = empty_list;\\n")
        _ (write "List *fnInfo;\\n")
        _ (write "List *arityInfo;\\n")
        _ (apply* (state-maybe list)
                  (flat-map (seq s-fns)
                            (fn [static-fn]
                              (let [name (nth static-fn 0)
                                    arities (nth static-fn 1)]
                                (comp
                                 (list (write "fnInfo = empty_list;\\n"))
                                 (flat-map (seq arities)
                                           (fn [arity]
                                             (let [arg-count (nth arity 0)
                                                   arity-sym (nth arity 1)]
                                               (list
                                                (write (str "arityInfo = listCons(stringValue(\\\"" arity-sym
                                                            "\\\"), empty_list);\\n"))
                                                (cond
                                                 (= :variadic arg-count)
                                                 (write (str "arityInfo = listCons(keywordValue(\\\"" arg-count
                                                             "\\\"), arityInfo);\\n"))

                                                 (write (str "arityInfo = listCons(numberValue(" arg-count
                                                             "), arityInfo);\\n")))
                                                (write (str "fnInfo = listCons((Value *)arityInfo, fnInfo);\\n"))))))
                                 (list
                                  (write (str "fnInfo = listCons((Value *)fnInfo, empty_list);\\n"))
                                  (write (str "fnInfo = listCons(stringValue(\\\"" name "\\\"), fnInfo);\\n"))
                                  (write (str "staticFns = listCons((Value *)fnInfo, staticFns);\\n"))))))))
        _ (write "return((Value *)staticFns);\\n")
        _ (write "}\\n\\n")]
    ""))

(defn counts []
  (inline-text "return(counts());"))

(defn load-counts []
  (let [count-list (counts)]
    (set-val :gensym-count (nth count-list 0 0))))

(defn serialize-counts []
  (for [gensym-count (get-val :gensym-count 0)
        _ (write "Value *counts() {\\n")
        _ (write "List *count_list = empty_list;\\n")
        _ (write (str "count_list = listCons(numberValue(" gensym-count "), count_list);\\n"))
        _ (write "return((Value *)count_list);\\n")
        _ (write "}\\n\\n")]
    ""))

(defn defined-syms []
  (inline-text "return(defined_syms());"))

(defn load-defined-syms []
  (let [defined (HashMap (defined-syms))]
    (set-val :core-defined-syms defined)))

(defn serialize-defined-syms []
  (for [def-syms (get-val :defined-syms {})
        _ (write "Value *defined_syms() {\\n")
        _ (write "List *defSyms = empty_list;\\n")
        _ (write "List *symInfo;\\n")
       _ (apply* (state-maybe list)
                  (flat-map (seq def-syms)
                       (fn [def]
                         (let [sym (nth def 0)
                               ext-ref (nth def 1)
                               ext (nth ext-ref 0)
                               ref (nth ext-ref 1)]
                           (list
                            (write (str "symInfo = listCons(stringValue(\\\"" ref "\\\"), empty_list);\\n"))
                            (write (str "symInfo = listCons(stringValue(\\\"" ext "\\\"), symInfo);\\n"))
                            (write (str "symInfo = listCons((Value *)symInfo, empty_list);\\n"))
                            (write (str "symInfo = listCons(symbolValue(\\\"" sym "\\\"), symInfo);\\n"))
                            (write (str "defSyms = listCons((Value *)symInfo, defSyms);\\n")))))))
        _ (write "return((Value *)defSyms);\\n")
        _ (write "}\\n\\n")]
    ""))

(defn compile-module [module-name & src-files]
  (let [text (slurp (first src-files))
        type-seq (seq (types))
        parser (make-parser (read-form))
        compiling-fn (apply-to list
                               (base-types)
                               (extern-functions)
                               (comp (for [_ (assoc-in-val (list :new-numbers)
                                                           (reduce type-seq {}
                                                                   (fn [m type]
                                                                     (assoc m
                                                                       (nth type 1 0)
                                                                       (str "_num_" (nth type 1 0))))))
                                           expr parser
                                           _ (set-expr expr)
                                           ast (analyze-bootstrap)
                                           _ (static-values)
                                           _ (evaluate ast emit-c)
                                           _ (set-val :bootstrapping true)]
                                       "")
                                     (apply-to list
                                               (core-base-fns)
                                               (fixed-fn-types)
                                               (load-defined-syms)
                                               (load-counts)
                                               (load-static-fns)
                                               (load-protocols)))
                               (new-sm (fn [s]
                                         (emit-exprs s parser)))
                               (comp (for [bootstrapping (get-val :bootstrapping false)
                                           :when bootstrapping
                                           _ (serialize-counts)
                                           _ (serialize-protocols)
                                           _ (serialize-static-fns)
                                           _ (serialize-defined-syms)]
                                       "")
                                     (state-maybe ""))
                               (comp (emit-main)
                                     (state-maybe "")))]
    (compiling-fn {:output empty-list
                   :file-name (first src-files)
                   :line-num 0
                   :types (types)
                   :symbols {}
                   :keywords {}
                   :numbers {}
                   :strings {}
                   :new-externs empty-list
                   :defined-syms (reduce type-seq {}
                                         (fn [m type]
                                           (assoc m
                                             (nth type 0 0)
                                             (list (str "Number _num_" (nth type 1 0))
                                                   (str "(Value *)&_num_" (nth type 1 0))))))
                   :num-count (inc (count type-seq))
                   :text text})))

(main [argList]
      (compile-module "" (nth argList 1)))