functor FLOWTOCODE (structure F   : FlowSig 
                    structure B2C : BlockToCodeSig 
                    sharing B2C.B = F.B and B2C.C = F.C) = 
struct 
local
    open F.C B2C

    fun length [] = 0 | length (_ :: t) = 1 + length t
    exception Lookup
    fun lookup [] _ = raise Lookup
      | lookup ((k,e) :: t) k' = if k = k' then e else lookup t k'

    fun remove x [] = [] | remove x (h :: t) = if x = h then t else h :: remove x t

    fun insert (x, d) = x :: remove x d

    fun relabel (code, labels) = 
    let fun fixup labels (GOTO(FALSE,0)) = (GOTO(TRUE, Basic.length code))
          | fixup labels (GOTO(c,d)) = 
            GOTO(c,( lookup labels d handle Lookup => Basic.length code))
          | fixup labels x = x
     in
        Code (map (fixup labels) code)
    end

    fun neg (x <<< y) = x >>= y
      | neg (x >>= y) = x <<< y
      | neg (x !!= y) = x === y
      | neg (x === y) = x !!= y
      | neg (x >>> y) = x <<= y
      | neg (x <<= y) = x >>> y
      | neg TRUE      = FALSE
      | neg FALSE     = TRUE
in
fun flowToCode   (g:F.G.Graph) =
let fun genBlocks [] (code, labels) = (code, labels)
      | genBlocks (h :: t) (code, labels) =
               let val (block, cond)   = F.data g h
                   val succs           = F.G.adj g h
                   val Code blockCode  = B2C.blockToCode block
                   val labels'         = insert((h, length code), labels)
                   val code'           = code @ blockCode
                   fun done w          = (lookup labels' w; true) handle Lookup => false
                   fun gen w           = (* generate w now unless it is already done *)
                       if done w then genBlocks t (code' @ [GOTO(TRUE, w)], labels')
                                 else genBlocks (insert (w, t)) (code', labels')
                in
                   case succs of
                        [ ]   => if t = [] then (code', labels')
                                 else genBlocks t (code' @ [GOTO(FALSE,0)], labels')
                                 (* this means we should insert a jump to the end of the code *)
                      | [w]   => if cond = TRUE then gen w
                                 else if cond = FALSE then
                                    if t = [] then (code', labels')
                                    else genBlocks t (code' @ [GOTO(FALSE,0)], labels')
                                 else if done w then 
                                    if t = [] then (code' @ [GOTO(cond, w)], labels')
                                              else (code' @ [GOTO(cond, w), GOTO(FALSE,0)], labels')
                                 else genBlocks (insert(w,t)) 
                                                   (code' @ [GOTO(cond, w), GOTO(FALSE,0)], labels')
                      | [w,x] =>if x = w then gen w
                                else
                                (case cond of TRUE  => gen w
                                            | FALSE => gen x
                                            | _ => 
                                   (case (done w, done x) of
                                    (true, false) => genBlocks (insert(x,t)) 
                                                               (code' @ [GOTO(cond, w)], labels')
                                   |(false,false) => genBlocks (insert(x,insert(w,t))) 
                                                               (code' @ [GOTO(cond, w)], labels')
                                   |(false, true) => genBlocks (insert(w,t)) 
                                                               (code' @ [GOTO(neg cond, x)], labels')
                                   |(true,  true) => genBlocks t
                                                               (code' @ [GOTO(cond,w), GOTO(TRUE,x)], 
                                                                labels')
                                   )                                               
                                )
               end
in
    relabel( genBlocks [0] ([], []) )
end
end
end