gistfile1.clj

(defn classify
  [x]
  (if (seq? x) 
    (case (first x)
      fn :fn
      if :if
      let :let
      letfn :letfn
      quote :quote
      try :try
      throw :throw
      (if (symbol? (first x))
        :invoke
        :list))
    :constant))   
   
(defn null
  [x]
  (or (nil? x) (and (seq? x) (empty? x))))

(defn index
  ([e n] (index e n 1))
  ([e n i]
     (if (null n)
       nil
       (letfn [(indx2 [e n j]
                 (if (null n)
                   nil
                   (if (= (first n) e) j (recur e (rest n) (inc j)))))]
         (let [j (indx2 e (first n) 1)]
           (if (null j)
             (recur e (rest n) (inc i))
             (cons i (list j))))))))
             
(defmulti -compile (fn [x namelist acc] (classify x)) :default :constant)

(defmethod -compile :constant
  [e n c]
  (if (null e)
    (cons nil c)
    (let [ij (index e n)]
      (if (null ij)
        (cons :LDC (cons e c))
        (cons :LD (cons ij c))))))

(defmethod -compile :symbol
  [x namelist acc]
  x)

(defmethod -compile :number
  [x namelist acc]
  x)

(defmethod -compile :nil
  [_ namelist acc]
  nil)

(defmethod -compile :if
  [[_ test then else] n c]
  (compile test n
           (cons :SEL (cons (compile then n (cons :JOIN nil))
                            (cons (compile else n (cons :JOIN nil)) c)))))

(defn compile-fn
  [body n c]
  (cons :LDF (cons (compile body n (cons :RTN nil)) c)))

(defmethod -compile :fn
  [[_ bindings body] n c]
  (let [n (cons bindings n)]
    (compile-fn body n c)))

(defn compile-app
  [args n c]
  (if (null args)
    c
    (recur (rest args) n (compile (first args) n (cons :CONS c)))))

(defmethod -compile :let
  [[_ bindings body] n c]
  (let [newn (cons (list* (map first bindings)) n)
        values (list* (map second bindings))]
    (cons :NIL (compile-app values n (compile-fn body newn (cons :AP c))))))

(defmethod -compile :letfn
  [[_ bindings body] n c]
  (let [newn (cons (list* (map first bindings)) n)
        values (list* (->> (map rest bindings)
                           (map (partial cons 'fn))))]
    (concat '(:DUM :NIL)
            (compile-app values newn (compile-fn body newn (cons :RAP c))))))

(defmethod -compile :quote
  [x namelist acc]
  (second x))

(defn compile-builtin
  [args n c]
  (if (null args)
    c
    (recur (rest args) n (compile (first args) n c))))

(defmethod -compile :invoke
  [[op & args] n c]
  (if (contains? '#{car cdr cons + - * /} op)
    (let [c (cons op c)]
      (compile-builtin args n c))
    (cons :NIL (compile-app args n (compile op n (cons :AP c))))))

(defmethod -compile :list
  [x namelist acc]
  (list* (map #(-compile % namelist acc) x)))

(defn compile
  ([form] (compile form nil '(:STOP)))
  ([form n c]
     (-compile form n c)))