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


;


(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 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 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 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 (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 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 (mapcar #'(lambda (z) (set-difference z fn-vars)) fvl-b))
            (setf fvl-b (add-fv fvl-b fn-fvl-1))
            (list code fvl-b)))))))