(in-package "CL-USER")

;; COMP-2: write elimination

(defun comp-2 (e sl)
  (labels
      ((comp-2-number (e sl) e)
       (comp-2-string (e sl) e)
       (comp-2-other (e sl) e))
    (cond ((null e) e)
          ((symbolp e) (comp-2-symbol e sl))
          ((numberp e) (comp-2-number e sl))
          ((stringp e) (comp-2-string e sl))
          ((characterp e) (comp-2-other e sl))
          ((listp e)
           (cond
            ((is-quote e) e)
            ((is-special-form e) (comp-2-nohead e sl))
            ((is-primitive e) (comp-2-nohead e sl))
            ((is-setq e) (comp-2-setq e sl))
            ((is-lambda (car e)) (comp-2-let e sl))
            ((is-lambda e) (comp-2-lambda e sl))
            ((is-labels e) (comp-2-labels e sl))
            (t (comp-2-generic e sl)))))))


(defun comp-2-symbol (e sl)
  (let ((subs (assoc e sl)))
    (if (and subs (not (numberp (cdr subs))))
        (cdr subs)
      e)))

(defun comp-2-setq (e sl)
  (let ((v (cadr e))
        (e1 (caddr e)))
    (setf v (comp-2 v sl))
    (setf e1 (comp-2 e1 sl))
    (if (atom v)
        (list 'setq v e1)
      (list '%set-svref (cadr v) (caddr v) e1))))

 

(defun comp-2-generic (e sl)
    (mapcar #'(lambda (z) (comp-2 z sl)) e))

(defun comp-2-nohead (e sl)
  (let ((head (car e)))
    (cons head (comp-2-generic (cdr e) sl))))

(defun comp-2-lambda (e sl)
  (let* ((lam-vars (lambda-vars e))
         (subs-vars (annotate-prop e 'cl-wrqs))
         (diff-vars (set-difference lam-vars subs-vars))
         (sl-1 sl)
         (new-var nil))
    (setf sl-1 (append (enumerate diff-vars 0) sl-1))
    (if (not (null subs-vars))
        (let ()
          (setf new-var (get-closure-write-sl-var))
          (let ((subs-vars-l (enumerate subs-vars 0)))
            (setf subs-vars-l (mapcar #'(lambda (z) (cons (car z) (list '%svref new-var (cdr z)))) subs-vars-l))
            (setf sl-1 (append subs-vars-l sl-1)))))
    (let ((lam-body (lambda-body e)))
      (setf lam-body (comp-2-generic lam-body sl-1))
      (if (not (null subs-vars))
          (setf lam-body 
                (list (make-let (list new-var) (list (cons 'vector subs-vars))
                                lam-body))))
      (make-lambda lam-vars lam-body))))



(defun comp-2-let (e sl)
  (comp-2-generic e sl))

(defun comp-2-labels (e sl)
  (let ((e1 (un-annotate e)))
    (let ((e-body (labels-body e1))
          (fn-defs (cadr e1)))
;      (format t "e-body = ~A~%" e-body)
      (let ((fn-lis (mapcar #'(lambda (z) (list 'lambda (cadr z) (caddr z) (cadddr z))) fn-defs))
            (fn-vars (mapcar #'car fn-defs)))
        (let ((fn-res (mapcar #'(lambda (z) (comp-2 z sl)) fn-lis))
              (e-body-res (comp-2-generic e-body sl)))
          (make-labels-lambda  fn-vars fn-res e-body-res))))))