(define-module (language clambda clambda2)
  #:use-module (ice-9    match                )
  #:use-module (language clambda clambda-meta )
  #:use-module (language clambda meta         )
  #:use-module (language clambda fmt          )
  #:export     (clambda->c *debug-clambda* f-define f-sub f-let* f-if  
                           z f-begin f-call f-recur f-next <=> <==> <recur> <next> <call> <+> <-> <*> </>
                           q< q> q<= q>= <and> <or> <!=> <bit-and> <bit-or>
                           <bit-xor> <define> <if> <let*> <begin> 
                           ))


;; ********************* TOOLBOX ********************
(define-syntax auto-quote
  (lambda (x)
    (syntax-case x ()
      ((_ a)
       (let ((v (syntax->datum #'a)))
         (if (symbol? v)
             #'(quote a)
             #'a))))))

(define-syntax auto
  (syntax-rules ()
    ((_ (a ...)) (a ...))
    ((_ a      ) (z (auto-quote a)))))

(define (my-block . a)
  (if (> (length a) 1)
      (apply c-block `(,fmt-null ,@a))
      (car a)))

(define old-pk pk)
(define *debug-clambda* #t)
(define pk (lambda (x)
             (if *debug-clambda* (old-pk x) x)))

(define void-it (lambda (c) (c #f)))

(define (z x) 
  (lambda (v)
    (match v
      (#f       x)
      (v  (c= v x)))))

(define (z-2 x)
  (match x
    ((_ _) x)
    (x     `(SCM ,x))))

(define (z-3 x)
  (match x
    ((_ _ _) x)
    ((s   v) `(SCM ,s ,v))))

(define (clambda->c x) 
  (fmt #f           
       (fmt-let 'braceless-bodies? #f
                x)))

;; ********************************** DEFINE/SUB *************************
(define (f-define f args . code)
  (define function-type car)
  (define function-sym  cadr)
  
  (let ((r (gensym "ret")))
    (let* ((f     (z-2 f))
           (args  (map z-2 args))
           (ts    (map car args)))
      (c-fun (function-type f)
             (function-sym  f)
             args
             (my-block
              (c-var (function-type f) r)
              ((apply f-begin code) r)
              r)))))

(define-syntax <define>
  (syntax-rules ()
    ((_ f (a ...) code ...)
     (let ((fq (farg f))
           (aq (list (farg a) ...)))
       (set-symbol-property! (cadr fq) 'fkn-signature (map car aq))
       (f-define fq aq (auto code) ...)))))

(define-syntax farg
  (syntax-rules ()
    ((_ (t a))  '(t a))
    ((_ a    )  '(SCM a))))

(define (f-sub f args . code)
  (define function-type car)
  (define function-sym  cadr)

  (let ((f     (z-2 f))
        (args  (map z-2 args)))
    (c-fun (function-type f)
           (function-sym  f)
           args
           ((apply f-begin code) #f))))

#|
(f-define '(int f) '((int a)) code ...)
|#

;; ************************************ BEGIN *************************
(define (f-begin . a)
  (lambda (v)
    (if v
        (match a  
          ((a ... b)  
           (apply my-block `(,@(map void-it a) ,(b v)))))
        (apply my-block (map void-it a)))))

(define-syntax <begin> 
  (syntax-rules ()
    ((_ a ...) (f-begin (auto a) ...))))

;; ************************************** if *************************
(define (f-if p x y)
  (lambda (v)
    (let ((pred (gensym "pred")))
      (my-block
       (c-var 'int pred)
       (p pred)
       (c-if pred (x v) (y v))))))
  
(define-syntax <if>
  (syntax-rules ()
    ((_ p x y) (f-if (auto p) (auto x) (auto y)))))

;; ************************************** let* ***********************
(define (f-let* vars . code)
  (lambda (v)
    (define (f x)
      (match x
        ((t s v) (c-var t s))))

    (define (g x)
      (match x
        ((t s v) (v s))))

    (define (mk-vars x)
      (match x
        ((x . l)  `(,(f x) ,(g x) ,@(mk-vars l)))
        (()       '())))
    (apply my-block `(,@(mk-vars (map z-3 (pk vars))) ,((apply f-begin code) v)))))

(define-syntax <let*>
  (syntax-rules ()
    ((_ (v ...) code ...)  (f-let* `(,(leta v) ...) code ...))))

(define-syntax leta
  (syntax-rules ()
    ((_ a v)   (z-3 (list 'a (auto v))))
    ((_ t a v) (z-3 (list 't 'a (auto v))))))

;; ************************************** call  *******************
(define (f-call0 f ts arg)
  (pk ts)
  (pk arg)
  (lambda (v)
    (let* ((vl   (map (lambda (x)   (gensym "a")) ts))
           (defs (map (lambda (s t) (c-var t s))  vl ts))
           (sets (map (lambda (s a) (a s))        vl arg)))
      (if v
          (apply my-block `(,@defs ,@sets ,(c= v `(,f ,@vl))))
          (apply my-block `(,@defs ,@sets `(,f ,@vl)))))))

(define (f-call f . a) (f-call0 f (symbol-property f 'fkn-signature) a))

(define-syntax <call>
  (syntax-rules ()
    ((_ f a ...)
     (f-call (auto f) (auto a) ...))))

;; ************************************** recur *******************
;  TAIL CALL VERSION ONLY

(define-syntax <recur>
  (syntax-rules ()
    ((_ sym ((a ...) ...) code ...)
     (f-recur 'sym (list (leta a ...) ...) (auto code) ...))))

(define-syntax f-recur
  (syntax-rules ()
    ((_ sym vars code ...)
     (begin
       (set-symbol-property! sym 'recur (map cadr (map z-3 vars)))
       (f-recur0 sym vars code ...)))))

(define (f-recur0 sym vars . code)
  (lambda (v)
     (define (f x)
      (match x
        ((t s v) (c-var t s))))

     (define (g x)       
       (match x
         ((t s v) (v s))))

    (define (mk-vars x)
      (match x
        ((x . l)  `(,(f x) ,(g x) ,@(mk-vars l)))
        (()       '())))

    (apply my-block `(,@(mk-vars (map z-3 vars))
                      ,(c-label sym)
                      ,((apply f-begin code) v)))))


(define-syntax <next>
  (syntax-rules ()
    ((_ sym a ...)
     (f-next 'sym (auto a) ...))))
                     
(define (f-next sym . as)
    (lambda (v)
      (let ((ss (symbol-property sym 'recur)))
        (apply my-block
               `(,@(map (lambda (a s) (a s)) as ss)
                 ,(c-goto sym))))))



    
;; ************************************** binop *******************
(define-syntax mk-op-2
  (syntax-rules ()
    ((_ op cop)
     (define-syntax op 
       (syntax-rules ()
         ((_ op t x y)
          (lambda (v)
            (let ((xx (gensym "x"))
                  (yy (gensym "y")))
              (my-block
               (c-var (auto t) xx)
               (c-var (auto t) yy)
               ((auto x) xx)
               ((auto y) yy)
               (c= v (cop xx yy))))))
         
          ((_ x y)
           (lambda (v)
             (let ((xx (gensym "x"))
                   (yy (gensym "y")))
               (my-block
                (c-var 'int xx)
                (c-var 'int yy)
                ((auto x) xx)
                ((auto y) yy)
                (c= v (cop xx yy)))))))))))
                
(mk-op-2 <=>        c=   )
(mk-op-2 <!=>       c!=  )
(mk-op-2 <==>       c==  )
(mk-op-2 <+>        c+   )
(mk-op-2 <->        c-   )
(mk-op-2 <*>        c*   )
(mk-op-2 </>        c/   )
(mk-op-2 <and>      c&&  )
(mk-op-2 <or>       c-or )
(mk-op-2 <bit-and>  c&   )
(mk-op-2 <bit-or>   c-bit-or)
(mk-op-2 <bit-xor>  c^   )
(mk-op-2 q<         c<   )
(mk-op-2 q>         c>   )
(mk-op-2 q<=        c<=  )
(mk-op-2 q>=        c>=  )