(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))))))



;


(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
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 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-special-form (form)
  (member (car form) *special-form-list*))

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

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


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

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

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


(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-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))
     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 (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))
    (setf gl-wrs (caddar aux-2))
    (setf gl-wrs-1 (set-difference gl-wrs f-name-l))
    (setf aux-3 (gl-look-up gl-rds gl-wrs-1 aux))
; 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)))



(defun cons-progn (e)
  (if (= (length e) 1)
      (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 ((atom e) e)
          ((stringp e) e)
          ((listp e)
           (let ((head (car e)))
             (cond ((eq head 'let)
                    (let-expand e))
                   (t (mapcar #'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))))




(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 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 e (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-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 fold (fn start lis)
  (cond ((null lis) start)
        (t (funcall fn (car lis) (fold fn start (cdr lis))))))

(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)
              (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))))
                ((eq mode :let-form)
                 (setf rds nil)
                 (setf wrs (intersection vars (fv-clwr fvl)))))
          (setf lam (annotate lam (list 'reads rds 'writes wrs )))
          (if (eq mode :general-form)
              (setf fvl-1 (list nil nil (union (fv-rd fvl-1) (fv-clrd fvl-1)) (union (fv-wr fvl-1) (fv-clwr 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 (list nil nil (union (fv-rd fn-fvl-1) (fv-clrd fn-fvl-1)) (union (fv-wr fn-fvl-1) (fv-clwr fn-fvl-1))))
            
            (setf res-body (comp-11 e-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 (cadr res-body))
            (setf fvl-b (add-fv fvl-b fn-fvl-1))
            (list code fvl-b)))))))