(in-package "CL-USER")



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


;;
;; an experiment in backquote expansion
;;

(defun is-comma-at (e)
  (and (consp e) (eq (car e) 'comma-at) (null (cddr e))))

(defun is-comma (e)
  (and (consp e) (eq (car e) 'comma) (null (cddr e))))

(defun is-bq (e)
  (and (consp e) (eq (car e) 'bq) (null (cddr e))))


;; (bq-expand-1 e) expresses (bq e) without comma, comma-at and backquote

;;

(defun bq-extend-list (el lis)
  (if (is-comma-at el)
      (case (car lis)
        (list (cons 'append (list (bq-expand-1 el) lis)))
        (append (cons 'append (cons (bq-expand-1 el) (cdr lis)))))
    (case (car lis)
      (list (cons 'list (cons (bq-expand-1 el) (cdr lis))))
      (append (cons 'append (cons (list 'list (bq-expand-1 el)) (cdr lis)))))))

(defun bq-expand-1 (e)
  (cond ((atom e)
         (list 'quote e))
        ((is-bq e)
         (bq-expand-1 (bq-expand-1 (cadr e))))
        ((is-comma e)
         (bq-expand (cadr e)))
        ((is-comma-at e)
         (bq-expand (cadr e)))
        ((listp e)
         (fold #'(lambda (el ll) (bq-extend-list el ll)) '(list) e))
        (t (error "bq-expand-1: 000: case not implemented."))))


;; (bq-expand e) expresses e without comma, comma-at and backquote

(defun bq-expand (e)
  (cond ((atom e)
         e)
        (t (cond
            ((is-bq e)
             (cond ((is-comma (cadr e))
                    (bq-expand (cadr (cadr e))))
                   ((is-comma-at (cadr e))
                    (bq-expand (cadr (cadr e))))
                   (t
                    (bq-expand-1 (cadr e)))))
            (t (cond ((listp e)
                      (mapcar #'bq-expand e))
                     (t (error "bq-expand: 000: case not implemented."))))))))
                   






(defun expand (e)
  (labels
      ((and-expand (e)
         (cond ((null (cdr e))
                t)
               ((null (cddr e))
                (expand (cadr e)))
               (t (let ()
                    (list 'if (expand (cadr e)) (expand (cons 'and (cddr e))) nil)))))
       (or-expand (e)
         (cond ((null (cdr e))
                nil)
               ((null (cddr e))
                (expand (cadr e)))
               (t (let ((var (gensym)))
                    (expand (list (make-lambda (list var) (list (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)) (expand (list (cadar vars))) (let-body e)))
                           (t (make-let (list (caar vars)) (expand (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 (let-vars e)) (mapcar #'expand (let-body e)))
               (expand (mapcar #'cadr (let-vars 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)))))))))
       (when-expand (e)
         (let ((cnd (cadr e))
               (e-lis (cddr e)))
           (list 'if (expand cnd) (expand (cons 'progn e-lis)))))
       (defun-expand (e)
         (list '%set-symbol-function (list 'quote (cadr e))
               (expand (make-lambda (caddr e) (cdddr e)))))
       (do-expand (e)
         (let ((inits (cadr e))
               (test-exit (caddr e))
               (body (cdddr e)))
           (if (null inits)
               (let ()
                 `(do-until ,(expand test-exit) ,@(expand body)))
             (let* ((vars-init (mapcar #'car inits))
                    (vals-init (mapcar #'cadr inits))
                    (steps (mapcar #'caddr inits))
                    (vars-dummy (mapcar #'(lambda (z) (get-unique-var z)) vars-init))) 
             
               (expand (make-let vars-init (mapcar #'expand vals-init)
                                 (list 
                                  (append 
                                   (list
                                    'do-until (expand test-exit))
                                   (append (expand body)
                                           (list (make-let 
                                                  vars-dummy 
                                                  (mapcar #'expand steps)
                                                  (zip #'(lambda (x y) (list 'setq x y)) vars-init vars-dummy))))))))))))
       (dolist-expand (e)
         (let* ((second (cadr e))
                (body (cddr e))
                (var (car second))
                (lis (cadr second))
                (auxvar (get-unique-var var)))
           (expand (append (list 'do 
                                 (list (list auxvar lis (list 'cdr auxvar)))
                                 (list (list 'null auxvar)))
                           (list (make-let (list var) (list (list 'car auxvar)) body))))))

       (defconstant-expand (e)
         (push (cons (cadr e) (caddr e)) *global-const-list*)
         (caddr e))

       (mul-expand (e)
         (let ((op1 (cadr e))
               (op2 (caddr e)))
           (if (is-power-of-two op1)
               (let ((m op2))
                 (setf op2 op1)
                 (setf op1 m)))
           (if (is-power-of-two op2)
               (do ((l op2 l)
                    (i 0 i))
                   ((= l 1) 
                    (return-from mul-expand 
                      (if (> i 0)
                          `(p-shiftl ,(expand op1) ,i)
                        (expand op1))))
                 (multiple-value-bind (q r) (floor l 2)
                   (setf i (+ i 1))
                   (setf l q)))
             (progn
               (format t "no strength reduction possible in: ~a~%" e)
               (let ((res `(mul ,(expand op1) ,(expand op2))))
                 (format t "res = ~a~%" res)
                 res)))))

             
                      


       (atom-expand (e)
         (if (symbolp e)
             (let ((val (assoc e *global-const-list*)))
               (if val
                   (cdr val)
                 e))
           e))
         

       (multiple-value-bind-expand (e)
         (let* ((vars (cadr e))
                (fn (caddr e))
                (elis (cdddr e))
                (nvars (length vars)))
           (expand (append (list (append (list 'lambda vars) elis)  fn) 
                           (do ((i 0 (+ i 1))
                                (res nil res)) 
                               ((>= i (- nvars 1)) (reverse res))
                             (setf res 
                                   (cons (list '%svref (list '%symbol-value (list 'quote 'valuesq))
                                               (list '%+ (list '%symbol-value 
                                                                 (list 'quote 'valuescntq)) (+ i 1))) res)))))))
       
                         
         

       (generic-expand (e)
         (mapcar #'expand e)))
    
    (cond ((atom e) (atom-expand e))
          ((stringp e) e)
          ((listp e)
           (let ((head (car e)))
             (cond ((eq head 'backquote)
                    (bq-expand e))
                   ((eq head 'defstruct)
                    (defstruct-expand e))
                   ((eq head 'setf)
                    (setf-expand e))
                   ((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 'when)
                    (when-expand e))
                   ((eq head 'defun)
                    (defun-expand e))
                   ((eq head 'do)
                    (do-expand e))
                   ((eq head 'dolist)
                    (dolist-expand e))
                   ((eq head 'defconstant)
                    (defconstant-expand e))
                   ((eq head '%*)
                    (mul-expand e))
                   ((eq head 'multiple-value-bind)
                    (multiple-value-bind-expand e))
                   ((is-struct-accessor head)
                    (rewrite-struct-accessor 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 (labels-body 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-generic 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-generic 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 (labels-body 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))

            (format t "e-body = ~A~%" e-body)
            (setf res-body (comp-11-generic e-body))
            (format t "res-body = ~A~%" res-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))