(define (backpatch stmt-lst l)
  (for-each (lambda (stmt)
	      (cond ((binif? stmt)
		     (binif.label! stmt l))
		    ((unif? stmt)
		     (unif.label! stmt l))
		    ((valif? stmt)
		     (valif.label! stmt l))
		    ((goto? stmt)
		     (goto.label! stmt l))))
	    stmt-lst))

(define-record-type exp-attr :exp-attr
  (make-exp-attr code place)
  exp-attr?
  (code      exp-attr.code      exp-attr.code!)
  (place     exp-attr.place     exp-attr.place!)
  (truelist  exp-attr.truelist  exp-attr.truelist!)
  (falselist exp-attr.falselist exp-attr.falselist!))

(define (Cexp->Dexp exp)
  (cond ((arithbin? exp)
	 (let* ((e1 (Cexp->Dexp (arithbin.exp1 exp)))
		(e1.code (exp-attr.code e1))
		(e1.place (exp-attr.place e1))

		(e2 (Cexp->Dexp (arithbin.exp2 exp)))
		(e2.code (exp-attr.code e2))
		(e2.place (exp-attr.place e2))
		(newtemp (newtemp)))
	   (make-exp-attr
	    (append e1.code e2.code
		    (list (make-x:=y<op>z newtemp e1.place (arithbin.op exp) e2.place)))
	    newtemp 'no-truelist 'no-falselist)))
	((arithun? exp)
	 (let* ((e (Cexp->Dexp (arithun.exp exp)))
		(e.code (exp-attr.code e))
		(e.place (exp-attr.place e))
		(newtemp (newtemp)))
	   (make-exp-attr
	    (append e.code (list (make-x:=<op>y newtemp (arithun.op exp) e.place)))
	    newtemp 'no-truelist 'no-falselist)))
	((cast? exp)
	 ; (newtype)e
	 ; der Typ von e muß sich schon durch eine einzige Instruktion
	 ; in den newtype verwandeln lassen (Parser hat schon alles vorbereitet)
	 (let* ((e (Cexp->Dexp (cast.exp exp)))
		(e.code (exp-attr.code e))
		(e.place (exp-attr.place e))
		(newtemp (newtemp)))
	   (make-exp-attr
	    (append e.code (list (make-x:=<op>y newtemp (cast.newtype exp) e.place)))
	    newtemp 'no-truelist 'no-falselist)))
	((asgn? exp)
	 (let* ((e1 (asgn.exp1 exp))
		(e2 (Cexp->Dexp (asgn.exp2 exp)))
		(e2.code (exp-attr.code e2))
		(e2.place (exp-attr.place e2)))
	   (cond ((deref? e1)
		  (let* ((e1 (Cexp->Dexp (deref.exp e1)))
			 (e1.code (exp-attr.code e1))
			 (e1.place (exp-attr.place e1)))
		    (make-exp-attr
		     (append e1.code e2.code (list (make-*x:=y e1.place e2.place)))
		     e2.place 'no-truelist 'no-falselist)))
		 (else
		  (let* ((e1 (Cexp->Dexp e1))
			 (e1.code (exp-attr.code e1))
			 (e1.place (exp-attr.place e1)))
		    (make-exp-attr
		     (append e1.code e2.code (list (make-x:=y e1.place e2.place)))
		     e2.place 'no-truelist 'no-falselist))))))
	((var? exp)
	 (make-exp-attr '() (get-sym-attr (var.symtab exp) (var.symbol exp) 'name)
			'no-truelist 'no-falselist))
	((exp-seq? exp)
	 (let* ((e1 (Cexp->Dexp (exp-seq.exp1 exp)))
		(e1.code (exp-attr.code e1))
		(e2 (Cexp->Dexp (exp-seq.exp2 exp)))
		(e2.code (exp-attr.code e2))
		(e2.place (exp-attr.place e2)))
	   (make-exp-attr (append e1.code e2.code) e2.place 'no-truelist 'no-falselist)))
	((cond? exp)
	 (let* ((newtemp (newtemp))
		(stmt
		 (Cstmt->Dstmt
		  (make-if-then-else
		   (cond.tst-exp exp)
		   (make-asgn newtemp (cond.true-exp exp))
		   (make-asgn newtemp (cond.false-exp exp)))
		  #f #f)))
	   (make-exp-attr (stmt-attr.code stmt) newtemp 'no-truelist 'no-falselist)))
	((deref? exp)
	 (let* ((e (Cexp->Dexp (deref.exp exp)))
		(e.code (exp-attr.code e))
		(e.place (exp-attr.place e))
		(newtemp (newtemp)))
	   (make-exp-attr
	    (append e.code (list (make-x:=*y newtemp e.place)) newtemp 'no-truelist 'no-falselist))))
	((addr? exp)
	 (let ((var (addr.exp exp))
	       (newtemp (newtemp)))
	   (make-exp-attr (list (make-x:=&y newtemp (var.symtabentry var)))
			  newtemp 'no-truelist 'no-falselist)))
	((boolbin? exp)
	 (let* ((exp1 (Cexp->Dexp (boolbin.exp1 exp)))
		(exp1.code (exp-attr.code exp1))
		(exp1.place (exp-attr.place exp1))
		(exp1.truelist (exp-attr.truelist exp1))
		(exp1.falselist (exp-attr.falselist exp1))

		(exp2 (Cexp->Dexp (boolbin.exp2 exp)))
		(exp2.code (exp-attr.code exp2))
		(exp2.place (exp-attr.place exp2))
		(exp2.truelist (exp-attr.truelist exp2))
		(exp2.falselist (exp-attr.falselist exp2)))
	   (case (boolbin.op exp)
	     ((AND)
	      (backpatch exp1.truelist (caar exp2.code))
	      (make-exp-attr
	       (append exp1.code exp2.code)
	       'noplace
	       exp2.truelist
	       (append exp1.falselist exp2.falselist)))
	     ((OR)
	      (backpatch exp1.falselist (caar exp2.code))
	      (make-exp-attr
	       (append exp1.code exp2.code)
	       'noplace
	       (append exp1.truelist exp2.truelist)
	       exp2.falselist))
	     ((EQ NE LT GT LE GE)
	      (let ((if-then-code
		     (make-binif exp1.place (boolbin.op exp) exp2.place 'to-be-backpatched))
		    (else-code (make-goto 'to-be-backpatched)))
		(make-exp-attr
		 (append
		  exp1.code
		  exp2.code
		  `((,(newlabel) ,if-then-code))
		  `((,(newlabel) ,else-code)))
		 'noplace
		 (list if-then-code)
		 (list else-code)))))))
	((boolun? exp)
	 (let* ((exp (Cexp->Dexp (boolun.exp exp)))
		(exp.truelist (exp-attr.truelist exp))
		(exp.falselist (exp-attr.falselist exp)))
	   (make-exp-attr
	    exp.code
	    'noplace
	    exp.falselist
	    exp.truelist)))))

(define-record-type stmt-attr :stmt-attr
  (make-stmt-attr code nextlist)
  stmt-attr?
  (code     stmt-attr.code     stmt-attr.code!)
  (nextlist stmt-attr.nextlist stmt-attr.nextlist!))

(define-record-discloser :stmt-attr
  (lambda (p) `(stmt-attr ,(stmt-attr.code p) ,(stmt-attr.nextlist p))))

(define (Cstmt->Dstmt stmt continue-label break-label)
  (cond ((if-then? stmt)
	 (let* ((tst-exp (if-then.tst-exp stmt))
		(true-stmt (if-then.true-stmt stmt))

		(tst-exp (Cexp->Dexp tst-exp))
		(tst-exp.code (exp-attr.code tst-exp))
		(tst-exp.truelist (exp-attr.truelist tst-exp))
		(tst-exp.falselist (exp-attr.falselist tst-exp))

		(true-stmt (Cstmt->Dstmt true-stmt continue-label break-label))
		(true-stmt.code (stmt-attr.code true-stmt))
		(true-stmt.nextlist (stmt-attr.nextlist true-stmt)))
	   (backpatch tst-exp.truelist (caar true-stmt.code))
	   (make-stmt-attr (append tst-exp.code true-stmt.code)
			   (append tst-exp.falselist true-stmt.nextlist))))
	((if-then-else? stmt)
	 (let* ((tst-exp (if-then-else.tst-exp stmt))
		(true-stmt (if-then-else.true-stmt stmt))
		(false-stmt (if-then-else.false-stmt stmt))

		(tst-exp (Cexp->Dexp tst-exp))
		(tst-exp.code (exp-attr.code tst-exp))
		(tst-exp.truelist (exp-attr.truelist tst-exp))
		(tst-exp.falselist (exp-attr.falselist tst-exp))

		(true-stmt (Cstmt->Dstmt true-stmt continue-label break-label))
		(true-stmt.code (stmt-attr.code true-stmt))
		(true-stmt.nextlist (stmt-attr.nextlist true-stmt))

		(false-stmt (Cstmt->Dstmt false-stmt continue-label break-label))
		(false-stmt.code (stmt-attr.code false-stmt))
		(false-stmt.nextlist (stmt-attr.nextlist false-stmt))

		(newlabel (newlabel))
		(jump-code (make-goto 'to-be-backpatched)))
	   (backpatch tst-exp.truelist  (caar true-stmt.code))
	   (backpatch tst-exp.falselist (caar false-stmt.code))
	   (make-stmt-attr (append tst-exp.code
				   true-stmt.code
				   `((,newlabel ,jump-code))
				   false-stmt.code)
			   (append true-stmt.nextlist (list jump-code) false-stmt.nextlist))))
	((switch? stmt)
	 ; das fehlt noch
	 )
	((default? stmt)
	 ; das fehlt noch
	 )
	((block? stmt)
	 ; das fehlt noch)
	((returnval? stmt)
	 (let* ((e (Cexp->Dexp (returnval.x stmt)))
		(e.code (exp-attr.code e))
		(e.place (exp-attr.place e)))
	   (make-stmt-attr (append e.code `((,(newlabel) ,(make-returnval e.place)))) '())))
	((return? stmt)
	 (make-stmt-attr `((,(newlabel) ,(make-return))) '()))
	((break? stmt)
	 (if break-label
	     (make-stmt-attr `((,(newlabel) ,(make-goto break-label))) '())
	     (error "break statement not within loop or switch")))
	((continue? stmt)
	 (if continue-label
	     (make-stmt-attr `((,(newlabel) ,(make-goto continue-label))) '())
	     (error "continue statement not within a loop")))
	((while? stmt)
	 (let* ((entry-label (newlabel))
		(continue-label (newlabel))
		(break-label (newlabel))
		(while-Ccode
		 (make-sequences
		  (make-goto continue-label)
		  (make-label entry-label)
		  (while.stmt stmt)
		  (make-label continue-label)
		  (make-if-then (while.exp stmt) (make-goto entry-label))
		  (make-label break-label)))
		(while-Dcode (Cstmt->Dstmt while-Ccode continue-label break-label)))
	   (make-stmt-attr (stmt-attr.code while-Dcode) (stmt-attr.nextlist while-Dcode))))
	((do-while? stmt)
	 (let* ((entry-label (newlabel))
		(continue-label (newlabel))
		(break-label (newlabel))
		(do-while-Ccode
		 (make-sequences
		  (make-label entry-label)
		  (do-while.stmt stmt)
		  (make-label continue-label)
		  (make-if-then (do-while.exp stmt) (make-goto entry-label))
		  (make-label break-label)))
		(do-while-Dcode (Cstmt->Dstmt do-while-Ccode continue-label break-label)))
	   (make-stmt-attr (stmt-attr.code do-while-Dcode) (stmt-attr.nextlist do-while-Dcode))))
	((for? stmt)
	 (let* ((entry-label (newlabel))
		(tst-label (newlabel))
		(continue-label (newlabel))
		(break-label (newlabel))
		(init-exp (for.init-exp stmt))
		(tst-exp (for.tst-exp stmt))
		(update-exp (for.update-exp stmt))
		(body-stmt (for.stmt stmt))
		(for-Ccode
		 (make-sequences
		  init-exp
		  (make-goto tst-label)
		  (make-label entry-label)
		  body-stmt
		  (make-label continue-label)
		  update-exp
		  (make-label tst-label)
		  (make-if-then tst-exp (make-goto entry-label))
		  (make-label break-label)))
		(for-Dcode (Cstmt->Dstmt for-Ccode continue-label break-label)))
	   (make-stmt-attr (stmt-attr.code for-Dcode) (stmt-attr.nextlist for-Dcode))))
	((sequence? stmt)
	 (let* ((s1 (Cstmt->Dstmt (sequence.stmt1 stmt) continue-label break-label))
		(s1.code (stmt-attr.code s1))
		(s1.nextlist (stmt-attr.nextlist s1))
		
		(s2 (Cstmt->Dstmt (sequence.stmt2 stmt) continue-label break-label))
		(s2.code (stmt-attr.code s2))
		(s2.nextlist (stmt-attr.nextlist s2)))
	   (backpatch s1.nextlist (caar s2.code))
	   (make-stmt-attr (append s1.code s2.code) s2.nextlist)))
	((label? stmt)
	 (make-stmt-attr (define-label (label.label stmt)) '()))
	((goto? stmt)
	 (make-stmt-attr `((,(newlabel) ,stmt)) '()))))

(define (define-label label)
  `((,label ,(make-empty-stmt))))

(define (compute-leader-labels code)
  (cons (caar code)
	(apply
	 append
	 (my-map
	  (lambda (code1 code2)
	    (let* ((stmt1 (cadr code1))
		   (leader-after-jump (if code2
					  (list (car code2))
					  '()))
		   (leaders
		    (cond ((goto? stmt1)
			   (cons (goto.label stmt1) leader-after-jump))
			  ((binif? stmt1)
			   (cons (binif.label stmt1) leader-after-jump))
			  ((unif? stmt1)
			   (cons (unif.label stmt1) leader-after-jump))
			  ((valif? stmt1)
			   (cons (valif.label stmt1) leader-after-jump))
			  (else
			   '()))))
	      leaders))
	  code))))

(define (true-positions pred lst n)
  (if (null? lst)
      '()
      (if (pred (car lst))
	  (cons n (true-positions pred (cdr lst) (+ n 1)))
	  (true-positions pred (cdr lst) (+ n 1)))))

(define (partition-into-basic-blocks code)
  (let* ((leader-labels (compute-leader-labels code))
	 (positions
	  (true-positions
	   (lambda (stmt)
	     (let ((label (car stmt)))
	       (if (member stmt leader-labels)
		   #t
		   #f)))
	   code
	   0))
	 (basic-blocks
	  (my-filter-map
	   (lambda (begin end)
	     (and end (sublist begin (- end 1) code)))
	   positions)))
    basic-blocks))