(datatype symtab-entry
  (var ty init)
  (fun ty body))

(define-record-type expty
  (exp ty)
  ())

(define-record-discloser type/expty
  (lambda (p) `(expty ,(expty-exp p) ,(expty-ty p))))

(define *inits* '())

(define (trans-type ty)
  (cond ((absyn-type.pointer? ty)
	 (make-pointer (trans-type (absyn-type.pointer->type ty))))
	((absyn-type.array? ty)
	 (make-array (absyn-type.array->size ty) (trans-type (absyn-type.array->type ty))))
	((absyn-type.function? ty)
	 (make-function (map (lambda (dec)
			       (trans-type (absyn-dec.var->type dec)))
			     (absyn-type.function->from-types ty))
			(trans-type (absyn-type.function->to-type ty))))
	((absyn-type.qual? ty)
	 (make-qual (absyn-type.qual->qualificator ty) (trans-type (absyn-type.qual->type ty))))
	(else
	 (call-with-values
	  (lambda ()
	    (decl-specs->base-type ty))
	  (lambda (class ty)
	    ty)))))

(define (trans-prg prg)
  (if (absyn-prg.prog? prg)
      (trans-decs (make-empty-symtab) (make-empty-symtab) (absyn-prg.prog->decls prg))
      (error "trans-prg: no ansi-c-program")))

(define (trans-dec venv tenv dec)
  (cond ((absyn-dec.var? dec)
	 (let ((ty (trans-type (absyn-dec.var->type dec))))
	   (if (function? ty)
	       (call-with-values
		(lambda ()
		  (trans-decs venv tenv (absyn-type.function->from-types (absyn-dec.var->type dec))))
		(lambda (formals-venv formals-tenv)
		  (let ((body (trans-stm formals-venv formals-tenv (absyn-dec.var->init dec))))
		    (values
		     (enter-symtab venv
				   (attr-desc-attribute (absyn-dec.var->name dec))
				   (symtab-entry.fun ty body))
		     tenv))))
	       (let ((init (trans-exp venv tenv (absyn-dec.var->init dec))))
		 (values
		  (enter-symtab venv
				(attr-desc-attribute (absyn-dec.var->name dec))
				(symtab-entry.var ty init))
		  tenv)))))
	(else
	 (error "trans-dec: don't know ~a" dec))))

(define (trans-decs venv tenv decs)
  (if (null? decs)
      (values venv tenv)
      (call-with-values
       (lambda ()
	 (trans-dec venv tenv (car decs)))
       (lambda (venv tenv)
	 (trans-decs venv tenv (cdr decs))))))

(define (trans-exp venv tenv exp)
  (cond ((absyn-exp.seq? exp)
	 (let ((et1 (trans-exp venv tenv (absyn-exp.seq->exp1 exp)))
	       (et2 (trans-exp venv tenv (absyn-exp.seq->exp1 exp))))
	   (expty-maker (absyn-exp.seq et1 et2) (expty-ty et2))))
	((absyn-exp.cond? exp)
	 (let ((et-tst (trans-exp venv tenv (absyn-exp.cond->tst-exp exp)))
	       (et-true (trans-exp venv tenv (absyn-exp.cond->true-exp exp)))
	       (et-false (trans-exp venv tenv (absyn-exp.cond->false-exp exp))))
	   (condtree et-tst et-true et-false)))
	((absyn-exp.nil? exp)
	 (expty-maker exp 'int))
	((absyn-exp.const? exp)
	 (expty-maker exp 'int))
	((absyn-exp.arithbin? exp)
	 (let ((exp1 (trans-exp venv tenv (absyn-exp.arithbin->exp1 exp)))
	       (exp2 (trans-exp venv tenv (absyn-exp.arithbin->exp2 exp)))
	       (op (absyn-exp.arithbin->op exp)))
	   (case op
	     ((add)
	      (addtree exp1 exp2))
	     ((sub)
	      (subtree exp1 exp2))
	     ((mul div)
	      (multree exp1 op exp2)))))
	((absyn-exp.arithun? exp)
	 (let* ((op (absyn-exp.arithun->op exp))
		(expty (pointer (trans-exp venv tenv (absyn-exp.arithun->exp exp))))
		(exp (expty-exp expty))
		(ty (expty-ty expty)))
	   (case op
	     ((neg)
	      (let ((ty (promote (expty-ty expty))))
		(if (arith? ty)
		    (expty-maker (absyn-exp.arithun 'neg (cast expty ty)) ty)
		    (error "unsigned operand of -"))))
	     ((plus)
	      (if (arith? ty)
		  (cast expty (promote ty))
		  (error "typeerror: + something")))
	     ((complement)
	      (if (int? ty)
		  (let ((ty (promote ty)))
		    (expty-maker (absyn-exp.arithun 'complement (cast expty ty)) ty))
		  (error "complement of no int-type"))))))
	((absyn-exp.boolun? exp)
	 (let* ((op (absyn-exp.arithun->op exp))
		(expty (pointer (trans-exp venv tenv (absyn-exp.arithun->exp))))
		(exp (expty-exp expty))
		(ty (expty-ty expty)))
	   (case op
	     ((not)
	      (if (scalar? ty)
		  (uncx expty)
		  (error "! needs scalar operand"))))))
	((absyn-exp.var? exp)
	 (let ((entry (locate-sym venv (absyn-exp.var->symbol exp))))
	   (if (and entry (symtab-entry.var? entry))
	       (expty-maker exp (symtab-entry.var->ty entry))
	       (error "undefined variable: ~a" exp))))))

(define (uncx x) x)

(define (addtree exp1 exp2)
  (let ((ty1 (expty-ty exp1))
	(ty2 (expty-ty exp2))
	(e1 (expty-exp exp1))
	(e2 (expty-exp exp2)))
    (cond ((and (arith? ty1) (arith? ty2))
	   (let ((ty (binary ty1 ty2)))
	     (expty-maker (absyn-exp.arithbin (cast exp1 ty) 'add (cast exp2 ty)) ty)))
	  ((and (pointer? ty1) (not (function? (pointer->ty ty1))) (int? ty2))
	   (expty-maker (absyn-exp.pointerbin exp1 'add (cast exp2 (promote ty2))) ty1))
	  ((and (pointer? ty2) (not (function? (pointer->ty ty2))) (int? ty1))
	   (expty-maker (absyn-exp.pointerbin (cast exp1 (promote ty1)) 'add exp2) ty2))
	  (else
	   (error "addtree: type-error ~a ~a" exp1 exp2)))))

(define (subtree exp1 exp2)
  (let ((ty1 (expty-ty exp1))
	(ty2 (expty-ty exp2))
	(e1 (expty-exp exp1))
	(e2 (expty-exp exp2)))
    (cond ((and (arith? ty1) (arith? ty2))
	   (let ((ty (binary ty1 ty2)))
	     (expty-maker (absyn-exp.arithbin (cast exp1 ty) 'sub (cast exp2 ty)) ty)))
	  ((and (pointer? ty1) (not (function? (pointer->ty ty1))) (int? ty2))
	   (expty-maker (absyn-exp.pointerbin exp1 'sub (cast exp2 (promote ty2))) ty1))
	  ((and (pointer? ty2) (not (function? (pointer->ty ty2))) (int? ty1))
	   (expty-maker (absyn-exp.pointerbin (cast exp1 (promote ty1)) 'sub exp2) ty2))
	  ((compatible? ty1 ty2)
	   (expty-maker (absyn-exp.pointerbin exp1 'sub exp2) 'long-int))
	  (else
	   (error "subtree: type-error")))))

(define (multree exp1 op exp2)
  (let ((ty1 (expty-ty exp1))
	(ty2 (expty-ty exp2))
	(e1 (expty-exp exp1))
	(e2 (expty-exp exp2)))
    (cond ((and (arith? ty1) (arith? ty2))
	   (let ((ty (binary ty1 ty2)))
	     (expty-maker (absyn-exp.arithbin (cast exp1 ty) op (cast exp2 ty)) ty)))
	  (else
	   (error "multree: type-error")))))

(define (pointer expty)
  (let ((ty (expty-ty expty))
	(exp (expty-exp expty)))
    (cond ((array? ty)
	   (expty-maker exp (array->pointer ty)))
	  ((function? ty)
	   (expty-maker exp (make-pointer ty)))
	  (else
	   expty))))

(define cast
  (let* ((edges
	  '((float          . double)       (double       . float)
	    (short-int      . int)          (int          . short-int)
	    (unsigned-short . unsigned-int) (unsigned-int . unsigned-short)
	    (signed-char    . int)          (int          . signed-char)
	    (unsigned-char  . unsigned-int) (unsigned-int . unsigned-char)
	    (double         . int)          (int          . double)
	    (int            . unsigned-int) (unsigned-int . int)
	    (unsigned-int   . pointer)      (pointer      . unsigned-int)))
	 (sorted-graph (edges->sorted-graph edges)))
    (lambda (expty dst-type)
      (let* ((src-type
	      (let ((ty (unqual (expty-ty expty))))
		(cond ((pointer? ty)
		       'pointer)
		      ((enum? ty)
		       'int)
		      (else
		       ty))))
	     (dst-type2
	      (let ((ty (unqual dst-type)))
		(cond ((pointer? ty)
		       'pointer)
		      ((enum? ty)
		       'int)
		      (else
		       ty))))
	     (path (let ((path (shortest-path src-type dst-type2 sorted-graph)))
		     (if path
			 path
			 (error "cast: couldn't convert ~a to ~a" src-type dst-type))))
	     (converted-expty
	      (fold-left
	       (lambda (res ty)
		 (expty-maker (absyn-exp.cast ty res) ty))
	       expty
	       (cdr path))))
	(expty-maker (expty-exp converted-expty) dst-type)))))

(define (condtree et-tst et-true et-false)
  (let* ((xty (expty-ty et-true))
	 (yty (expty-ty et-false))
	 (ty (cond ((and (arith? xty) (arith? yty))
		    (binary xty yty))
		   ((eqtype xty yty #t)
		    (unqual ty))
		   ((and (pointer? xty) (nullpointer? et-false))
		    xty)
		   ((and (pointer? yty) (nullpointer? et-true))
		    yty)
		   ((or (and (pointer? xty) (not (function? (pointer->ty xty))) (voidpointer? yty))
			(and (pointer? yty) (not (function? (pointer->ty yty))) (voidpointer? xty)))
		    'void)
		   ((and (pointer? xty) (pointer? yty) (eqtype (unqual (pointer->ty xty))
							       (unqual (pointer->ty yty))
							       #t))
		    xty)
		   (else
		    (error "condtree: type-error" et-tst et-true et-false)))))
    (if (pointer? ty)
	(begin
	  (set! ty (unqual (pointer->ty (unqual ty))))
	  (if (or (and (pointer? xty) (const? (pointer->ty (unqual xty))))
		  (and (pointer? yty) (const? (pointer->ty (unqual yty)))))
	      (set! ty (make-qual 'const ty)))
	  (if (or (and (pointer? xty) (volatile? (pointer->ty (unqual xty))))
		  (and (pointer? yty) (volatile? (pointer->ty (unqual yty)))))
	      (set! ty (make-qual 'volatile ty)))
	  (set! ty (make-pointer ty))))
    ; hier gehts weiter
		   

(define (trans-stm venv tenv stm)
  (cond ((absyn-stm.nop? stm)
	 stm)
	((absyn-stm.sequence? stm)
	 (absyn-stm.sequence
	  (trans-stm venv tenv (absyn-stm.sequence->stm1 stm))
	  (trans-stm venv tenv (absyn-stm.sequence->stm2 stm))))
	((absyn-stm.exp? stm)
	 (trans-exp venv tenv (absyn-stm.exp->exp stm)))
	((absyn-stm.returnval? stm)
	 (absyn-stm.returnval (trans-exp venv tenv (absyn-stm.returnval->exp stm))))
	((absyn-stm.block? stm)
	 (call-with-values
	  (lambda ()
	    (trans-decs venv tenv (absyn-stm.block->dec stm)))
	  (lambda (venv tenv)
	    (absyn-stm.block (cons venv tenv) (trans-stm venv tenv (absyn-stm.block->stm stm))))))))