(in-package "CL-USER")

;; 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-do-until e) (comp-3-do-until e sl))
             ((is-primitive e) (comp-3-nohead e sl))
             ((is-system 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-do-until (e sl)
  (let ((second (cadr e))
        (body (cddr e)))
    (append 
     (list 'do-until
           (cons (comp-3 (car second) sl) (comp-3-generic (cdr second) sl)))
           (comp-3-generic body sl))))


(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-generic 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 (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 ((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-generic e-body sl-1)) 
                                                         (list '%svref cv-var 0)))))
                      (make-let (list cv-var) (list (cons 'vector clos-vect))
                                let-body)))))))))))