(in-package "CL-USER")


(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 length=2 (lis)
  (and (consp lis) (not (null (cdr lis))) (null (cddr lis))))

(defun length=1 (lis)
  (and (consp lis) (null (cdr lis))))

;

(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

%make-vector

%svref
%set-svref

%set-symbol-function
%symbol-function

%set-symbol-value
%symbol-value

%make-closure
%closure-ref

%print
%read

vector
apply

funcall

make-symbol intern
symbol-name symbol-value symbol-function symbol-plist
set-symbol-value set-symbol-function set-symbol-plist 
symbolp

char-code
code-char
characterp

%+ %- %* %div %rem %<= %>= %< %> %= %/=))

(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 make-let* (vars vals body)
  (cons 'let* (cons (zip #'(lambda (x y) (list x y)) vars vals) body)))

(defun let-vars (e)
  (cadr e))

(defun let-body (e)
  (cddr e))



(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 if-expr-tst (e)
  (cadr e))

(defun if-expr-branch-t (e)
  (caddr e))

(defun if-expr-branch-f (e)
  (cadddr e))

(defun if-expr-has-3 (e)
  (not (null (cdddr e))))







(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-if (form)
  (and (listp form) (eq (car form) 'if)))

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

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

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

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

(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
      ((and-expand (e)
         (cond ((null (cdr e))
                t)
               ((null (cddr e))
                (cadr e))
               (t (let ()
                    (list 'if (cadr e) (expand (cons 'and (cddr e))) nil)))))
       (or-expand (e)
         (cond ((null (cdr e))
                nil)
               ((null (cddr e))
                (cadr e))
               (t (let ((var (gensym)))
                    (expand (list (make-lambda (list var) (list 'if var var (cons 'or (cddr e)))) (cadr e)))))))
       (let*-expand (e)
         (let ((vars (let-vars e)))
           (let ((zz (cond ((null vars)
                            (make-let nil nil (let-body e)))
                           ((null (cdr vars))
                            (make-let (list (caar vars)) (list (cadar vars)) (let-body e)))
                           (t (make-let (list (caar vars)) (list (cadar vars)) 
                                        (list (expand (make-let* (mapcar #'car (cdr vars)) (mapcar #'cadr (cdr vars)) (let-body e)))))))))
             (expand zz))))
       (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 '%set-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 'and)
                    (and-expand e))
                   ((eq head 'or)
                    (or-expand e))
                   ((eq head 'let*)
                    (let*-expand e))
                   ((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-character (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))
          ((characterp e) (comp-01-character 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))
          ((characterp e) (comp-11-other 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))
          ((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 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))
    (let ()
;     (format t "++++++++~%comp3: e = ~A ~%sl=~A~%+++++++++~%" e sl)
     (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))
          ((characterp e) (comp-3-other 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)
;  (format t "e= ~A~% sl = ~A~%" e sl)
  (let ((subs (assoc e sl)))
;    (format t "subs = ~A~%*********************************~%" subs)
    (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 (mapcar #'(lambda (z) (comp-3 z sl)) args))
            (body-1 (comp-3 body sl-1)))
        (let ((res (cons (make-lambda vars body-1) e1)))
           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 '%set-symbol-value (access-write-3 v) e1))
          ((is-unquote-3 v)
           (list '%set-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 '%make-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 '%make-closure
                                                             (make-lambda (cons self-var (lambda-vars (car z)))
                                                                          (comp-3 (lambda-body (car z)) 
                                                                                  (append
                                                                                   (mapcar #'(lambda (x) (cons x (list 'lambda x)))
                                                                                           (lambda-vars (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)) 
                                                         (list '%svref cv-var 0)))))
                      (make-let (list cv-var) (list (cons 'vector clos-vect))
                                let-body)))))))))))

                                    

;; COMP-GEN ************ code erzeugung ****************************************************************************************


(defun c-error (n proc &rest lis)
  (format t "error: ~A in ~A " n proc)
  (mapcar #'(lambda (z) (format t " ~A" z)) lis)
  (format t "~%~%"))


(defvar *stat* (make-array 4))


(defparameter *stk-idx* 3)

(defun get-stack (stat)
  (aref stat *stk-idx*))

(defun set-stack (stat new-stack)
  (format t "stack = ~A ~%" new-stack)
  (setf (aref stat *stk-idx*) new-stack))

(defparameter *ilist-idx* 2)

(defun get-ilist (stat)
  (aref stat *ilist-idx*))

(defun set-ilist (stat new-ilist)
  (setf (aref stat *ilist-idx*) new-ilist))


(defparameter *lits-idx* 1)

(defun get-lits (stat)
  (aref stat *lits-idx*))

(defun set-lits (stat new-lits)
  (setf (aref stat *lits-idx*) new-lits))


(defparameter *parms-idx* 0)

(defun get-parms (stat)
  (aref stat *parms-idx*))

(defun set-parms (stat new-parms)
  (setf (aref stat *parms-idx*) new-parms))


(defun stat-init (stat)
  (let ()
    (set-stack stat nil)
    (set-ilist stat nil)
    (set-lits stat nil)
    (set-parms stat nil)
    stat))

(stat-init *stat*)


(defun comp-gen (e stat)
  (let ()
;    (format t "e= ~A~%stat= ~A~%++++++++++++++++++++++++++++~%" e stat)
  (cond ((symbolp e) (comp-gen-symbol e stat))
        ((characterp e) (comp-gen-character e stat))
        ((numberp e) (comp-gen-number e stat))
        ((stringp e) (comp-gen-string e stat))
        ((listp e)
         (cond
          ((is-quote e) 
           (comp-gen-quote e stat))
          ((is-function e)
           (comp-gen-function e stat))
          ((is-setq e)
           (comp-gen-setq e stat))
          ((is-if e)
           (comp-gen-if e stat))
          ((is-progn e)
           (comp-gen-progn e stat))
          ((eq (car e) 'vector)
           (comp-gen-vector e stat))
          ((eq (car e) 'apply)
           (comp-gen-apply e stat))
          ((eq (car e) 'funcall)
           (comp-gen-funcall e stat))
          ((is-primitive e)
           (comp-gen-primitive e stat))
          ((is-lambda (car e))
           (comp-gen-let e stat))
          ((is-lambda e)
           (comp-gen-lambda e stat))
          ((is-form e)
           (comp-gen-form e stat))
          (t (comp-gen-generic e stat)))))))
  

(defparameter *dummy* 0)

(defun increment-stack (n stat)
  (let ((stack (get-stack stat)))
    (setf stack (append (make-list n :initial-element *dummy*) stack))
    (set-stack stat stack)))

(defun decrement-stack (n stat)
  (let ((stack (get-stack stat)))
    (setf stack (do ((i 0 (+ i 1)) (stk stack (cdr stk))) ((>= i n) stk)))
    (set-stack stat stack)))

(defun add-vars-stack (vars stat)
  (let ((stack (get-stack stat)))
    (setf stack (append vars stack))
    (set-stack stat stack)))

(defun enter-opcode (opc ext stat)
  (let ((ilist (get-ilist stat)))
    (setf ilist (append ilist (list (list opc ext))))
    (set-ilist stat ilist)))

(defun enter-label (label stat)
  (let ((ilist (get-ilist stat)))
    (setf ilist (append ilist (list (list 'label label))))
    (set-ilist stat ilist)))


(defun get-lit-index (e stat)
  (let ((lits (get-lits stat)))
    (let ((idx (position e lits)))
      idx)))
            

(defun enter-literal (e stat)
  (let ((lits (get-lits stat)))
    (let ((idx (get-lit-index e stat)))
    (if (null idx)
        (let ()
          (setf lits (append lits (list e)))
          (set-lits stat lits))))))



(defun comp-gen-number (e stat)
  (enter-literal e stat)
  (enter-opcode 'LITIDX (get-lit-index e stat) stat)
  (increment-stack 1 stat))

(defun comp-gen-string (e stat)
  (enter-literal e stat)
  (enter-opcode 'LITIDX (get-lit-index e stat) stat)
  (increment-stack 1 stat))

(defun comp-gen-character (e stat)
  (enter-literal e stat)
  (enter-opcode 'LITIDX (get-lit-index e stat) stat)
  (increment-stack 1 stat))



(defun comp-gen-quote (e stat)
  (let ((val (cadr e)))
    (enter-literal val stat)
    (enter-opcode 'LITIDX (get-lit-index val stat) stat)
    (increment-stack 1 stat)))

(defun comp-gen-function (e stat)
  (let ((val (cadr e)))
    (if (eq (car val) '%make-closure)
        (let ()
          (comp-gen val stat)
          (pprint stat))
      (c-error 1 'comp-gen-function "function of non closure not implemented yet"))))


(defun get-pos (var lis)
  (position var lis))


(defun get-stack-index (var stat)
  (let ((stk (get-stack stat)))
    (let ((res (get-pos var stk)))
      res)))


(defun comp-gen-symbol (e stat)
  (if (eq e nil)
      (let ()
        (enter-opcode 'LODNIL 0 stat)
        (increment-stack 1 stat))
    (let ((idx (get-stack-index e stat)))
      (if (null idx)
          (let ()
            (c-error 1 'comp-gen-symbol e "not found on stack")))
      (enter-opcode 'LOD idx stat)
      (increment-stack 1 stat))))


(defun comp-gen-progn (e stat)
  (maplist #'(lambda (z)
              (let ()
                (comp-gen (car z) stat)
                (if (not (null (cdr z)))
                    (let ()
                      (enter-opcode 'INCSP 1 stat)
                      (decrement-stack 1 stat))))) (cdr e)))

(defun comp-gen-let (e stat)
  (let ((head (car e))
        (args (cdr e)))
    (let ((vars (lambda-vars head))
          (body (lambda-body head)))
      (mapcar #'(lambda (z) (comp-gen z stat)) args)
      (decrement-stack (length vars) stat)
      (add-vars-stack (reverse vars) stat)
      (comp-gen body stat)
      (enter-opcode 'STO (length vars) stat)
      (decrement-stack 1 stat)
      (enter-opcode 'INCSP (- (length vars) 1) stat)
      (decrement-stack (length vars) stat)
      (increment-stack 1 stat))))
      

(defun comp-gen-primitive (e stat)
  (let ((head (car e))
        (args (cdr e)))
    (mapcar #'(lambda (z) (comp-gen z stat)) args)
    (enter-opcode head 0 stat)
    (decrement-stack (- (fun-arity head) 1) stat)))

    
(defun fun-arity (fun)
  (let ((i (emu::get-opcode (find-symbol (symbol-name fun) "EMU"))))
    (cadr (aref emu::*opcode-vector* i))))

(defun comp-gen-vector (e stat)
  (let ((args (cdr e)))
    (let ((nargs (length (cdr e))))
      (enter-literal nargs stat)
      (enter-opcode 'LITIDX (get-lit-index nargs stat) stat)
      (increment-stack 1 stat)
      (enter-opcode '%make-vector 0 stat)
      (do ((i 0 (+ i 1))
           (p args (cdr p)))
          ((null p))
        (enter-opcode 'LOD 0 stat)
        (increment-stack 1 stat)
        (enter-literal i stat)
        (enter-opcode 'LITIDX (get-lit-index i stat) stat)
        (increment-stack 1 stat)
        (comp-gen (car p) stat)
        (enter-opcode '%set-svref 0 stat)
        (decrement-stack 2 stat)
        (enter-opcode 'INCSP 1 stat)
        (decrement-stack 1 stat)))))

(defun comp-gen-funcall (e stat)
  (comp-gen-generic (cdr e) stat))




(defun comp-gen-apply (e stat)
  (let ((e1 (cdr e)))
    (let ((fun (car e1))
          (args (cdr e1))
          (nargs nil)
          (label-loop (gensym))
          (label-end (gensym))
          (q nil))
      (labels ((translate-fun (fun) (if (and (length=2 fun) (eq (car fun) '%symbol-value))
                                      (cons '%symbol-function (cdr fun))
                                    fun)))
        (setf fun (translate-fun fun)))
      (comp-gen fun stat)
      (setf q args)
      (setf nargs (do ((p args (cdr p))
                       (i 1 (+ i 1)))
                      ((length=1 p) i)
                    (comp-gen (car p) stat)
                    (setf q (cdr q))))
      (enter-literal nargs stat)
      (enter-opcode 'LITIDX (get-lit-index nargs stat) stat)
      (increment-stack 1 stat)
      (enter-opcode 'PUSHCS 0 stat)
      (enter-opcode 'INCSP 1 stat)
      (decrement-stack 1 stat)
      (comp-gen (car q) stat)
      (enter-opcode 'PUSHCS 0 stat)
      (enter-label label-loop stat)
      (enter-opcode 'JNIL label-end stat)
      (enter-opcode 'LODCS 0 stat)
      (enter-opcode 'CAR 0 stat)
      (enter-opcode 'LODCS 1 stat)
      (enter-literal 1 stat)
      (enter-opcode 'LITIDX (get-lit-index 1 stat) stat)
      (enter-opcode '%+ 0 stat)
      (enter-opcode 'STOCS 1 stat)
      (enter-opcode 'LODCS 0 stat)
      (enter-opcode 'CDR 0 stat)
      (enter-opcode 'LOD 0 stat)
      (enter-opcode 'STOCS 0 stat)
      (enter-opcode 'JMP label-loop stat)
      (enter-label label-end stat)
      (enter-opcode 'LODCS 1 stat)
      (enter-opcode 'INCCSP 2 stat)
      (enter-opcode 'CALLCLOSV 0 stat)
      (decrement-stack (+ nargs 1) stat)
      (increment-stack 1 stat))))

(defun tos (n)
  (loop for i from 0 to n do
        (format t "i =~A : ~A~%" i (msys::to-cl (msys::get-word (+ emu::*dsp* (* 4 i)) 0)))))



(defun comp-gen-if (e stat)
  (let ((tst (if-expr-tst e))
        (e1 (if-expr-branch-t e))
        (e2 (if-expr-branch-f e))
        (label (gensym))
        (label-ex (gensym)))
    (comp-gen tst stat)
    (enter-opcode 'JNIL label stat)
    (decrement-stack 1 stat)
    (comp-gen e1 stat)
    (enter-opcode 'JMP label-ex stat)
    (decrement-stack 1 stat)
    (enter-label label stat)
    (comp-gen e2 stat)
    (enter-label label-ex stat)))


(defun generate-rest-prolog (nvars stat)
  (let ((label-loop (gensym))
        (label-start (gensym))
        (label-ex (gensym)))
  (enter-opcode 'PUSHCS 0 stat)
  (enter-literal nvars stat)
  (enter-opcode 'LITIDX (get-lit-index nvars stat) stat)
  (increment-stack 1 stat)
  (enter-opcode '%< 0 stat)
  (decrement-stack 1 stat)
  (enter-opcode 'JNIL label-start stat)
  (decrement-stack 1 stat)
  (enter-opcode 'EXCEPT 0 stat)
  (enter-label label-start stat)
  (enter-opcode 'LODNIL 0 stat)
  (increment-stack 1 stat)
  (enter-label label-loop stat)
  (enter-opcode 'CONS 0 stat)
  (decrement-stack 1 stat)
  (enter-opcode 'LODCS 0 stat)
  (increment-stack 1 stat)
  (enter-literal 1 stat)
  (enter-opcode 'LITIDX (get-lit-index 1 stat) stat)
  (increment-stack 1 stat)
  (enter-opcode '%- 0 stat)
  (decrement-stack 1 stat)
  (enter-opcode 'INCCSP 1 stat)
  (enter-opcode 'PUSHCS 0 stat)
  (enter-opcode 'LITIDX (get-lit-index nvars stat) stat)
  (increment-stack 1 stat)
  (enter-opcode '%<  0 stat)
  (decrement-stack 1 stat)
  (enter-opcode 'JNIL label-loop stat)
  (decrement-stack 1 stat)
  (enter-opcode 'INCCSP 1 stat)))
  
(defun generate-standard-prolog (nvars stat)
  (let ()
    (enter-opcode 'INCSP 1 stat)
    (decrement-stack 1 stat)))



(defun comp-gen-lambda (e stat)
  (let ((vars (lambda-vars e))
        (body (lambda-body e)))
    (let ((ilist (get-ilist stat))
          (lits (get-lits stat))
          (stack (get-stack stat))
          (nvars (length vars))
          (rest nil))
      
      (set-stack stat nil)
      (set-ilist stat nil)
      (set-lits stat nil)
      
      (setf rest (member '&rest vars))
      (cond ((length=2 rest)
             (setf nvars (- nvars 1))
             (setf vars (remove '&rest vars)))
            ((null rest))
            (t (c-error 1 'comp-gen-lambda "illegal formed &rest")))
    
      (add-vars-stack (reverse vars) stat)
      (increment-stack 1 stat)
      
      (if (length=2 rest)
          (generate-rest-prolog nvars stat)
        (generate-standard-prolog nvars stat))

      (comp-gen body stat)
      (enter-opcode 'STO nvars stat)
      (decrement-stack 1 stat)
      (enter-opcode 'INCSP (- nvars 1) stat)
      (decrement-stack nvars stat)
      (increment-stack 1 stat)
      (enter-opcode 'RET 0 stat)
      (let ((templ (make-pretemplate stat)))
        (set-stack stat stack)
        (set-ilist stat ilist)
        (set-lits stat lits)
        (enter-literal templ stat)
        (enter-opcode 'LITIDX (get-lit-index templ stat) stat)
        (increment-stack 1 stat)
        templ))))


(defun comp-gen-generic (e stat)
  (let ((len (length e)))
    (mapcar #'(lambda (z) (comp-gen z stat)) e)
    (enter-opcode 'CALLCLOS len stat)
    (decrement-stack len stat)
    (increment-stack 1 stat)))

    


(defun comp-gen-embrace (stat)
  (enter-opcode 'HALT 0 stat))








(defun is-pretemplate (x)
  (and (listp x) (eq (car x) 'pre-template)))




(defun make-pretemplate (stat)
  (let ((lits (get-lits stat))
        (ilist (get-ilist stat)))
    (list 'pre-template lits ilist)))


; asm assembliert eine pretemplate zu einer template, die er direkt im speicher (des emu-systems) anlegt

(defun is-label-stmt (stmt)
  (eq (car stmt) 'label))

(defun get-opc (stmt labl-assoc idx)
  (if (null (find-symbol (symbol-name (car stmt)) "EMU"))
      (c-error 1 'get-opc "opcode" stmt " not resolvable"))
  (let ((opc (emu::get-opcode (find-symbol (symbol-name (car stmt)) "EMU"))))
    (let ((d (cadr stmt)))
      (if (symbolp d)
          (let ((subs (assoc d labl-assoc)))
            (if (null subs)
                (c-error 1 'get-opc " label cannot be resolved"))
            (setf d (- (cdr subs) idx))))
      (cons (logand opc 65535) (logand 65535 d)))))

(defun asm-templ (ptl)
  (let ((data (cadr ptl))
        (code (caddr ptl)))
    (let ((d-len (length data))
          (c-len nil)
          (labl-assoc nil)
          (stmt nil)
          (templ nil)
          (opc nil))
      (setf labl-assoc (do ((idx 0 idx)
                            (p code (cdr p)))
                           ((null p) labl-assoc)
                         (setf stmt (car p))
                         (if (is-label-stmt stmt)
                             (setf labl-assoc (cons (cons (cadr stmt) idx) labl-assoc))
                           (setf idx (+ idx 1)))))
      (setf code (remove-if #'(lambda (z) (is-label-stmt z)) code))
      (setf c-len (length code))
      (setf templ (msys::make-template (msys::cl-to d-len) (msys::cl-to c-len)))
      (do ((i 0 (+ i 1))
           (p data (cdr p)))
          ((>= i d-len))
        (msys::set-templ-ref-d templ (msys::cl-to i) (msys::cl-to (car p))))
      (do ((i 0 (+ i 1))
           (p code (cdr p)))
          ((>= i c-len))
        (setf opc (get-opc (car p) labl-assoc i))
        (msys::set-templ-ref-c templ (msys::cl-to i) (msys::cl-to (car opc)) (msys::cl-to (cdr opc))))
      templ)))

(defun disasm-opc (val)
  (let ((opc (logand (ash (logand val (ash 65535 16)) -16) 65535))
        (d (logand val 65535)))
    (let ((opc1 (car (aref emu::*opcode-vector* opc))))
      (setf opc1 (make-symbol (symbol-name opc1)))
      (list opc1 d))))

(defun disasm-templ (tpl)
  (let ((d-len (msys::to-cl (msys::length-d tpl)))
        (c-len (msys::to-cl (msys::get-word tpl (msys::cl-to 12))))
        (data nil)
        (code nil)
        (res nil))
    (do ((i 0 (+ i 1)))
        ((>= i d-len))
      (setf data (cons (msys::to-cl (msys::templ-ref-d tpl (msys::cl-to i))) data)))
    (setf data (reverse data))
    (do ((i 0 (+ i 1)))
        ((>= i c-len))
      (setf code (cons (disasm-opc (msys::templ-ref-c tpl (msys::cl-to i))) code)))
    (setf code (reverse code))
    (list 'pre-template data code)))








  
(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))
    (setf *xx* res)
    (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)))




(defun comp-x (e)
  (let ((res nil))
    (setf res (expand e))
    (setf res (comp-11 res))
    (setf res (comp-2 (car res) nil))
    (setf res (comp-11 (expand res)))
    (pprint res)
    (format t "~%************~%")
    (setf res (comp-3 (car res) nil))
    (setf res (expand res))
    (pprint res)
    (format t "~%************~%")
    (stat-init *stat*)
    (format t "res = ~A~%" res)
    (pprint res)
    (comp-gen res *stat*)
    (comp-gen-embrace *stat*)
    (setf *tt* (make-pretemplate *stat*))
    (format t "*stat* = ~A~%" *stat*)))


(defun tst1 (xx)
  (setf steps 100000)
  (setf *tst00* xx)
  (comp-x *tst00*)
  (setf tp (msys::cl-to *tt*))
  (emu::emu-init tp)
  (emu::run-processor steps))



(defparameter *tstxz* '(progn
                         (let ((a 1) (b 2))
                           (defun adder (x) #'(lambda (a) (%+ x a)))
                           (setq add3 (adder 3))
                           (setq add12 (adder 12))
                           (%print (funcall add3 7))
                           (%print (funcall add12 18)))))




(defparameter *tstxy* '(progn
                         (defun f (a b c) (cons (cons a b) c))
                         (defun lis (&rest x) x)
                         (%print (lis 1 2 3 4 5 6))
                         (%print (apply f (lis 1 2 3)))))

(defparameter *tstxx* '(progn
                         (defun f (a b c) (cons (cons a b) c))
                         (defun lis (&rest x) x)
                         (%print (lis 1 2 3 4 5 6))
                         (%print (apply f (apply f 1 '(77 88)) 3 (lis (apply f 1 '(5 6)))))))


(defparameter *tst01* '(progn
                         (defun f (n) (cond ((%<= n 1) 1)
                                            (1 (%+ (f (%- n 1)) (f (%- n 2))))))
                         (defun g (n) (cond ((%<= n 0) nil)
                                            (1 (cons (f n) (g (%- n 1))))))
                         (defun app (l x) (cond ((eq l nil) (cons x nil))
                                                (1 (cons (car l) (app (cdr l) x)))))
                         (defun rev (x) (cond ((eq x nil) nil)
                                              (1 (app (rev (cdr x)) (car x)))))
                         (%print (rev '(-1 -2 "juergen" -4 -5)))
                         (defun mapcar (f l) (cond ((eq l nil) nil)
                                                 (1 (cons (funcall f (car l)) (mapcar f (cdr l))))))
                         (%print (mapcar #'(lambda (z) (cons "juergen" (%* z -120000))) '(1 2 3 4 5)))
                         (%print (mapcar #'(lambda (z) (cons z z)) '(#\v #\n #\r #\g)))
                         (%print (mapcar #'(lambda (z) (apply app z)) '(((1 2 3 4) 99) ((5 6 7 8) 33)))))) 


(defparameter *tst00* '(labels ((f (n) (%* n n)) (g (n) (%+ (f n) (f n))))
                         (%print (g 12))))                         

(defparameter *tst02* 
  '(progn 
     (setq x 10)
     (let ((a 1))
     (labels ((f (n) (cond ((%<= n a) a)
                           (1 (%+ (f (%- n 1)) (f (%- n 2))))))
              (g (n) (cond ((%<= n 1) nil)
                           (1 (cons (f n) (g (%- n 1)))))))
       (%print (g x))))))


(defparameter *tst03*
  '(progn (labels ((f (n) (%* n n)))
            (setq ff #'(lambda (z) (f z))))
     (%print (funcall ff 12))))




;;;; (defparameter *tst00* '(let ((a 1)
;;;;                              (b 2)
;;;;                              (c 3))
;;;;                          (let ((d 4))
;;;;                            (%print (vector a b c d)))))


(defparameter *tst04* 
  '(progn
     (defun f (a &rest b) (cons a (cons b nil)))
     (%print (f 1 2 3 4))
     (let ((a 1) (b 10) (c 100))
       (%print (%* b (%- a c))))))


(defparameter *tst05*
  '(let ((a 1) (b 2))
     (if (and (%= a b) (%= a a)) (%print a) (%print b))
     (if (and (%= a a) (%= a b)) (%print a) (%print b))
     (if (and (%= a a) (%= b b)) (%print a) (%print b))

     (if (or (%= a b) (%= a a)) (%print a) (%print b))
     (if (or (%= a a) (%= a b)) (%print a) (%print b))
     (if (or (%/= a a) (%/= b b)) (%print a) (%print b))))





(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 #'(lambda (t) (setq a s)))  (setq f s) (setq r g))))
                          (progn (f p q) (g a b) (setq c (lambda (t) (setq t g)))))))

(defparameter *tst6* '(progn (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))) (h 6)))

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

(defparameter *tst62* '(defun h (a &rest a1) 
                        (labels ((f (n &rest n1) (cond ((<= n 1) 1)
                                              (1 (+ (f (- n 1)) (f (- n 2))))))
                                 (g (k) (cond ((<= k 1) nil)
                                              (1 (cons (f k) (g (- k 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))))