(module flsim-cc

	*
	
	(import scheme chicken)
	
	(require-extension data-structures srfi-1 datatype)


(define-record-type ident
  (make-ident name stamp)
  ident?
  (name   ident-name) 
  (stamp  ident-stamp)
  )


(define ident-create   (let ((currstamp (make-parameter 0)))
			 (lambda (s) 
			   (currstamp (+ 1 (currstamp)))
			   (make-ident s (currstamp)))))
(define  ident-equal? (lambda (id1 id2) (= (ident-stamp id1) 
					   (ident-stamp id2))))
(define ident-empty '())
(define ident-add  (lambda (id data tbl) 
		    (cons (cons id data) tbl)))
(define ident-find  (let ((compare (lambda (x y) (equal? (ident-name x) (ident-name y)))))
		      (lambda (id1 tbl)
			(alist-ref id1 tbl compare))))


(define fv-empty '())
(define (fv-empty? a)          (equal? a '()))
(define (fv-singleton x)       (list x))
(define (fv-remove x a)        (let recur ((a a) (a1 '()))
				 (if (null? a) a1
				     (if (equal? x (car a))
					 (recur (cdr a) a1)
					 (recur (cdr a) (cons x a1))))))
(define (fv-add x a)           (lset-adjoin equal? a x))
(define (fv-union a b)         (lset-union equal? b a))
(define (fv-difference a b)    (lset-difference equal? b a))



(define-datatype cvalue cvalue?
  (CV:C       (v (lambda (x) (or (symbol? x) (number? x) ))))
  (CV:Var     (name ident?))
  (CV:Rec     (flds (lambda (x) (and (pair? x) (every (lambda (x) (and (symbol? (car x)) (cvalue? (cadr x)))) flds)))))
  (CV:Sel     (field (lambda (x) (or (symbol? x) (integer? x)))) (v cvalue?))
  (CV:Vec     (vals (lambda (x) (every cvalue? x))))
  (CV:Sub     (index (lambda (x) (and (integer? x) (or (zero? x) (positive? x))))) (v cvalue?))
  (CV:Ldv     (v cvalue?))
  (CV:Stv     (v cvalue?))
  (CV:Ifv     (test cvalue?)  (ift cvalue?) (iff cvalue?))
  (CV:Prim    (name ident?)  (args (lambda (x) (every cvalue? x))))
  (CV:Fn      (args pair?) (ts pair?) (body cexpr?))
  )


(define-datatype cexpr cexpr?
  (CE:Ife     (test cvalue?)   (ift cexpr?) (iff cexpr?))
  (CE:Let     (bnds pair?)    (body cexpr?))
  (CE:Set     (loc cvalue?)    (v cvalue?))
  (CE:Ret     (v cvalue?))
  (CE:Seq     (exprs pair?))
  (CE:Noop)
  )

(define-datatype cdecl cdecl?
  (CD:Val     (name symbol?)  (t pair?) (v cvalue?)))


(define (cvalue-fv v)
  (cases cvalue v
	 (CV:C (c)         fv-empty)
	 (CV:Var (n)       (fv-singleton (ident-name n)))
	 (CV:Rec (flds)    (fold (compose fv-union cvalue-fv) fv-empty (map cadr flds)))
	 (CV:Sel (field v) (cvalue-fv v))
	 (CV:Vec (vals)    (fold (compose fv-union cvalue-fv) fv-empty vals))
	 (CV:Sub (index v) (cvalue-fv v))
	 (CV:Ldv (v)       (cvalue-fv v))
	 (CV:Stv (v)       (cvalue-fv v))
	 (CV:Ifv  (v1 v2 v3) (fv-union (cvalue-fv v1) (fv-union (cvalue-fv v2) (cvalue-fv v3) )))
	 (CV:Prim (n args) (fv-union (fv-singleton (ident-name n)) 
				     (fold (compose fv-union cvalue-fv) fv-empty args)))
	 (CV:Fn  (args ts body) (fold fv-remove (cexpr-fv body) args))
	 ))
	 


(define (cexpr-fv x)  
  (cases cexpr x
	 (CE:Ife (v1 e2 e3)  (fv-union (cvalue-fv v1) (fv-union (cexpr-fv e2) (cexpr-fv e3))))
	 (CE:Let (bnds body) (fv-union 
			      (cexpr-fv body)
			      (fold fv-remove
				    (fold (compose fv-union cvalue-fv) fv-empty (map cadr bnds))
				    (map car bnds))))
	 (CE:Set (loc v)     (fv-union (cvalue-fv loc) (cvalue-fv v)))
	 (CE:Ret (v)         (cvalue-fv v))
	 (CE:Seq (es)        (fold (compose fv-union cexpr-fv) fv-empty es))
	 (CE:Noop ()         fv-empty)))



(define (cvalue-type v tenv)
  (cases cvalue v
	 (CV:C (v)  
	      (cond ((symbol? v) (alist-ref v tenv))
		    ((number? v) '(number))))
	 (CV:Var (x) 
		(ident-find x tenv))
	 (CV:Rec (vflds) 
		 `(record . ,(map (lambda (x) (list (car x) (cvalue-type (cadr x) tenv))) vflds)))
	 (CV:Sel (fld v) 
		 (let ((vtype (cvalue-type v tenv)))
		   (case (car vtype)
		     ((record) (alist-ref fld (cdr vtype)))
		     (else (error 'cvalue-type "invalid argument type for V:Sel" vtype)))))
	 (CV:Vec (v) 
		 (let ((ts (delete-duplicates (map (lambda (v) (cvalue-type v tenv)) v))))
		   (if (> (length ts) 1) (error 'cvalue-type "invalid argument type for V:Vec" v)
		       `(vector . ,(car ts)))))
	 (CV:Sub (index v) 
		(let ((vtype (cvalue-type v tenv)))
		  (case (car vtype)
		    ((vector) (cadr vtype))
		    (else (error 'cvalue-type "invalid argument type for V:Sub" vtype)))))
	 (CV:Ldv (v)
		(let ((vtype (cvalue-type v tenv)))
		  (case (car vtype)
		    ((pointer) (cadr vtype))
		    (else (error 'cvalue-type "invalid argument type for V:Ldv" vtype)))))
	 (CV:Stv (v)
		(let ((vtype (cvalue-type v tenv)))
		  `(pointer ,vtype)))
	 (CV:Ifv     (test ift iff)
		     (let ((ttest  (cvalue-type test tenv))
			   (tift   (cvalue-type ift tenv))
			   (tiff   (cvalue-type iff tenv)))
		       (if (equal? tift tiff)
			   tift (error 'cvalue-type "true and false clauses do not have the same type in V:Ifv" tift tiff))))
	 (CV:Prim (x args)
		  (let ((ftype (ident-find x tenv)))
		    (let ((argts (map (lambda (v) (cvalue-type v tenv)) args)))
		      (let recur ((argts argts)  (ftype ftype))
			(if (null? argts) ftype
			    (case (car ftype)
			      ((arrow)  (if (equal? (cadr ftype) (car argts))
					    (recur (cdr argts) (cadr ftype))))
			      (else (error 'cvalue-type "invalid argument type for CV:Prim" ftype)))))
		      )))
	 (CV:Fn (args ts body)
		(let ((bt (cexpr-type body (fold ident-add tenv args ts))))
		  (fold (lambda (t ax) `(arrow ,t ,ax)) bt (reverse ts) )))

	 ))
  


(define (cexpr-type e tenv)
  (cases cexpr e
	 (CE:Let     (bnds body)    
		     (let ((ltenv (fold (lambda (bnd env) (ident-add (ident-create (car bnd)) (cadr bnd) env)) tenv bnds)))
		       (cexpr-type body ltenv)))

	 (CE:Set     (loc v)  
		     (let ((tloc (cvalue-type loc tenv))
			   (tv (cvalue-type v tenv)))
		       (case (car tloc)
			 ((pointer) (if (equal? tv (cadr tloc)) `(void) 
					(error 'cexpr-type "incompatible pointer value" tloc tv)))
			 (else (error 'cexpr-type "first argument to CE:Set must be a pointer" loc)))))

	 (CE:Seq     (es)     
		     (let ((ts (map (lambda (e) (cexpr-type e tenv)) es)))
		       (last ts)))

	 (CE:Ife     (test ift iff) 
		     (let ((ttest (cvalue-type test tenv))
			   (tift  (cexpr-type ift tenv))
			   (tiff  (cexpr-type iff tenv)))
		       (if (equal? tift tiff) tift
			   (error 'cexpr-type "true and false clauses do not have the same type in E:Ifv" tift tiff))
		       ))


	 (CE:Ret     (v)  (cvalue-type v tenv) )

	 (CE:Noop    ()   `(void) )
	 ))


(define (cvalue-type-unify v tenv)
  (cases cvalue v
	 (CV:C (v)  
	      (cond ((symbol? v) (alist-ref v tenv))
		    ((number? v) '(number))))
	 (CV:Var (x) (ident-find x tenv))
	 (CV:Rec (vflds) 
		 `(record . ,(map (lambda (x) (list (car x) (cvalue-type-unify (cadr x) tenv))) vflds)))
	 (CV:Sel (fld v) 
		 (let ((vtype (cvalue-type-unify v tenv)))
		   (case (car vtype)
		     ((record) (alist-ref fld (cdr vtype)))
		     (else (error 'cvalue-type-unify "invalid argument type for V:Sel" vtype)))))
	 (CV:Vec (v) 
		 (let ((ts (delete-duplicates (map (lambda (v) (cvalue-type-unify v tenv)) v))))
		   (if (> (length ts) 1) (error 'cvalue-type-unify "invalid argument type for V:Vec" v)
		       `(vector . ,(car ts)))))
	 (CV:Sub (index v) 
		(let ((vtype (cvalue-type-unify v tenv)))
		  (case (car vtype)
		    ((vector) (cadr vtype))
		    (else (error 'cvalue-type-unify "invalid argument type for V:Sub" vtype)))))
	 (CV:Ldv (v)
		(let ((vtype (cvalue-type-unify v tenv)))
		  (case (car vtype)
		    ((pointer) (cadr vtype))
		    (else (error 'cvalue-type-unify "invalid argument type for V:Ldv" vtype)))))
	 (CV:Stv (v)
		(let ((vtype (cvalue-type-unify v tenv)))
		  `(pointer ,vtype)))
	 (CV:Ifv     (test ift iff)
		     (let ((ttest  (cvalue-type-unify test tenv))
			   (tift   (cvalue-type-unify ift tenv))
			   (tiff   (cvalue-type-unify iff tenv)))
		       (if (equal? tift tiff)
			   tift (error 'cvalue-type-unify "true and false clauses do not have the same type in V:Ifv" tift tiff))))
	 (CV:Prim (x args)
		  (let ((ftype (ident-find x tenv)))
		    (let ((argts (map (lambda (v) (cvalue-type-unify v tenv)) args)))
		      (let recur ((argts argts)  (ftype ftype))
			(if (null? argts) ftype
			    (case (car ftype)
			      ((arrow)  (let ((argty (car argts)))
					  (case (car argty)
					    ((tvar)  (let ((p (cadr argty)))
						       (p (cons (cadr ftype) (p)))
						       (recur (cdr argts) (cddr ftype))))
					    (else
					     (if (equal? (cadr ftype) argty)
						 (recur (cdr argts) (cddr ftype))
						 (else (error 'cvalue-type-unify "invalid argument type for CV:Prim" ftype)))))))
			      (else (error 'cvalue-type-unify "invalid function type for CV:Prim" ftype)))))
		      )))
	 (CV:Fn (args ts body)
		(let ((bt (cexpr-type-unify body (fold ident-add tenv args ts))))
		  (fold (lambda (t ax) `(arrow ,t ,ax)) bt (reverse ts) )))

	 ))


(define (cexpr-type-unify e tenv)
  (cases cexpr e
	 (CE:Let     (bnds body)    
		     (let ((tenv1 (fold (lambda (b tenv) 
					  (let ((t (cvalue-type-unify (cadr b) tenv)))
					    (ident-add (car b) t tenv)))
					tenv bnds)))
		       (cexpr-type-unify body tenv1)))

	 (CE:Set     (loc v)  
		     (let ((tloc (cvalue-type-unify loc tenv))
			   (tv (cvalue-type-unify v tenv)))
		       (case (car tloc)
			 ((pointer) (if (equal? tv (cadr tloc)) `(void) 
					(error 'cexpr-type-unify "incompatible pointer value" tloc tv)))
			 (else (error 'cexpr-type-unify "first argument to CE:Set must be a pointer" loc)))))

	 (CE:Seq     (es)     
		     (let ((ts (map (lambda (e) (cexpr-type-unify e tenv)) es)))
		       (last ts)))

	 (CE:Ife     (test ift iff) 
		     (let ((ttest (cvalue-type-unify test tenv))
			   (tift  (cexpr-type-unify ift tenv))
			   (tiff  (cexpr-type-unify iff tenv)))
		       (if (equal? tift tiff) tift
			   (error 'cexpr-type-unify "true and false clauses do not have the same type in E:Ifv" tift tiff))
		       ))


	 (CE:Ret     (v)  (cvalue-type-unify v tenv) )

	 (CE:Noop    ()   `(void) )
	 ))



(define (ctransform xs decls #!key (env ident-empty) (tenv ident-empty))

  (if (null? xs) (reverse decls)
      
      (cases expr (car xs) 
	 
	 (E:Val (name val)

		(let ((id (ident-create name))
		      (val1  (ctransform-val val env tenv)))

		  (let ((t1 (cvalue-type val1 tenv)))

		    (ctransform (cdr xs)
				(cons (CD:Val name t1 val1) decls)
				env: (ident-add id val1 env)
				tenv: (ident-add id t1 tenv)))))

	 (else (error 'ctransform "invalid declaration: " (car xs))))
      ))


					      
(define (ctransform-val v env tenv)
  (cases value v
	 (V:C       (k)  (CV:C k) )

	 (V:Var     (n)  (CV:Var n) )

	 (V:Rec     (flds) (let recur ((flds flds) (flds1 '()))
			     (if (null? flds) (CV:Rec (reverse flds1))
				 (let ((fld (car flds)))
				   (let ((n (car fld)) (v (cadr fld)))
				     (let ((v1 (ctransform-val v env tenv)))
				       (recur (cdr flds) (cons (list n v1) flds1)))
				     ))
				 )))

	 (V:Sel     (fld v) (let ((v1 (ctransform-val v env tenv)))
			      (CV:Sel fld v1) ))

	 (V:Vec     (vals)  (let recur ((vals vals) (vals1 '()) (env env) (tenv tenv))
				     (if (null? vals) (values (CV:Vec (reverse vals1)) env tenv)
					   (let ((v (car vals)))
					     (let-values (((v1 env1 tenv1) (ctransform-val v env tenv)))
					       (recur (cdr vals) (cons v1 vals1) env1 tenv1)))
					     )))

	 (V:Sub     (index v) (let ((v1 (ctransform-val v env tenv)))
				(CV:Sub index v1) ))
		    
	 (V:Ldv     (v)       (let ((v1 (ctransform-val v env tenv)))
				(CV:Ldv v1) ))

	 (V:Stv     (v)       (let ((v1 (ctransform-val v env tenv)))
				(CV:Stv v1) ))

	 (V:Fn      (args body) (ctransform-fn args body env tenv))

	 (V:Prim    (name vs)  (let recur ((vals vs) (vals1 '()))
				 (if (null? vals) 
				     (let ((n (ident-create name)))
				       (CV:Prim (CV:Sel 'fn (CV:Var n)) 
						(cons (CV:Sel 'env (CV:Var n)) (reverse vals1))))
				     (let ((v (car vals)))
				       (let ((v1 (ctransform-val v env tenv)))
					 (recur (cdr vals) (cons v1 vals1))))
				     )))

	 (V:Ifv     (test ift iff) (let recur ((vals (list test ift iff)) (vals1 '()) )
				     (if (null? vals) (CV:Ifv (reverse vals1))
					   (let ((v (car vals)))
					     (let ((v1 (ctransform-val v env tenv)))
					       (recur (cdr vals) (cons v1 vals1) )))
					     )))

	 ))


(define (ctransform-expr e env tenv)
  (cases expr e
	 (E:Val     (name v)
		    (error 'ctransform-expr "internal declaration encountered" e))

	 (E:Ife     (test ift iff)
		    (CE:Ife (ctransform-val test env tenv)
			    (ctransform-expr ift env tenv)
			    (ctransform-expr iff env tenv)))

	 (E:Let     (bnds body)
		    (CE:Let (map (lambda (x) (list (car x) (ctransform-expr (cadr x) env tenv))) bnds)
			    (ctransform-expr body)))
			  
	 (E:Set     (loc v)
		    (CE:Set (ctransform-val loc env tenv) (ctransform-val v env tenv)))

	 (E:Ret     (v)  
		    (CE:Ret (ctransform-val v env tenv)))
		    
	 (E:Seq     (exprs)
		    (CE:Seq (map (lambda (x) (ctransform-expr x env tenv)) exprs)))

	 (E:Noop    () (CE:Noop))))

					    

(define (ctransform-fn args body env tenv)

  (let* ((xargs (map ident-create args))
	 (ltenv (fold (lambda (x env) (ident-add x `(tvar ,(make-parameter '())) env)) tenv xargs))
	 (body1 (ctransform-expr body env ltenv))
	 (fvs   (fold fv-remove (cexpr-fv body1) args))
	 (xenv  (ident-create (gensym 'xenv)))
	 (cenv  (CV:Rec (map (lambda (x)
			       (let ((ix (ident-create x)))
				 (list x (ident-find ix env)))) fvs)))
	 (cbody   (CE:Let (map (lambda (x) (list x (CV:Sel x (CV:Var xenv)))) fvs) body1))
	 (ltenv1  (fold (lambda (x env) (cexpr-type-unify cbody env)) ltenv xargs))
	 (ts      (map (lambda (x) (let ((t (ident-find x ltenv1)))
				     (case (car t)
				       ((tvar)  (let ((p ((cadr t))))
						  (if (null? (cdr p)) (car p)
						      (error 'ctransform-fn "multiple types for function argument" x p))))
				       (else  (error 'ctransform-fn "invalid argument type" x t)))))
		       xargs)))

	(CV:Rec (list (list 'env cenv) (list 'fn (CV:Fn xargs ts cbody))))

	))



)