content: {-# LANGUAGE CPP            #-}
  {-# LANGUAGE QuasiQuotes    #-}
  
  -- | Ivory backend targeting language-c-quote.
  
  module Ivory.Compile.C.Gen where
  
  import           Language.C.Quote.GCC
  import qualified Language.C.Syntax                     as C
  
  import qualified Ivory.Language.Array                  as I
  import qualified Ivory.Language.Proc                   as P
  import qualified Ivory.Language.Syntax                 as I
  import           Ivory.Language.Syntax.Concrete.Pretty
  
  import           Ivory.Compile.C.Gen.Const (makeTargetConstIf)
  import           Ivory.Compile.C.Prop
  import           Ivory.Compile.C.Types
  
  import           Data.List                             (foldl')
  import           Prelude                               hiding (abs, exp, signum)
  
  import           Data.Loc                              (noLoc)
  
  data Visibility = Public | Private deriving (Show, Eq)
  
  --------------------------------------------------------------------------------
  -- | Compile a top-level element.
  compile :: P.Def a -> Compile
  compile (P.DefProc fun) = compileUnit fun
  compile (P.DefImport _) = error "Can't compile an import!"
  
  --------------------------------------------------------------------------------
  -- | Compile a struct.
  compileStruct :: Visibility -> I.Struct -> Compile
  compileStruct visibility def = case def of
    I.Struct n fs
      -> (if visibility == Public then putHdrSrc else putSrc)
           [cedecl| typedef struct $id:n { $sdecls:(map mkFieldGroup fs) } $id:n ;
                  |]
  
    I.Abstract _ file
      -> putHdrInc (SysInclude file)
  
  mkFieldGroup :: I.Typed String -> C.FieldGroup
  mkFieldGroup field =
    [csdecl| $ty:(toType (I.tType field)) $id:(I.tValue field) ; |]
  
  --------------------------------------------------------------------------------
  -- | Compile an external memory area reference.
  compileAreaImport :: I.AreaImport -> Compile
  compileAreaImport ai = putHdrInc (SysInclude (I.aiFile ai))
  
  --------------------------------------------------------------------------------
  -- | Get prototypes for memory areas.
  extractAreaProto :: Visibility -> I.Area -> Compile
  extractAreaProto visibility area = do
    let aty                   = toType (I.areaType area)
        ty | I.areaConst area = [cty| const $ty:aty |]
           | otherwise        = aty
    if visibility == Public
      then putHdrSrc [cedecl| extern $ty:ty $id:(I.areaSym area); |]
      else putSrc    [cedecl| static $ty:ty $id:(I.areaSym area); |]
  
  -- | Compile a memory area definition into an extern in the header, and a
  -- structure in the source.
  compileArea :: Visibility -> I.Area -> Compile
  compileArea visibility area = do
    let aty                   = toType (I.areaType area)
        i                     = I.areaInit area
        ty | I.areaConst area = [cty| const $ty:aty |]
           | otherwise        = aty
    case i of
      I.InitZero -> putSrc [cedecl| $ty:(type' visibility ty) $id:(I.areaSym area) ; |]
      _          -> putSrc [cedecl| $ty:(type' visibility ty)
                                   $id:(I.areaSym area) = $init:(toInit i) ; |]
    where
    type' Public ty' = [cty|$ty:ty'|]
    type' Private ty' = [cty|static $ty:ty'|]
  
  --------------------------------------------------------------------------------
  -- | Compile a definition unit.
  compileUnit :: I.Proc -> Compile
  compileUnit I.Proc { I.procSym      = sym
                     , I.procRetTy    = ret
                     , I.procArgs     = args
                     , I.procBody     = body
                     , I.procRequires = requires
                     , I.procEnsures  = ensures
                     }
    = do let ens  = map I.getEnsure ensures
         let bd   = foldr collapseComment [] $ concatMap (toBody ens) body
         let reqs = map (toRequire . I.getRequire) requires
         putSrc [cedecl| $ty:(toType ret) ($id:sym) ($params:(toArgs args))
                           { $items:reqs
                             $items:bd
                           } |]
  
  collapseComment :: C.BlockItem -> [C.BlockItem] -> [C.BlockItem]
  collapseComment (C.BlockStm (C.Comment c (C.Exp Nothing _) src))
                  (C.BlockStm stm : items)
    = C.BlockStm (C.Comment c stm src) : items
  collapseComment stm items
    = stm : items
  
  --------------------------------------------------------------------------------
  -- | Get the prototypes.
  extractProto :: Visibility -> I.Proc -> Compile
  extractProto visibility I.Proc { I.procSym   = sym
                                 , I.procRetTy = ret
                                 , I.procArgs  = args
                                 }
    = if visibility == Public
         then putHdrSrc
           [cedecl| $ty:(toType ret) ($id:sym) ($params:(toArgs args)); |]
         else putSrc
           [cedecl| static $ty:(toType ret) ($id:sym) ($params:(toArgs args)); |]
  
  --------------------------------------------------------------------------------
  
  -- | Argument conversion.
  toArgs :: [I.Typed I.Var] -> [C.Param]
  toArgs [] = [[cparam| void |]]
  toArgs ls = foldl' go [] (reverse ls)
    where
    go acc I.Typed { I.tType  = t
                   , I.tValue = v }
      = [cparam| $ty:(toType t) $id:(toVar v) |] : acc
  
  toParam :: C.Type -> C.Param
  toParam ty = case ty of
    C.Type spec decl loc -> C.Param Nothing spec decl loc
    _                    -> error "toParam: unexpected anti-quote"
  
  --------------------------------------------------------------------------------
  -- Types
  
  -- | Make C type, and decay array types into pointers (e.g., `x[2][3]` decays
  -- into `(*x)[3]`).
  toTypeDecay :: I.Type -> C.Type
  toTypeDecay = toType' True
  
  -- | Make C type, but don't decay array types (default).
  toType :: I.Type -> C.Type
  toType = toType' False
  
  -- | C type conversion, with a special case for references and pointers.
  toType' :: Bool -> I.Type -> C.Type
  toType' decay ty = case ty of
    I.TyVoid              -> [cty| void |]
    I.TyChar              -> [cty| char |]
    I.TyInt i             -> intSize i
    I.TyWord w            -> wordSize w
    I.TyIndex _           -> toType I.ixRep
    I.TyBool              -> [cty| typename bool |]
    I.TyFloat             -> [cty| float |]
    I.TyDouble            -> [cty| double |]
    I.TyStruct nm         -> [cty| struct $id:nm |]
    I.TyCArray t          -> [cty| $ty:(toType t) * |]
    I.TyArr len t         -> [cty| $ty:(toType t)[$uint:len] |]
    I.TyProc retTy argTys ->
      [cty| $ty:(toType retTy) (*)
            ($params:(map (toParam . toType) argTys)) |]
    I.TyOpaque            -> error "Opaque type is not implementable."
    I.TyRef t             -> arrCase False  t
    I.TyPtr t             -> arrCase False  t
    I.TyConstRef t        -> arrCase True   t
    I.TyConstPtr t        -> arrCase True   t
    where
    arrCase isTargetConst t =
      makeTargetConstIf isTargetConst $
      case t of
        I.TyArr len t'
          -> if decay then [cty| $ty:(toType t') * |]
                      else [cty| $ty:(toType t')[$uint:len] |]
        I.TyCArray t'
          -> [cty| $ty:(toType t') * |]
        _ -> [cty| $ty:(toType t)  * |]
  
  intSize :: I.IntSize -> C.Type
  intSize I.Int8  = [cty| typename int8_t  |]
  intSize I.Int16 = [cty| typename int16_t |]
  intSize I.Int32 = [cty| typename int32_t |]
  intSize I.Int64 = [cty| typename int64_t |]
  
  wordSize :: I.WordSize -> C.Type
  wordSize I.Word8  = [cty| typename uint8_t  |]
  wordSize I.Word16 = [cty| typename uint16_t |]
  wordSize I.Word32 = [cty| typename uint32_t |]
  wordSize I.Word64 = [cty| typename uint64_t |]
  
  --------------------------------------------------------------------------------
  -- | Call Symbols
  toName :: I.Name -> String
  toName name = case name of
    I.NameSym s   -> s
    I.NameVar var -> toVar var
  
  -- | Variable name mangling.
  toVar :: I.Var -> String
  toVar var = case var of
    I.VarName n     -> "n_" ++ n
    I.VarInternal n -> "i_" ++ n
    I.VarLitName n  -> n
  
  --------------------------------------------------------------------------------
  
  -- | Translate statements.
  toBody :: [I.Cond] -> I.Stmt -> [C.BlockItem]
  toBody ens stmt =
    let toBody' = toBody ens in
    case stmt of
      -- t is the ref type.
      I.Assign t v exp
        ->
        [C.BlockDecl [cdecl| $ty:(toTypeDecay t) $id:(toVar v)
                           = $exp:(toExpr t exp); |]]
      I.IfTE exp blk0 blk1
        ->
        let ifBd   = concatMap toBody' blk0 in
        let elseBd = concatMap toBody' blk1 in
        if null elseBd
          then [C.BlockStm [cstm| if($exp:(toExpr I.TyBool exp)) {
                                    $items:ifBd } |]]
          else [C.BlockStm [cstm| if($exp:(toExpr I.TyBool exp)) {
                                    $items:ifBd }
                                  else { $items:elseBd } |]]
      I.Return exp
        ->
             map (toEnsure $ I.tValue exp) ens
          ++ [C.BlockStm [cstm| return $exp:(typedRet exp); |]]
      I.ReturnVoid
        -> [C.BlockStm [cstm| return; |]]
  
      -- t is the referenced type.  Should only be able to deref a stored value.
      -- We replicate some of the type deconstruction in parsing expressions to
      -- optimize away *& constructions on dereferncing structs and indexes into
      -- arrays.
      I.Deref t var exp
        ->
        [C.BlockDecl [cdecl| $ty:(toType t) $id:(toVar var) =
                               $exp:(derefExp (toExpr (I.TyRef t) exp)); |]]
  
      I.Local t var inits
        -> [C.BlockDecl $
        case inits of
          I.InitStruct []
            -> [cdecl| $ty:(toType t) $id:(toVar var); |]
          _ -> [cdecl| $ty:(toType t) $id:(toVar var)
                  = $init:(toInit inits); |]
        ]
      -- Can't do a static check since we have local let bindings.
      I.RefCopy t vto vfrom
        ->
        [C.BlockStm $ case t of
          I.TyArr{} ->
            [cstm| if( $exp:toRef != $exp:fromRef) {
               memcpy( $exp:toRef, $exp:fromRef, sizeof($ty:(toType t)) ); }
                                 else { COMPILER_ASSERTS(false); }
            |]
          _ -> [cstm| $exp:(derefExp toRef) = $exp:(derefExp fromRef); |]
        ]
        where
        toRef   = toExpr (I.TyRef t) vto
        fromRef = toExpr (I.TyRef t) vfrom
  
      I.RefZero t ref
        ->
        [C.BlockStm [cstm| memset( $exp:(toExpr (I.TyRef t) ref), 0x0,
                                   sizeof($ty:(toType t)) ); |] ]
  
      -- Should only be a reference (not a pointer).
      I.AllocRef t l r
          -> [C.BlockDecl
          [cdecl| $ty:(toTypeDecay (I.TyRef t)) $id:(toVar l) = $exp:rhs; |]]
        where
        name      = toName r
        rhs = case t of
          I.TyArr _ _  -> [cexp| $id:name    |]
          I.TyCArray _ -> [cexp| $id:name    |]
          _            -> [cexp| &($id:name) |]
      I.Assert exp
        -> [C.BlockStm
        [cstm| ASSERTS($exp:(toExpr I.TyBool exp)); |]]
      I.CompilerAssert exp
        -> [C.BlockStm
        [cstm| COMPILER_ASSERTS($exp:(toExpr I.TyBool exp)); |]]
      I.Assume exp
        -> [C.BlockStm
        [cstm| ASSUMES($exp:(toExpr I.TyBool exp)); |]]
      I.Call t mVar sym args
        ->
        case mVar of
          Nothing  -> -- Just call the fuction.
            [C.BlockStm [cstm| $id:(toName sym)($args:(map go args)); |]]
          Just var -> -- Call it and assign it a value.
            [C.BlockDecl [cdecl| $ty:(toType t) $id:(toVar var) =
                                   $id:(toName sym)($args:(map go args));
                        |]]
          where
          go I.Typed { I.tType = t'
                     , I.tValue = v }
            = toExpr t' v
      -- Assume that ty is a signed and sufficiently big (int).
      I.Loop _ var start incr blk
        ->
        let loopBd =  concatMap toBody' blk in
        [C.BlockStm [cstm| for( $ty:(toType ty) $id:(toVar var)
                                  = $exp:(toExpr ty start);
                                $exp:test;
                                $exp:incExp ) {
                         $items:loopBd } |]]
        where
        ty = I.ixRep
        (test,incExp)  = toIncr incr
        ix = toVar var
        toIncr (I.IncrTo to) =
          ( [cexp| $id:ix <= $exp:(toExpr ty to) |]
          , [cexp| $id:ix++ |] )
        toIncr (I.DecrTo to) =
          ( [cexp| $id:ix >= $exp:(toExpr ty to) |]
          , [cexp| $id:ix-- |] )
  
      I.Forever blk
        ->
        let foreverBd =  concatMap toBody' blk
            foreverDecl = C.BlockDecl
              [cdecl| int forever_loop __attribute__((unused)); |]
            loop = C.BlockStm [cstm| for( forever_loop = 0
                                        ; IFOREVER
                                        ; IFOREVER_INC ) { $items:foreverBd } |]
            decAndLoop = [ foreverDecl, loop ]
        in  [ C.BlockStm [cstm| { $items:decAndLoop } |] ]
  
      I.Break
        -> [C.BlockStm [cstm| break; |]]
      I.Store t ptr exp
        -> [C.BlockStm
        [cstm| $exp:(derefExp (toExpr (I.TyRef t) ptr)) = $exp:(toExpr t exp); |]]
      I.Comment (I.UserComment c)
        -> [C.BlockStm
        [cstm| $comment:("/* " ++ c ++ " */"); |]]
      I.Comment (I.SourcePos src)
        -> [C.BlockStm
        [cstm| $comment:("/* " ++ prettyPrint (pretty src) ++ " */"); |]]
  -- | Return statement.
  typedRet :: I.Typed I.Expr -> C.Exp
  typedRet I.Typed { I.tType  = t
                   , I.tValue = exp }
      = [cexp| $exp:(toExpr t exp) |]
  
  --------------------------------------------------------------------------------
  
  toInit :: I.Init -> C.Initializer
  toInit i = case i of
    I.InitZero       -> [cinit|{$inits:([])}|] -- {}
    I.InitExpr ty e  -> [cinit|$exp:(toExpr ty e)|]
    I.InitArray is _ -> [cinit|{$inits:([ toInit j | j <- is ])}|]
    I.InitStruct fs  ->
      C.CompoundInitializer [ (Just (fieldDes f), toInit j) | (f,j) <- fs ] noLoc
  
  fieldDes :: String -> C.Designation
  fieldDes n = C.Designation [ C.MemberDesignator (C.Id n noLoc) noLoc ] noLoc
  
  --------------------------------------------------------------------------------
  
  derefExp :: C.Exp -> C.Exp
  derefExp (C.UnOp C.AddrOf rhs _) = rhs
  derefExp e = [cexp| * $exp:e |]
  
  labelExp :: C.Exp -> String -> C.Exp
  labelExp (C.UnOp C.AddrOf lhs _) field = [cexp| $exp:lhs . $id:field |]
  labelExp lhs field = [cexp| $exp:lhs -> $id:field |]
  
  -- | Translate an expression.
  toExpr :: I.Type -> I.Expr -> C.Exp
  ----------------------------------------
  toExpr _ (I.ExpVar var)  = [cexp| $id:(toVar var) |]
  ----------------------------------------
  toExpr t (I.ExpLit lit)  =
    case lit of
      -- XXX hack: should make type-correct literals.
      I.LitInteger i -> [cexp| ($ty:(toType t))$id:fromInt |]
        where fromInt = case t of
                          I.TyWord _  -> show i ++ "U"
                          I.TyInt  _  -> show i
                          I.TyIndex _ -> show i
                          I.TyFloat   -> show (fromIntegral i :: Float) ++ "F"
                          I.TyDouble  -> show (fromIntegral i :: Double)
                          _           -> error ("Nonint type " ++ (show t) ++
                                                " of literal " ++ (show i) )
      I.LitChar c    -> [cexp| $char:c |]
      I.LitBool b    -> [cexp| $id:(if b then "true" else "false") |]
      I.LitNull      -> [cexp| NULL |]
      I.LitString s  -> [cexp| $string:s |]
      I.LitFloat f   -> [cexp| $id:(show f ++ "f") |]
      I.LitDouble d  -> [cexp| $id:(show d) |]
  ----------------------------------------
  toExpr t (I.ExpOp op args) =
    [cexp| ($ty:(toTypeDecay t)) $exp:(toExpOp t op args) |]
  ----------------------------------------
  toExpr _ (I.ExpSym sym) = [cexp| $id:sym |]
  ----------------------------------------
  toExpr _ (I.ExpExtern (I.Extern sym _ _)) = [cexp| $id:sym |]
  ----------------------------------------
  toExpr t (I.ExpLabel t' e field) = case t of
    I.TyRef (I.TyArr _ _)       -> getField
    I.TyRef (I.TyCArray _)      -> getField
    I.TyConstRef (I.TyArr _ _)  -> getField
    I.TyConstRef (I.TyCArray _) -> getField
    _                           ->
      [cexp| &($exp:(labelExp (toExpr (I.TyRef t') e) field)) |]
    where getField = labelExp (toExpr t' e) field
  ----------------------------------------
  toExpr t (I.ExpIndex at a ti i) = case t of
    I.TyRef (I.TyArr _ _)       -> expIdx I.TyRef
    I.TyRef (I.TyCArray _)      -> expIdx I.TyRef
    I.TyConstRef (I.TyArr _ _)  -> expIdx I.TyConstRef
    I.TyConstRef (I.TyCArray _) -> expIdx I.TyConstRef
    _                           ->
      [cexp| &($exp:(toExpr (I.TyRef at) a) [$exp:(toExpr ti i)]) |]
    where
    expIdx constr =
      [cexp| ($exp:(toExpr (constr at) a) [$exp:(toExpr ti i)]) |]
  ----------------------------------------
  toExpr tTo (I.ExpSafeCast tFrom e) =
    [cexp| ($ty:(toTypeDecay tTo))$exp:(toExpr tFrom e) |]
  ----------------------------------------
  toExpr _ (I.ExpToIx e maxSz) =
    [cexp| $exp:(toExpr I.ixRep e ) % $exp:maxSz |]
  ----------------------------------------
  toExpr tTo (I.ExpAddrOfGlobal sym) = case tTo of
    I.TyRef (I.TyArr _ _)       -> [cexp| $id:sym |]
    I.TyRef (I.TyCArray _)      -> [cexp| $id:sym |]
    I.TyConstRef (I.TyArr _ _)  -> [cexp| $id:sym |]
    I.TyConstRef (I.TyCArray _) -> [cexp| $id:sym |]
    _                           -> [cexp| & $id:sym |]
  ----------------------------------------
  toExpr ty (I.ExpMaxMin b) = [cexp| $id:macro |]
    where
    macro = case b of
      True  -> case ty of
        I.TyInt sz -> case sz of
          I.Int8     -> "INT8_MAX"
          I.Int16    -> "INT16_MAX"
          I.Int32    -> "INT32_MAX"
          I.Int64    -> "INT64_MAX"
        I.TyWord sz -> case sz of
          I.Word8     -> "UINT8_MAX"
          I.Word16    -> "UINT16_MAX"
          I.Word32    -> "UINT32_MAX"
          I.Word64    -> "UINT64_MAX"
        I.TyIndex n -> show n
        _           -> err
      False -> case ty of
        I.TyInt sz -> case sz of
          I.Int8     -> "INT8_MIN"
          I.Int16    -> "INT16_MIN"
          I.Int32    -> "INT32_MIN"
          I.Int64    -> "INT64_MIN"
        I.TyWord sz -> show $ case sz of
          I.Word8     -> 0 :: Integer
          I.Word16    -> 0
          I.Word32    -> 0
          I.Word64    -> 0
        I.TyIndex _ -> "0"
        _           -> err
    err = error $ "unexpected type " ++ show ty ++ " in ExpMaxMin."
  ----------------------------------------
  toExpr ty (I.ExpSizeOf ty') = [cexp| ($ty:(toTypeDecay ty)) sizeof($ty:(toType ty')) |]
  ----------------------------------------
  
  exp0 :: [C.Exp] -> C.Exp
  exp0 = flip (!!) 0
  
  exp1 :: [C.Exp] -> C.Exp
  exp1 = flip (!!) 1
  
  exp2 :: [C.Exp] -> C.Exp
  exp2 = flip (!!) 2
  
  mkArgs :: I.Type -> [I.Expr] -> [C.Exp]
  mkArgs ty = map (toExpr ty)
  
  toExpOp :: I.Type -> I.ExpOp -> [I.Expr] -> C.Exp
  toExpOp ty op args = case op of
    -- eq instance
    I.ExpEq ety  -> let xs = mkArgs ety args in
                    [cexp| $exp:(exp0 xs) == $exp:(exp1 xs) |]
    I.ExpNeq ety -> let xs = mkArgs ety args in
                    [cexp| $exp:(exp0 xs) != $exp:(exp1 xs) |]
    -- conditional expressions
    I.ExpCond    -> let b  = toExpr I.TyBool (head args) in
                    let xs = mkArgs ty (tail args) in
                    [cexp| $exp:b ? $exp:(exp0 xs) : $exp:(exp1 xs) |]
    -- ord instance
    I.ExpGt orEq ety
      | orEq      -> let xs = mkArgs ety args in
                     [cexp| $exp:(exp0 xs) >= $exp:(exp1 xs) |]
      | otherwise -> let xs = mkArgs ety args in
                     [cexp| $exp:(exp0 xs) > $exp:(exp1 xs) |]
    I.ExpLt orEq ety
      | orEq      -> let xs = mkArgs ety args in
                     [cexp| $exp:(exp0 xs) <= $exp:(exp1 xs) |]
      | otherwise -> let xs = mkArgs ety args in
                     [cexp| $exp:(exp0 xs) < $exp:(exp1 xs) |]
    -- boolean operations
    I.ExpNot      -> let xs = mkArgs ty args in
                     [cexp| !($exp:(exp0 xs)) |]
    I.ExpAnd      -> let xs = mkArgs ty args in
                     [cexp| $exp:(exp0 xs) && $exp:(exp1 xs) |]
    I.ExpOr       -> let xs = mkArgs ty args in
                     [cexp| $exp:(exp0 xs) || $exp:(exp1 xs) |]
    -- num instance
    I.ExpMul      -> let xs = mkArgs ty args in
                     [cexp| $exp:(exp0 xs) * $exp:(exp1 xs) |]
    I.ExpAdd      -> let xs = mkArgs ty args in
                     [cexp| $exp:(exp0 xs) + $exp:(exp1 xs) |]
    I.ExpSub      -> let xs = mkArgs ty args in
                     [cexp| $exp:(exp0 xs) - $exp:(exp1 xs) |]
    I.ExpNegate   -> let xs = mkArgs ty args in
                     [cexp| - ($exp:(exp0 xs)) |]
    I.ExpAbs      -> let xs = mkArgs ty args in
                     [cexp| $id:(absSym ty)($exp:(exp0 xs)) |]
    I.ExpSignum   -> let xs = mkArgs ty args in
                     [cexp| $id:(signumSym ty)($exp:(exp0 xs)) |]
  
    -- integral/fractional instance
    I.ExpDiv      -> let xs = mkArgs ty args in
                     [cexp| $exp:(exp0 xs) / $exp:(exp1 xs) |]
    I.ExpMod      -> toMod ty args
    I.ExpRecip    -> let xs = mkArgs ty args in
                     [cexp| 1 / $exp:(exp0 xs) |]
  
    -- floating instance
    I.ExpFExp       -> floatingUnary ty "exp"  args
    I.ExpFSqrt      -> floatingUnary ty "sqrt" args
    I.ExpFLog       -> floatingUnary ty "log"  args
    I.ExpFPow       -> floatingBinary ty "pow" args
    I.ExpFLogBase   -> toLogBase ty args
    I.ExpFSin       -> floatingUnary ty "sin"   args
    I.ExpFCos       -> floatingUnary ty "cos"   args
    I.ExpFTan       -> floatingUnary ty "tan"   args
    I.ExpFAsin      -> floatingUnary ty "asin"  args
    I.ExpFAcos      -> floatingUnary ty "acos"  args
    I.ExpFAtan      -> floatingUnary ty "atan"  args
    I.ExpFAtan2     -> floatingBinary ty "atan2" args
    I.ExpFSinh      -> floatingUnary ty "sinh"  args
    I.ExpFCosh      -> floatingUnary ty "cosh"  args
    I.ExpFTanh      -> floatingUnary ty "tanh"  args
    I.ExpFAsinh     -> floatingUnary ty "asinh" args
    I.ExpFAcosh     -> floatingUnary ty "acosh" args
    I.ExpFAtanh     -> floatingUnary ty "atanh" args
  
    -- float operations
    -- XXX this needs to add a dependency on <math.h>
    I.ExpIsNan ety -> let xs = mkArgs ety args in
                      [cexp| ($ty:(toTypeDecay I.TyBool)) (isnan($exp:(exp0 xs))) |]
    -- isinf returns -1 for negative infinity and 1 for positive infinity.
    I.ExpIsInf ety -> let xs = mkArgs ety args in
                      [cexp| ($ty:(toTypeDecay I.TyBool)) (isinf($exp:(exp0 xs))) |]
    I.ExpRoundF    -> floatingUnary ty "round" args
    I.ExpCeilF     -> floatingUnary ty "ceil"  args
    I.ExpFloorF    -> floatingUnary ty "floor" args
  
    -- bit operations
    I.ExpBitAnd        -> let xs = mkArgs ty args in
                          [cexp| $exp:(exp0 xs) & $exp:(exp1 xs) |]
    I.ExpBitOr         -> let xs = mkArgs ty args in
                          [cexp| $exp:(exp0 xs) | $exp:(exp1 xs) |]
    I.ExpBitXor        -> let xs = mkArgs ty args in
                          [cexp| $exp:(exp0 xs) ^ $exp:(exp1 xs) |]
    I.ExpBitComplement -> let xs = mkArgs ty args in
                          [cexp| ~($exp:(exp0 xs)) |]
    I.ExpBitShiftL     -> let xs = mkArgs ty args in
                          [cexp| $exp:(exp0 xs) << $exp:(exp1 xs) |]
    I.ExpBitShiftR     -> let xs = mkArgs ty args in
                          [cexp| $exp:(exp0 xs) >> $exp:(exp1 xs) |]
  
  floatingSym :: I.Type -> String ->  String
  floatingSym t sym = case t of
    I.TyFloat -> sym ++ "f"
    I.TyDouble -> sym
    _ -> error "Can't make floatingSym out of non-float"
  
  floatingBinary :: I.Type -> String -> [I.Expr] -> C.Exp
  floatingBinary ty name args =
    let xs = mkArgs ty args in
    [cexp| $id:(floatingSym ty name)($exp:(exp0 xs), $exp:(exp1 xs)) |]
  
  floatingUnary :: I.Type -> String -> [I.Expr] -> C.Exp
  floatingUnary ty name args =
    let xs = mkArgs ty args in
    [cexp| $id:(floatingSym ty name)($exp:(exp0 xs)) |]
  
  toLogBase :: I.Type -> [I.Expr] -> C.Exp
  toLogBase ty args = [cexp| $exp:(logC $ exp0 xs) / $exp:(logC $ exp1 xs) |]
    where
    xs = mkArgs ty args
    logC e = [cexp| $id:(floatingSym ty "log")($exp:e) |]
  
  -- XXX Not sure aobut this, as there's currently no way to perform mod on
  -- float/double in the frontend.
  toMod :: I.Type -> [I.Expr] -> C.Exp
  toMod ty args = case ty of
    I.TyFloat  -> [cexp| fmodf($exp:x', $exp:y') |]
    I.TyDouble -> [cexp| fmod ($exp:x', $exp:y') |]
    _          -> [cexp| $exp:x' % $exp:y' |]
    where
    args' = mkArgs ty args
    x' = exp0 args'
    y' = exp1 args'
  
  -- | Emit the function name for a call to abs.  This doesn't include any symbol
  -- for unsigned things, as they should be optimized out by the front end.
  absSym :: I.Type -> String
  absSym ty = case ty of
    I.TyFloat  -> "fabsf"
    I.TyDouble -> "fabs"
    I.TyInt i  -> "abs_i" ++ iType i
    I.TyChar   -> "abs_char"
    _          -> error ("abs " ++ "unimplemented for type " ++ show ty)
    where
    iType i = case i of
      I.Int8  -> "8"
      I.Int16 -> "16"
      I.Int32 -> "32"
      I.Int64 -> "64"
  
  -- | Emit the function name for a call to signum.
  signumSym :: I.Type -> String
  signumSym ty = case ty of
    I.TyFloat  -> "signum_float"
    I.TyDouble -> "signum_double"
    I.TyInt i  -> "signum_i" ++ showInt i
    I.TyWord w -> "signum_u" ++ showWord w
    I.TyChar   -> "signum_char"
    _          -> error ("signum " ++ "unimplemented for type " ++ show ty)
  ----------------------------------------
  
  showInt :: I.IntSize -> String
  showInt I.Int8  = show (8 :: Int)
  showInt I.Int16 = show (16 :: Int)
  showInt I.Int32 = show (32 :: Int)
  showInt I.Int64 = show (64 :: Int)
  
  showWord :: I.WordSize -> String
  showWord I.Word8  = show (8 :: Int)
  showWord I.Word16 = show (16 :: Int)
  showWord I.Word32 = show (16 :: Int)
  showWord I.Word64 = show (32 :: Int)
  
  --------------------------------------------------------------------------------
  
  toRequire :: I.Cond -> C.BlockItem
  toRequire = toAssertion id "REQUIRES"
  
  -- | Takes the return expression, the condition, and returns a 'BlockItem'.
  toEnsure :: I.Expr -> I.Cond -> C.BlockItem
  toEnsure retE = toAssertion (ensTrans retE) "ENSURES"
  
  toAssertion :: (I.Expr -> I.Expr) -> String -> I.Cond -> C.BlockItem
  toAssertion trans call cond = C.BlockStm $
    case cond of
      I.CondBool e          ->
        [cstm| $id:call($exp:(toExpr I.TyBool (trans e))); |]
      I.CondDeref t e var c ->
        let res = (toBody []) (I.Deref t var (trans e)) in
        let c1  = toAssertion trans call c in
        [cstm| { $items:res $item:c1 } |]
  
  --------------------------------------------------------------------------------
  