(defun zip (fn l1 l2)
  (cond ((or (null l1) (null l2)) nil)
        (t (cons (funcall fn (car l1) (car l2)) (zip fn (cdr l1) (cdr l2))))))


(defun fold (fn start lis)
  (cond ((null lis) start)
        (t (funcall fn (car lis) (fold fn start (cdr lis))))))

(defun findl (elm lis)
  (cond ((null lis) nil)
        ((eql elm (car lis)) lis)
        (t (findl elm (cdr lis)))))

(defun enumerate (lis strt)
  (cond ((null lis) nil)
        (t (cons (cons (car lis) strt) (enumerate (cdr lis) (+ 1 strt)))))) 


;

(defun show-error (&rest lis)
  (let ()
    (format t "error: " )
    (mapcar #'(lambda (z) (format t "~S" z)) lis)))



;

(defparameter *primitive-list* 
'(cons car cdr set-car set-cdr consp listp eq null
make-string char set-char stringp
make-vector svref set-svref arrayp
vector
make-symbol intern
symbol-name symbol-value symbol-function symbol-plist
setf-symbol-value setf-symbol-function setf-symbol-plist 
symbolp
char-code
code-char
characterp
+ - * divrem <= >= < > =))

(defun is-primitive (form)
  (member (car form) *primitive-list*))



(defun make-let (vars vals body)
  (cons 'let (cons (zip #'(lambda (x y) (list x y)) vars vals) body)))




(defun is-lambda (form)
  (and (consp form) (eq (car form) 'lambda)))

(defun make-lambda (vars body)
  (list 'lambda vars body))

(defun lambda-vars (form)
  (cadr (un-annotate form)))

(defun lambda-body (form)
  (caddr (un-annotate form)))

(defun is-labels (form)
  (eq (car form) 'labels))

(defun make-labels-lambda (funs fun-lambdas body)
  (list 'labels
        (zip #'(lambda (x y) (annotate (list x (lambda-vars y) (lambda-body y)) (get-annotate y)))
             funs fun-lambdas)
        body))


(defparameter *special-form-list* '(progn if cond quote function)) 

(defun is-form (form)
  (atom (car form)))

(defun is-special-form (form)
  (member (car form) *special-form-list*))

(defun is-setq (form)
  (and (listp form) (eq (car form) 'setq)))

(defun is-quote (form)
  (and (listp form) (eq (car form) 'quote)))

(defun is-defun (form)
  (and (listp form) (eq (car form) 'defun)))


(defun un-annotate (form)
  (if (and (listp form) (eq (car (cadr form)) '&&annotate))
      (cons (car form) (cddr form))
    form))

(defun get-annotate (form)
  (if (and (listp form) (eq (car (cadr form)) '&&annotate))
      (cadr (cadr form))
    nil))

(defun annotate (form val)
  (if (null val)
      form
    (let ((form-1 (un-annotate form)))
      (cons (car form-1) (cons (list '&&annotate val) (cdr form-1))))))

(defun annotate-prop (form prop)
  (let ((ann (get-annotate form)))
    (if ann
        (let ()
          (setf ann (findl prop ann))
          (if ann
              (cadr ann)
            nil))
      nil)))



(defun get-form (e)
  (car e))

(defun get-aux (e)
  (cadr e))


;



(defun comp-1-xp (expr aux)
  (cond ((numberp expr) (comp-1-number expr aux))
        ((symbolp expr) (comp-1-symbol expr aux))
        ((listp expr) (comp-1-list expr aux))))


(defun comp-1-number (e aux)
  (list e aux))

(defun comp-1-symbol (e aux)
  (list e (look-up e aux :read)))




(defun comp-1-list (e aux)
  (let ()
    (cond ((is-quote e) (list e aux))
          ((is-special-form e) (comp-1-special-form e aux))
          ((is-primitive e) (comp-1-special-form e aux))
          ((is-setq e) (comp-1-setq e aux))
          ((is-defun e) (comp-1-defun e aux))
          ((is-lambda e) (comp-1-lambda e aux :general-form))
          ((is-labels e) (comp-1-labels e aux))
          (t (comp-1-gen-func e aux)))))


(defun comp-1-special-form (e aux)
  (let ((res nil)
        (aux-res aux)
        (code-res nil)
        (head (car e)))
    (do ((elis (cdr e) (cdr elis)))
        ((null elis))
      (setf res (comp-1-xp (car elis) aux-res))
      (setf aux-res (get-aux res))
      (setf code-res (cons (get-form res) code-res)))
    (list (cons head (reverse code-res)) aux-res)))


(defun comp-1-setq (e aux)
  (let ((atm (cadr e))
        (e1 (caddr e)))
    (let ((res (comp-1-xp e1 aux))
          (code nil)
          (aux-1 nil))
      (setf code (get-form res))
      (setf aux-1 (get-aux res))
      (setf aux-1 (look-up atm aux-1 :write))
      (list (list 'setq atm code) aux-1))))

(defun comp-1-defun (e aux)
  (let ((fun (cadr e))
        (vars (caddr e))
        (body (cadddr e))
        (lam nil)
        (e1 nil)
        (res nil)
        (code nil)
        (aux-1 nil))
    (setf lam (make-lambda vars body))
    (setf e1 (list 'setf-symbol-function (list 'quote fun) (list 'function lam)))
    (setf res (comp-1-xp e1 aux))
    (setf code (get-form res))
    (setf aux-1 (get-aux res))
    (list code aux-1)))






(defun gl-look-up (gl-rds gl-wrs aux)
  (let ((aux-1 aux)
        (read-mode :gl-read)
        (write-mode :gl-write))
    (do ((gl-rds1 gl-rds (cdr gl-rds1)))
        ((null gl-rds1))
      (setf aux-1 (look-up (car gl-rds1) aux-1 read-mode)))
    (do ((gl-wrs1 gl-wrs (cdr gl-wrs1)))
        ((null gl-wrs1))
      (setf aux-1 (look-up (car gl-wrs1) aux-1 write-mode)))
    aux-1))

(defun remove-vars (vars aux)
  (let ((top (car aux)))
    (setf top (list (car top) (cadr top) (set-difference (caddr top) vars)))
    (cons top (cdr aux))))

(defun comp-1-lambda (e aux mode)
  (let ((vars (cadr e))
        (body (caddr e))
        (aux-1 aux)
        (aux-2 aux)
        (res nil)
        (gl-rds nil)
        (gl-wrs nil)
        (gl-wrs-1 nil)
        (cbdy-code nil)
        (cbdy-aux nil))
    (if (eq mode :let-form)
        (setf aux (mark-let aux-1)))
    (setf aux-1 (extend-aux aux vars))
  
    (setf res (comp-1-xp body aux-1))
    (setf cbdy-code (get-form res))
    (setf cbdy-aux (get-aux res))
    
    (setf gl-rds (cadr (car cbdy-aux)))
    (setf gl-wrs (caddr (car cbdy-aux)))

    (setf aux-2 (pop-aux cbdy-aux))
    (setf gl-wrs-1 (set-difference gl-wrs vars))
    (setf aux-2 (gl-look-up gl-rds gl-wrs-1 aux-2))
    (list
     (annotate (make-lambda vars cbdy-code) (list 'reads gl-rds 'writes gl-wrs-1 'cl-wrqs (intersection gl-wrs vars)))
     aux-2)))

(defun extend-aux (aux vars)
  (cons (list vars nil nil) aux))

(defun pop-aux (aux)
  (if (is-let-frame aux)
      (cddr aux)
    (cdr aux)))


(defun loc-vars (top)
  (car top))

(defun look-up (atm aux mode)
  (if (is-let-frame aux)
      (let ()
        (if (member atm (loc-vars (car aux)))
            (look-up-1 atm aux mode)
          (cons (car aux) (cons (cadr aux) (look-up atm (cddr aux) mode)))))
    (look-up-1 atm aux mode)))



(defun look-up-1 (atm aux mode)
  (let ((top (car aux)))
    (let ((loc-var (car top))
          (gl-rds (cadr top))
          (gl-wrs (caddr top)))
;      (format t "look-up: atm ~S loc ~S rds ~S wrs ~S ~%" atm loc-var gl-rds gl-wrs)
      (cond ((and (member atm loc-var) 
                  (or (eq mode :gl-read) (eq mode :read) (eq mode :write))) aux)
            ((and (member atm gl-rds) (or (eq mode :gl-read) (eq mode :read))) aux)
            ((member atm gl-wrs) aux)
            (t 
             (cond ((or (eq mode :read) (eq mode :gl-read))
                    (setf gl-rds (cons atm gl-rds)))
                   ((or (eq mode :write) (eq mode :gl-write))
                    (setf gl-rds (remove atm gl-rds))
                    (setf gl-wrs (cons atm gl-wrs))))
             (cons (list loc-var gl-rds gl-wrs) (cdr aux)))))))



    
(defun comp-1-gen-func (e aux)
  (let ((aux-1 aux)
        (res nil)
        (code nil))
    (if (is-lambda (car e))
        (comp-1-let e aux)
      (let ()
        (do ((e-1 e (cdr e-1)))
            ((null e-1))
          (setf res (comp-1-xp (car e-1) aux-1))
          (setf aux-1 (get-aux res))
          (setf code (cons (get-form res) code)))
        (setf code (reverse code))
        (list code aux-1)))))



(defun comp-1-let (e aux)
  (let ((aux-1 aux)
        (head (car e))
        (head-code nil)
        (res nil)
        (code nil))
    (do ((e-args (cdr e) (cdr e-args)))
        ((null e-args))
      (setf res (comp-1-xp (car e-args) aux-1))
      (setf aux-1 (get-aux res))
      (setf code (cons (get-form res) code)))
    (setf code (reverse code))
    (setf res (comp-1-lambda head aux-1 :let-form))
    (setf head-code (get-form res))
    (setf aux-1 (get-aux res))
    (setf code (cons head-code code))
    (list code aux-1)))


(defun mark-let (aux)
  (cons '&&let aux))

(defun is-let-frame (aux)
  (eq (cadr aux) '&&let))

    
(defun comp-1-labels (e aux)
  (let ((e-body (caddr e))
        (e-body-code nil)
        (f-list (cadr e))
        (aux-1 aux)
        (aux-2 aux)
        (aux-3 aux)
        (code nil)
        (res nil)
        (gl-rds nil)
        (gl-wrs nil)
        (gl-wrs-1 nil)
        (f-name-l (mapcar #'car (cadr e))))
    (setf aux-1 (extend-aux aux-1 f-name-l))
    (do ((ff f-list (cdr ff)))
        ((null ff))
      (let ((f-akt (car ff)))
        (let ((f-lambda (make-lambda (cadr f-akt) (caddr f-akt))))
          (format t "f-lambda = ~S~%" f-lambda)
          (setf res (comp-1-xp f-lambda aux-1))
          (setf code (cons (get-form res) code))
          (setf aux-1 (get-aux res)))))
    (setf code (reverse code))
; die gl-s des labels-body
    (setf aux-2 (mark-let aux-2))
    (setf aux-2 (extend-aux aux-2 f-name-l)) 
    (setf res (comp-1-xp e-body aux-2))
    (setf e-body-code (get-form res))
    (setf aux-2 (get-aux res))
    (setf gl-rds (cadar aux-2))
    (format t "gl-rds = ~S~%" gl-rds)
    (setf gl-wrs (caddar aux-2))
    (format t "gl-wrs = ~S~%" gl-wrs)
    (setf gl-wrs-1 (set-difference gl-wrs f-name-l))

    (setf aux-2 (pop-aux aux-2))
    (setf aux-3 (gl-look-up gl-rds gl-wrs-1 aux-2))
; die gl-s der lambdas
    (setf gl-rds (cadar aux-1))
    (setf gl-wrs (caddar aux-1))
    (setf gl-wrs-1 (set-difference gl-wrs f-name-l))
    (setf aux-3 (gl-look-up gl-rds gl-wrs-1 aux-3))

    (list (annotate
           (make-labels-lambda f-name-l code e-body-code)
           (list 'reads gl-rds 'writes gl-wrs-1))
          aux-3)))



;; EXPAND: eine vereinfachte macro expansion

(defun cons-progn (e)
  (if (null (cdr e))
      (car e)
    (cons 'progn e)))

(defun un-progn (e)
  (if (and (listp e) (eq (car e) 'progn))
      (cdr e)
    (list e)))


(defun expand (e)
  (labels 
      ((let-expand (e)
         (cons (make-lambda (mapcar #'car (cadr e)) (cons-progn (mapcar #'expand (cddr e))))
               (mapcar #'cadr (cadr e))))
       (cond-expand (e)
         (let ((rest (cdr e)))
           (if (null rest)
               nil
             (let ((rest-1 (car rest)))
               (if (null (cdr rest-1))
                   (let ((tt (gensym)))
                     (expand (make-let  (list tt) (list (car rest-1)) 
                                        (list (list 'if tt tt (cons 'cond (cdr rest)))))))
                 (expand (list 'if (car rest-1) (cons-progn (cdr rest-1)) (cons 'cond (cdr rest)))))))))
       (defun-expand (e)
         (list 'setf-symbol-function (list 'quote (cadr e))
               (make-lambda (caddr e) (cadddr e))))
       (generic-expand (e)
         (mapcar #'expand e)))
    
    (cond ((atom e) e)
          ((stringp e) e)
          ((listp e)
           (let ((head (car e)))
             (cond ((eq head 'let)
                    (let-expand e))
                   ((eq head 'cond)
                    (cond-expand e))
                   ((eq head 'defun)
                    (defun-expand e))
                   (t (generic-expand e)))))
          (t e))))

 
(defun display (e)
  (labels
      ((let-display (e)
         (cons 'let
               (cons
                (zip #'(lambda (x y) (list x y)) (lambda-vars (car e)) (cdr e))
                (un-progn (display (lambda-body (car e))))))))
    (cond ((atom e) e)
          ((stringp e) e)
          ((listp e)
           (let ((head (car e)))
                 (cond ((is-lambda head)
                        (let-display e))
                       (t (mapcar #'display e)))))
          (t e))))



;; COMP-0: labels substitution, dann alpha substitution

(defun access-read-01 (vv)
  (cadr vv))

(defun access-read-fun-01 (vv)
  (if (eq (car vv) 'found)
      (caddr vv)
    (cadr vv)))



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


(defun comp-01-symbol (e sl)
  (let ((subs (assoc e sl)))
    (if subs
        (list 'found e (cdr subs))
      (list 'not-found e e))))

(defun comp-01-setq (e sl)
  (let ((v (cadr e))
        (e1 (caddr e)))
    (setf v (comp-01 v sl))
    (setf e1 (comp-01 e1 sl))
    (list 'setq v e1)))
 

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

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

(defun comp-01-lambda (e sl)
  (let ((lam-vars (lambda-vars e))
        (lam-body (lambda-body e)))
    (setf lam-body (comp-01 lam-body sl))
    (make-lambda lam-vars lam-body)))


(defun comp-01-labels (e sl)
  (let ((e1 (un-annotate e)))
    (let ((e-body (caddr e1))
          (fn-defs (cadr e1)))
      (let ((fn-lis (mapcar #'(lambda (z) (list 'lambda (cadr z) (caddr z) (cadddr z))) fn-defs))
            (fn-vars (mapcar #'car fn-defs)))
        (let ((fn-vars-1 (mapcar #'(lambda (z) (get-unique-var z)) fn-vars)))
          (let ((sl-a (pair fn-vars fn-vars-1)))
            (let ((sl-1 (append sl-a sl)))
              (let ((fn-res (mapcar #'(lambda (z) (comp-01 z sl-1)) fn-lis))
                    (e-body-res (comp-01 e-body sl-1)))
                (make-labels-lambda  fn-vars-1 fn-res e-body-res)))))))))


(defun comp-01-form (e sl)
  (let ((head (car e))
        (rest (cdr e)))
    (let ((rest-1 (comp-01-generic rest sl))
          (head-1 (access-read-fun-01 (comp-01-symbol head sl))))
      (cons head-1 rest-1))))

;; COMP-1: freie variablen analyse


(defun fv-rd (fvl) (car fvl))
(defun fv-wr (fvl) (cadr fvl))
(defun fv-clrd (fvl) (caddr fvl))
(defun fv-clwr (fvl) (cadddr fvl))

(defun fv-empty () (list nil nil nil nil))

(defun add-rd (v fvl) (list (adjoin v (fv-rd fvl)) (fv-wr fvl) (fv-clrd fvl) (fv-clwr fvl)))
(defun add-wr (v fvl) (list (fv-rd fvl) (adjoin v (fv-wr fvl)) (fv-clrd fvl) (fv-clwr fvl)))
(defun add-clrd (v fvl) (list (fv-rd fvl) (fv-wr fvl) (adjoin v (fv-clrd fvl)) (fv-clwr fvl)))
(defun add-clwr (v fvl) (list (fv-rd fvl) (fv-wr fvl) (fv-clrd fvl) (adjoin v (fv-clwr fvl))))

(defun mv-cl (fvl) (list nil nil (union (fv-rd fvl) (fv-clrd fvl)) (union (fv-wr fvl) (fv-clwr fvl))))


(defun add-fv (fvl-1 fvl-2)
  (zip #'(lambda (x y) (union x y)) fvl-1 fvl-2))

(defun comp-11 (e)
  (labels
      ((comp-11-symbol (e) (list e (list (list e) nil nil nil)))
       (comp-11-number (e) (list e (fv-empty)))
       (comp-11-string (e) (list e (fv-empty)))
       (comp-11-other (e) (list e (fv-empty)))
       (comp-11-setq (e)
         (let ((v (cadr e))
               (e1 (caddr e)))
           (let ((res (comp-11 e1)))
             (list (list 'setq v (car res)) (add-wr v (cadr res)))))))
    (cond ((symbolp e) (comp-11-symbol e))
          ((numberp e) (comp-11-number e))
          ((stringp e) (comp-11-string e))
          ((listp e)
           (cond
            ((is-quote e) (list e (fv-empty)))
            ((is-special-form e) (comp-11-nohead e))
            ((is-primitive e) (comp-11-nohead e))
            ((is-setq e) (comp-11-setq e))
            ((is-lambda (car e)) (comp-11-let e))
            ((is-lambda e) (comp-11-lambda e :general-form))
            ((is-labels e) (comp-11-labels e))
            (t (comp-11-generic e)))))))


(defun comp-11-generic (e)
  (let ((res (mapcar #'comp-11 e)))
    (list (mapcar #'car res)
          (fold #'(lambda (x y) (add-fv x y)) (list nil nil nil nil) (mapcar #'cadr res)))))

(defun comp-11-let (e)
  (let ((res (comp-11-generic (cdr e)))
        (res-head (comp-11-lambda (car e) :let-form)))
    (list
     (cons (car res-head) (car res))
     (add-fv (cadr res) (cadr res-head)))))

(defun comp-11-nohead (e)
  (let ((res (comp-11-generic (cdr e))))
    (list (cons (car e) (car res)) (cadr res))))
  
(defun comp-11-lambda (e mode)
  (let ((vars (lambda-vars e))
        (body (lambda-body e)))
    (let ((res (comp-11 body)))
      (let ((fvl (cadr res)))
        (let ((lam (make-lambda vars (car res)))
              (rds nil)
              (wrs nil)
              (wrsx nil)
              (fvl-1 nil))
          (setf fvl-1 (mapcar #'(lambda (z) (set-difference z vars)) fvl))   
          (cond ((eq mode :general-form)
                 (setf rds (union (fv-rd fvl-1) (fv-clrd fvl-1)))
                 (setf wrs (union (fv-wr fvl-1) (fv-clwr fvl-1)))
                 (setf wrsx (intersection (fv-clwr fvl) vars)))
                ((eq mode :let-form)
                 (setf rds nil)
                 (setf wrsx (intersection vars (fv-clwr fvl)))))
          (setf lam (annotate lam (list 'reads rds 'writes wrs 'cl-wrqs wrsx)))
          (if (eq mode :general-form)
              (setf fvl-1 (mv-cl fvl-1)))
          (list lam fvl-1))))))
    
(defun comp-11-labels (e)
  (let ((e-body (caddr e))
        (fn-defs (cadr e)))
    (let ((fn-lis (mapcar #'(lambda (z) (list 'lambda (cadr z) (caddr z))) fn-defs))
          (fn-vars (mapcar #'car fn-defs)))
      (let ((fn-res (mapcar #'comp-11 fn-lis)))
        (let ((fn-codes (mapcar #'car fn-res))
              (fn-fvl-lis (mapcar #'cadr fn-res)))
          (let ((fn-fvl (fold #'(lambda (x y) (add-fv x y)) (fv-empty) fn-fvl-lis))
                (fn-fvl-1 nil)
                (res-body nil)
                (code nil)
                (fvl-b nil))
            (setf fn-fvl-1 (mapcar #'(lambda (z) (set-difference z fn-vars)) fn-fvl))
            (setf fn-fvl-1 (mv-cl fn-fvl-1))

            (setf res-body (comp-11 e-body))

            (setf fvl-b (cadr res-body))
            (setf code (annotate 
                        (make-labels-lambda fn-vars fn-codes (car res-body))
                        (list 'reads (fv-clrd fn-fvl-1) 'writes (fv-clwr fn-fvl-1))))
            (setf fvl-b (mapcar #'(lambda (z) (set-difference z fn-vars)) fvl-b))
            (setf fvl-b (add-fv fvl-b fn-fvl-1))
            (list code fvl-b)))))))
            
;; NEW-VAR: eindeutige variablen erzeugung

(defparameter *unique-var-table* nil)

(defun get-unique-var (sym)
  (let ((sym-name (symbol-name sym))
        (u-assoc (assoc sym *unique-var-table*)))
    (let ((n-id 
           (if u-assoc
               (cdr u-assoc)
             0)))
      (setf n-id (+ n-id 1))
      (let ((usym-name (concatenate 'string sym-name "." (format nil "~A" n-id))))
        (let ((usym (make-symbol usym-name)))
          (if u-assoc
              (rplacd u-assoc n-id)
            (push (cons sym n-id) *unique-var-table*))
          usym)))))

(defun get-closure-write-sl-var ()
  (get-unique-var '&&cv))


;; 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))
          ((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 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 ((subs-vars (annotate-prop e 'cl-wrqs))
        (sl-1 sl)
        (new-var nil))
    (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)))))
    (let ((lam-vars (lambda-vars e))
          (lam-body (lambda-body e)))
      (setf lam-body (comp-2 lam-body sl-1))
      (if (not (null subs-vars))
          (setf lam-body 
                (make-let (list new-var) (list (cons 'vector subs-vars))
                          (list 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 (caddr e1))
          (fn-defs (cadr e1)))
      (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 e-body sl)))
          (make-labels-lambda  fn-vars fn-res e-body-res))))))



;; COMP-3: closure conversion

(defun is-lambda-var-3 (v)
  (and (listp v) (eq (car v) 'lambda)))

(defun is-global-3 (v)
  (and (listp v) (eq (car v) 'global)))

(defun is-svref-3 (v)
  (and (listp v) (eq (car v) 'svref)))

(defun is-unquote-3 (v)
  (and (listp v) (eq (car v) 'unquote)))


(defun un-global-3 (v)
  (cadr v))



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

(defun comp-3-symbol (e sl)
  (let ((subs (assoc e sl)))
    (if subs
        (let ((res (cdr subs)))
          (if (listp res)
              res
            (error "comp-3-symbol: error 1")))
      (list 'global e))))
      

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

(defun comp-3-nohead (e sl)
  (cons (car e)
        (comp-3-generic (cdr e) sl)))


(defun comp-3-form (e sl)
  (let ((head (car e))
        (rest (comp-3-generic (cdr e) sl)))
    (setf head (access-read-fun-3 (comp-3-symbol head sl)))
    (cons head rest)))





(defun comp-3-let (e sl)
  (let ((body (lambda-body (car e)))
        (vars (lambda-vars (car e)))
        (args (cdr e)))
    (let ((sl-1 (append
                 (mapcar #'(lambda (z) (cons z (list 'lambda z))) vars) sl)))
      (let ((e1 (comp-3 args sl))
            (body-1 (comp-3 body sl-1)))
        (let ((res (cons (make-lambda vars body-1) e1)))
          (format t "args = ~S~%*************************************~%" args)
          res)))))

(defun access-read-3 (z)
  (if (atom z)
      z
    (cond ((is-lambda-var-3 z) (cadr z))
          ((is-global-3 z) (list 'symbol-value (list 'quote (cadr z))))
          ((is-unquote-3 z) (list 'symbol-value (cdr z)))
          ((is-svref-3 z) z)
          (t z))))

(defun access-read-fun-3 (z)
  (if (atom z)
      z
    (cond ((is-lambda-var-3 z) 
           (list 'symbol-function (list 'quote (cadr z))))
          ((is-global-3 z) 
           (list 'symbol-function (list 'quote (cadr z))))
          ((is-unquote-3 z) (list 'symbol-value (cdr z)))
          ((is-svref-3 z) z)
          (t z))))

(defun access-write-3 (z)
  (if (atom z)
      z
    (cond ((is-global-3 z) (list 'quote (cadr z)))
          ((is-lambda-var-3 z) (cadr z))
          ((is-unquote-3 z) (cdr z))
          ((is-svref-3 z) z)
          (t z))))

(defun comp-3-setq (e sl)
  (let ((v (cadr e))
        (e1 (caddr e)))
    (setf v (comp-3-symbol v sl))
    (setf e1 (comp-3 e1 sl))
    (cond ((is-global-3 v)
           (list 'setf-symbol-value (access-write-3 v) e1))
          ((is-unquote-3 v)
           (list 'setf-symbol-value (access-write-3 v) e1))
          ((is-svref-3 v)
           (list 'set-svref (cadr v) (caddr v) e1))
          ((is-lambda-var-3 v)
           (list 'setq (access-write-3 v) e1)))))
      

(defun prepend-lambda-var (v lam)
  (make-lambda (cons v (lambda-vars lam)) (lambda-body lam)))


(defun pair (l1 l2)
  (zip #'(lambda (x y) (cons x y)) l1 l2))


(defun comp-3-lambda (e sl)
  (let ((rds (annotate-prop e 'reads)))
    (let ((rds-subs (mapcar #'(lambda (z) (comp-3-symbol z sl)) rds)))
      (setf rds-subs (pair rds-subs rds))
      (setf rds-subs (remove-if #'(lambda (z) (is-global-3 (car z))) rds-subs))
      (setf rds (mapcar #'cdr rds-subs))
      (setf rds-subs (mapcar #'car rds-subs))
      (let ((clos-vect (mapcar #'(lambda (z) (access-read-3 z)) rds-subs)))
        (let ((self-var (get-unique-var 'self)))
          (let ((sl-a (enumerate rds 0)))
            (let ((sl-1 (append
                         (mapcar #'(lambda (z)
                                     (cons (car z) (list 'svref (list '%closure-ref self-var 1) (cdr z)))) sl-a) sl)))
              (let ((vars (lambda-vars e))
                    (body (lambda-body e)))
                (let ((sl-1 (append
                             (mapcar #'(lambda (z) (cons z (list 'lambda z))) vars) sl-1)))
                  (let ((vars-1 (cons self-var vars))
                        (body-1 (comp-3 body sl-1)))
                    (list '%closure (make-lambda vars-1 body-1)
                          (cons 'vector clos-vect))))))))))))
      

(defun comp-3-labels (e sl)
  (let ((e1 (un-annotate e))
        (rds (annotate-prop e 'reads)))
    (let ((e-body (caddr e1))
          (fn-defs (cadr e1)))
      (let ((fn-lis (mapcar #'(lambda (z) (list 'lambda (cadr z) (caddr z) (cadddr z))) fn-defs))
            (fn-vars (mapcar #'car fn-defs)))
        (let ((rds-subs (mapcar #'(lambda (z) (comp-3-symbol z sl)) rds)))
          (setf rds-subs (pair rds-subs rds))
          (setf rds-subs (remove-if #'(lambda (z) (is-global-3 (car z))) rds-subs))
          (setf rds (mapcar #'cdr rds-subs))
          (setf rds-subs (mapcar #'car rds-subs))
          (do ((cc (reverse fn-vars) (cdr cc)))
              ((null cc))
              (setf rds (cons (car cc) rds))
              (setf rds-subs (cons nil rds-subs)))
          (let ((clos-vect (mapcar #'(lambda (z) (access-read-3 z)) rds-subs)))
            (let ((self-var (get-unique-var 'self))
                  (cv-var (get-unique-var 'cv)))
                (let ((sl-a (enumerate rds 0)))
                  (let ((sl-1 (append
                               (mapcar #'(lambda (z)
                                           (cons (car z) (list 'svref (list '%closure-ref self-var 1) (cdr z)))) sl-a) sl)))
                    (let ((let-body 
                           (mapcar #'(lambda (z) (list 'set-svref cv-var (cdr z)
                                                       (list '%closure
                                                             (make-lambda (cons self-var (lambda-vars (car z)))
                                                                          (comp-3 (lambda-body (car z)) sl-1))
                                                             cv-var))) (enumerate fn-lis 0))))
                      (setf let-body (append let-body
                                             (list (list (make-lambda (list self-var) (comp-3 e-body sl-1)) cv-var))))
                      (make-let (list cv-var) (list (cons 'vector clos-vect))
                                let-body)))))))))))
                      
                                    




  
(defun do-comp (e sl)
  (let ((res (comp-01 (expand e) nil))
        (globs nil))
    (setf res (comp-11 res))
    (format t "~%")
    (pprint (car res))
    (setf res (comp-2 (expand (car res)) nil))
    (format t "comp-2 = ~S~%" res)
    (pprint res)
    (format t "~%~%")
    (setf res (comp-11 (expand res)))
    (format t "comp-2 analyzed = ")
    (pprint (car res))
    (format t "~%~%")
    (setf res (comp-3 (car res) nil))
    (pprint res)))

(defun do-comp-1 (e sl)
  (let ((res (comp-11 (expand e)))
        (globs nil))
    (setf res (comp-2 (expand (car res)) nil))
    (format t "comp-2 = ~S~%" res)
    (pprint res)))




(defparameter *tst* '(let ((x 1) (y 2))
                     (let ((u 3) (v 4))
                       (let ((p 5))
                         (let ()
                           (setq lp (lambda (t1 t2) 
                                      (let ()
                                        (setq t1 t2)
                                        (setq u t1)
                                        (setq cc t1)
                                        (setq dd u)
                                        (setq t1 ee)
                                        (setq t2 v))))
                           (setq x u)
                           (setq aa x)
                           (setq y bb)
                           (setq lp1 (lambda (t) (setq ff t))))))))

(defparameter *tst1* '(defun f (n) (cond ((<= n 1) 1) (1 (* 2 f (- n 1))))))

(defparameter *tst2* '(lambda (a) (defun f (n) (cond ((<= n 1) (setq x 1) (setq y b) (setq a a)) (1 (* a f (- n 1)))))))

(defparameter *tst3* '(let ((x 1)(ff nil)) (let ((i 0)) 
                                        (do-until ((> i 5) ff)
                                                  (let ((y 1))
                                                    (push #'(lambda (z)
                                                              (cond ((= z 0) x)
                                                                    (1 (setq x z)))) ff))))))



(defparameter *tst4* '(let ((x 1) (y 2))
                        (let ((u 3) (v 4))
                          (let ((p 5))
                            (let ()
                              (setq lp (lambda (t1 t2) 
                                         (let ()
                                           (setq t1 t2)
                                           (setq u t1)
                                           (setq cc t1)
                                           (setq dd u)
                                           (setq t1 ee)
                                           (setq t2 v))))
                              (setq x u)
                              (setq aa x)
                              (setq y bb)
                              (setq lp1 (lambda (t) (setq ff tt))))))))

(defparameter *tst5* '(lambda (a b c)
                        (labels ((f (m n) (progn (setq a m) (setq a c) (setq n b)))
                                 (g (r s) (progn (setq r s) (setq f s) (setq r g))))
                          (progn (f p q) (g a b) (setq f (lambda (t) (setq t g)))))))

(defparameter *tst51* '(lambda (a b c)
                         (labels ((f (m n) (progn (setq a m) (setq a c) (setq n b)))
                                 (g (r s) (progn (setq r s) (setq f s) (setq r g))))
                          (progn (f p q) (g a b) (setq c (lambda (t) (setq t g)))))))

(defparameter *tst6* '(defun h (a) 
                        (labels ((f (n) (cond ((<= n 1) 1)
                                              (1 (+ (f (- n 1)) (f (- n 2))))))
                                 (g (n) (cond ((<= n 1) nil)
                                              (1 (cons (f n) (g (- n 1))))))) (g a))))

(defparameter *tst7* '(defun h (a) 
                        (labels ((f (n) (cond ((<= n 1) 1)
                                              (1 (+ (foo (- n 1)) (bar (- n 2))))))
                                 (g (n) (cond ((<= n 1) nil)
                                              (1 (cons (f n) (g (- n 1))))))) (g a))))