[Add foreign import "dynamic" support
Samuel Bronson <naesten@gmail.com>**20070703004722] hunk ./C/FromGrin2.hs 535
+    | APrim (IFunc _ as r) _ <- p = do
+        v':vs' <- mapM convertVal vs
+        let fn = cast (funPtrType (basicType r) (map basicType as)) v'
+        return $ cast (basicType r) (indirectFunctionCall fn [ cast (basicType t) v | v <- vs' | t <- as ])
hunk ./C/Generate.hs 25
+    indirectFunctionCall,
hunk ./C/Generate.hs 47
+    funPtrType,
hunk ./C/Generate.hs 135
-data Type = TB String | TPtr Type | TAnon [Type] | TNStruct Name
+data Type = TB String | TPtr Type | TAnon [Type] | TNStruct Name | TFunPtr Type [Type]
hunk ./C/Generate.hs 213
+    draw (TFunPtr r as) = draw r <+> text "(*)" <> tupled (map draw as)
hunk ./C/Generate.hs 225
+functionCall' fe es = expD (draw fe <> tupled (map draw es))
hunk ./C/Generate.hs 228
-functionCall n es = expD (draw n <> tupled (map draw es))
+functionCall = functionCall'
+
+indirectFunctionCall :: Expression -> [Expression] -> Expression
+indirectFunctionCall e = functionCall' (expD (parens (draw e)))
hunk ./C/Generate.hs 473
+funPtrType :: Type -> [Type] -> Type
+funPtrType r as = TFunPtr r as
+
hunk ./C/Prims.hs 41
+        funcIOLike :: !Bool,
hunk ./C/Prims.hs 44
-        } -- indirect function call
+        } -- indirect function call with C calling convention
hunk ./C/Prims.hs 147
-    pprint (IFunc xs r) = parens (text r) <> parens (char '*') <> tupled (map text xs)
+    pprint (IFunc _ xs r) = parens (text r) <> parens (char '*') <> tupled (map text xs)
hunk ./E/FromHs.hs 358
+
+    -- first argument builds the actual call primitive, given 
+    -- (a) the C argtypes
+    -- (b) the C return type
+    -- (c) whether it's IO-like or not
+    -- (d) the real return type
+    -- (e) the arguments themselves
+    -- ccallHelper returns a function expression to perform the call, when given the arguments
+    ccallHelper :: Monad m => ([ExtType] -> ExtType -> Bool -> [E] -> E -> E) -> E -> Ce m E
+    ccallHelper myPrim ty = do
+        let (ts,rt) = argTypes' ty
+            (isIO,rt') =  extractIO' rt
+        es <- newVars [ t |  t <- ts, not (sortKindLike t) ]
+        pt <- lookupCType rt'
+        cts <- mapM lookupCType (filter (not . sortKindLike) ts)
+        [tvrWorld, tvrWorld2] <- newVars [tWorld__,tWorld__]
+        let cFun = createFunc dataTable (map tvrType es)
+            prim = myPrim cts pt
+        case (isIO,pt) of
+            (True,"void") -> cFun $ \rs -> (,) (ELam tvrWorld) $
+                        eStrictLet tvrWorld2 
+                                   (prim True
+                                         (EVar tvrWorld
+                                          :[EVar t | (t,_) <- rs ])
+                                         tWorld__)
+                                   (eJustIO (EVar tvrWorld2) vUnit)
+            (False,"void") -> fail "pure foreign function must return a valid value"
+            _ -> do
+                (cn,rtt',_) <- lookupCType' dataTable rt'
+                [rtVar,rtVar'] <- newVars [rt',rtt']
+                let rttIO = ltTuple [tWorld__, rt']
+                    rttIO' = ltTuple' [tWorld__, rtt']
+                case isIO of
+                    False -> cFun $ \rs -> (,) id $
+                                 eStrictLet rtVar'
+                                           (prim False
+                                                 [ EVar t | (t,_) <- rs ]
+                                                 rtt')
+                                           (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' })
+                    True -> cFun $ \rs -> (,) (ELam tvrWorld) $
+                                eCaseTup' (prim True
+                                                (EVar tvrWorld:[EVar t | (t,_) <- rs ])
+                                                rttIO')
+                                          [tvrWorld2,rtVar']
+                                          (eLet rtVar 
+                                                (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' })
+                                                (eJustIO (EVar tvrWorld2) (EVar rtVar)))
+
hunk ./E/FromHs.hs 424
+
hunk ./E/FromHs.hs 428
-        let (ts,rt) = argTypes' ty
-            (isIO,rt') =  extractIO' rt
-        es <- newVars [ t |  t <- ts, not (sortKindLike t) ]
-        pt <- lookupCType rt'
-        cts <- mapM lookupCType (filter (not . sortKindLike) ts)
-        [tvrWorld, tvrWorld2] <- newVars [tWorld__,tWorld__]
-        let cFun = createFunc dataTable (map tvrType es)
-            prim io  = EPrim (APrim (Func io (packString rcn) cts pt) req)
-        result <- case (isIO,pt) of
-            (True,"void") -> cFun $ \rs -> (,) (ELam tvrWorld) $
-                        eStrictLet tvrWorld2 (prim True  (EVar tvrWorld:[EVar t | (t,_) <- rs ]) tWorld__) (eJustIO (EVar tvrWorld2) vUnit)
-            (False,"void") -> fail "pure foreign function must return a valid value"
-            _ -> do
-                (cn,rtt',_) <- lookupCType' dataTable rt'
-                [rtVar,rtVar'] <- newVars [rt',rtt']
-                let rttIO = ltTuple [tWorld__, rt']
-                    rttIO' = ltTuple' [tWorld__, rtt']
-                case isIO of
-                    False -> cFun $ \rs -> (,) id $ eStrictLet rtVar' (prim False [ EVar t | (t,_) <- rs ] rtt') (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' })
-                    True -> cFun $ \rs -> (,) (ELam tvrWorld) $
-                                eCaseTup' (prim True (EVar tvrWorld:[EVar t | (t,_) <- rs ]) rttIO')  [tvrWorld2,rtVar'] (eLet rtVar (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' }) (eJustIO (EVar tvrWorld2) (EVar rtVar)))
+        result <- ccallHelper
+                     (\cts crt io args rt ->
+                      EPrim (APrim (Func io (packString rcn) cts crt) req) args rt)
+                     ty
+        return [(name,setProperty prop_INLINE var,lamt result)]
+    cDecl (HsForeignDecl _ (FfiSpec Dynamic _ CCall) n _) = do
+        -- XXX ensure that the type is of form FunPtr /ft/ -> /ft/
+        let name = toName Name.Val n
+        (var,ty,lamt) <- convertValue name
+        let ((fptrTy:_), _) = argTypes' ty
+            fty = discardArgs 1 ty
+
+        result <- ccallHelper
+                     (\cts crt io args rt ->
+                      EPrim (APrim (IFunc io (tail cts) crt) (Requires [] [])) args rt)
+                     ty
hunk ./E/FromHs.hs 445
+
hunk ./Grin/FromE.hs 452
-            Func True fn as "void" -> return $ Prim ap  xs' ty'
-            Func True fn as r -> do
-                return $ Prim ap xs' ty'
+            Func True fn as "void" -> return $ Prim ap xs' ty'
+            Func True fn as r      -> return $ Prim ap xs' ty'
hunk ./Grin/FromE.hs 456
+            IFunc True _ _ ->
+                return $ Prim ap xs' ty'
+            IFunc False _ _ | Just _ <- fromRawType ty ->
+                return $ Prim ap xs' ty'
hunk ./Grin/NodeAnalyze.hs 9
-import Control.Monad.RWS
+import Control.Monad.RWS hiding(join)