gistfile1.clj

(def registers
  {:stack []
   :env {}
   :control []
   :dump []
   :backtrack []
   :free 0})
   
(defn classify
  [x]
  (cond
    ;; (symbol? x) :symbol
    ;; (number? x) :number
    ;; (nil? x) :nil
    (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))
    :else :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)))