(def evcall (e a s r m)
  (mev (cons (list (car e) a)
             (fu (s r m)
               (evcall2 (cdr e) a s r m))
             s)
       r
       m))

(def evcall2 (es a s (op . r) m)
  (if ((isa 'mac) op)
      (applym op es a s r m)
      (mev (append (map [list _ a] es)
                   (cons (fu (s r m)
                           (let (args r2) (snap es r)
                             (applyf op (rev args) a s r2 m)))
                         s))
           r
           m)))

(def applym (mac args a s r m)
  (applyf (caddr mac)
          args
          a
          (cons (fu (s r m)
                  (mev (cons (list (car r) a) s)
                       (cdr r)
                       m))
                s)
          r
          m))

(def applyf (f args a s r m)
  (if (= f apply)    (applyf (car args) (reduce join (cdr args)) a s r m)
      (caris f 'lit) (if (proper f)
                         (applylit f args a s r m)
                         (sigerr 'bad-lit s r m))
                     (sigerr 'cannot-apply s r m)))

(def applylit (f args a s r m)
  (aif (and (inwhere s) (find [(car _) f] locfns))
       ((cadr it) f args a s r m)
       (let (tag . rest) (cdr f)
         (case tag
           prim (applyprim (car rest) args s r m)
           clo  (let ((o env) (o parms) (o body) . extra) rest
                  (if (and (okenv env) (okparms parms))
                      (applyclo parms args env body s r m)
                      (sigerr 'bad-clo s r m)))
           mac  (applym f (map [list 'quote _] args) a s r m)
           cont (let ((o s2) (o r2) . extra) rest
                  (if (and (okstack s2) (proper r2))
                      (applycont s2 r2 args s r m)
                      (sigerr 'bad-cont s r m)))
                (aif (get tag virfns)
                     (let e ((cdr it) f (map [list 'quote _] args))
                       (mev (cons (list e a) s) r m))
                     (sigerr 'unapplyable s r m))))))

(set virfns nil)

(mac vir (tag . rest)
  `(set virfns (put ',tag (fn ,@rest) virfns)))

(set locfns nil)

(mac loc (test . rest)
  `(set locfns (cons (list ,test (fn ,@rest)) locfns)))

(loc (is car) (f args a s r m)
  (mev (cdr s) (cons (list (car args) 'a) r) m))

(loc (is cdr) (f args a s r m)
  (mev (cdr s) (cons (list (car args) 'd) r) m))