; abstrakte Syntax

(define (exp->type exp)
  (cond ((asgn? exp)
	 (asgn-type exp))
	((arithbin? exp)
	 (arithbin-type exp))
	((arithun? exp)
	 (arithun-type exp))
	((boolbin? exp)
	 (boolbin-type exp))
	((boolun? exp)
	 (boolun-type exp))
	((deref? exp)
	 (deref-type exp))
	((addr? exp)
	 (addr-type exp))))

; expressions

(define-record-discloser type/empty-exp
  (lambda (p) `(empty-exp)))

(define-record-type asgn
  ((exp1) (exp2))
  ((type 'no-type-yet)))

(define-record-discloser type/asgn
  (lambda (p) `(asgn ,(asgn-exp1 p) ,(asgn-exp2 p) ,(asgn-type p))))

(define arith-op '())

(define-record-type arithbin
  ((op) (exp1) (exp2))
  ((type 'no-type-yet)))

(define-record-discloser type/arithbin
  (lambda (p) `(,(arithbin-exp1 p) ,(arithbin-op p) ,(arithbin-exp2 p) ,(arithbin-type p))))

(define-record-type arithun
  ((op) (exp))
  ((type 'no-type-yet)))

(define-record-discloser type/arithun
  (lambda (p) `(,(arithun-op p) ,(arithun-exp p))))

(define-record-type boolbin
  ((op) (exp1) (exp2))
  ((type 'no-type-yet)))

(define-record-discloser type/boolbin
  (lambda (p) `(,(boolbin-exp1 p) ,(boolbin-op p) ,(boolbin-exp2 p))))

(define-record-type boolun
  ((op) (exp))
  ((type 'no-type-yet)))

(define-record-discloser type/boolun
  (lambda (p) `(,(boolun-op p) ,(boolun-exp p))))

(define-record-type deref
  ((exp))
  ((type 'no-type-yet)))

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

(define-record-type addr
  ((exp))
  ((type 'no-type-yet)))

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

(define-record-type cond
  ((tst-exp) (true-exp) (false-exp))
  ((type 'no-type-yet)))

(define-record-discloser type/cond
  (lambda (p) `(cond ,(cond-tst-exp p) ,(cond-true-exp p) ,(cond-false-exp p))))

(define-record-type exp-seq
  ((exp1) (exp2))
  ((type 'no-type-yet)))

(define-record-discloser type/exp-seq
  (lambda (p) `(exp-seq ,(exp-seq-exp1 p) ,(exp-seq-exp2 p))))

(define-record-type cast
  ((from->to) (exp))
  ((type 'no-type-yet)))

(define-record-discloser type/cast
  (lambda (p) `(cast ,(cast-from->to p) ,(cast-exp p))))

(define-record-type const
  ((value))
  ((type 'no-type-yet)))

(define-record-discloser type/const
  (lambda (p) `(const ,(const-value p))))

(define-record-type var
  ((symbol) (symtab))
  ())

(define-record-discloser type/var
  (lambda (p) `(var ,(var-symbol p) ,(var-symtab p))))

(define-record-type call
  ((func) (args))
  ())

(define-record-discloser type/call
  (lambda (p) `(call ,(call-func p) ,(call-args p))))

; statements

(define-record-type goto
  ((label))
  ())

(define-record-discloser type/goto
  (lambda (p) `(goto ,(goto-label p))))

;(define-record-type return :return
;  (make-return exp)
;  return?
;  (exp return.exp return.exp!))

;(define-record-discloser :return
;  (lambda (p) `(return ,(return.exp p))))

(define-record-type sequence
  ((stmt1) (stmt2))
  ())

(define-record-discloser type/sequence
  (lambda (p) `(sequence ,(sequence-stmt1 p) ,(sequence-stmt2 p))))

(define (make-sequences . ss)
  (cond ((null? ss)
	 (empty-stmt-maker))
	((null? (cdr ss))
	 (car ss))
	(else
	 (sequence-maker (car ss) (apply make-sequences (cdr ss))))))

(define-record-type for
  ((init-exp) (tst-exp) (update-exp) (stmt))
  ())

(define-record-discloser type/for
  (lambda (p) `(for ,(for-init-exp p) ,(for-tst-exp p) ,(for-update-exp p) ,(for-stmt p))))

(define-record-type while
  ((exp) (stmt))
  ())

(define-record-discloser type/while
  (lambda (p) `(while ,(while-exp p) ,(while-stmt p))))

(define-record-type do-while
  ((stmt) (exp))
  ())

(define-record-discloser type/do-while
  (lambda (p) `(do-while ,(do-while-stmt p) ,(do-while-exp p))))

(define-record-type if-then-else
  ((tst-exp) (true-stmt) (false-stmt))
  ())

(define-record-discloser type/if-then-else
  (lambda (p) `(if-then-else ,(if-then-else-tst-exp p)
			     ,(if-then-else-true-stmt p)
			     ,(if-then-else-false-stmt p))))

(define-record-type if-then
  ((tst-exp) (true-stmt))
  ())

(define-record-discloser type/if-then
  (lambda (p) `(if-then ,(if-then-tst-exp p)
			,(if-then-true-stmt p))))

(define-record-type label
  ((label))
  ())

(define-record-discloser type/label
  (lambda (p) `(label ,(label-label p))))

(define-record-type empty-stmt
  ()
  ())

(define-record-discloser type/empty-stmt
  (lambda (p) `(empty-stmt)))

(define-record-type switch
  ((exp) (stmt))
  ())

(define-record-discloser type/switch
  (lambda (p) `(switch ,(switch-exp p) ,(switch-stmt p))))

(define-record-type case
  ((exp) (stmt))
  ())

(define-record-discloser type/case
  (lambda (p) `(case ,(case-exp p) ,(case-stmt p))))

(define-record-type default
  ((stmt))
  ())

(define-record-discloser type/default
  (lambda (p) `(default ,(default-stmt p))))

(define-record-type break
  () ())

(define-record-discloser type/break
  (lambda (p) `(break)))

(define-record-type continue
  () ())

(define-record-discloser type/continue
  (lambda (p) `(continue)))

(define-record-type empty-exp
  () ())

(define (addtree exp1 exp2)
  (let ((exp1-type (exp->type exp1))
	(exp2-type (exp->type exp2)))
    (cond ((and (isarith? exp1-type) (isarith? exp2-type))
	   (let ((ty (binary exp1-type exp2-type)))
	     (arithbin-maker 'ADD (cast exp1 ty) (cast exp2 ty) ty)))
	  ((and (ispointer? exp1-type) (isint? exp2-type))
	   (addtree exp2 exp1))
	  ((and (ispointer? exp2-type) (isint? exp1-type) (not (isfunction? (type-kid exp2-type))))
	   (let* ((ty (unqual (type-of exp2)))
		  (n (type-size ty))
		  (exp1 (cast exp1 (promote (type-of exp1)))))
	     (arithbin-maker 'ADD
			     (multree 'MUL (consttre n 'int) exp1)
			     exp2
			     ty)))
	  (else
	   (error "addtree: typeerror")))))

(define (multree op exp1 exp2)
  (let ((exp1-type (exp->type exp1))
	(exp2-type (exp->type exp2)))
     (if (and (isarith? exp1-type) (isarith? exp2-type))
	(let ((ty (binary exp1-type exp2-type)))
	  (arithbin-maker op (cast exp1 ty) (cast exp2 ty) ty))
	(error "multree: typeerror"))))

(define (consttree n ty)
  (let ((ty (if (isarray? ty) (atop ty) ty)))
    (const-maker n ty)))

(define (cmptree op exp1 exp2)
  (let ((exp1-type (exp->type exp1))
	(exp2-type (exp->type exp2)))
    (cond ((and (isarith? exp1-type) (isarith? exp2-type))
	   (let ((ty (binary exp1-type exp2-type)))
	     (boolbin-maker op (cast exp1 ty) (cast exp2 ty) 'int)))
	  ((compatible? exp1-type exp2-type)
	   (boolbin-maker op (cast exp1 'unsigned-int) (cast exp2 'unsigned-int) 'int))
	  (else
	   (error "cmptree: typeerror")))))

(define (isnullpointer? exp)
  (or (and (isint? (exp->type exp))
	   (const? exp)
	   (let ((e (cast exp 'unsigned-int)))
	     (zero? (const-value e))))
      (and (isvoidpointer? (exp->type exp)) (const? exp) (zero? (const-value exp)))))

(define (eqtree op exp1 exp2)
  (let ((xty (exp->type exp1))
	(yty (exp->type exp2)))
    (cond ((or (and (ispointer? xty) (isnullpointer? exp2))
	       (and (ispointer? xty) (not (isfunction? (type-kid xty))) (isvoidpointer? yty))
	       (and (ispointer? xty) (ispointer? yty)
		    (eqtype (unqual (type-kid xty)) (unqual (type-kid yty)) #t)))
	   (boolbin-maker op (cast exp1 'unsigned-int) (cast exp2 'unsigned-int) 'unsigned-int))
	  ((or (and (ispointer? yty) (isnullpointer? exp1))
	       (and (ispointer? yty) (not (isfunction? (type-kid yty))) (isvoidpointer? xty)))
	   (eqtree op exp2 exp1))
	  (else
	   (cmptree op exp1 exp2)))))