on master help sign in
Merge pull request #246 from bitlisp/ffi2

More rigorous checking of validity for mkForeign calls

commit263b01790c57ddedb5a361e68874338f7a826081 authorEdwin Brady <edwin.brady@gmail.com> dateMon 18 Mar 2013, 15:46 (14 years ago) parentf46dcfe56a58fe
1 file changed+13−10
src/IRTS/Compiler.hs+13−10
src/IRTS/Compiler.hs+13−10
@@ -264,21 +264,24 @@ instance ToIR (TT Name) where
264264 doForeign :: [Name] -> [TT Name] -> Idris LExp
265265 doForeign env (_ : fgn : args)
266266 | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn
267− = let tys = getFTypes fgnArgTys
267+ = let maybeTys = getFTypes fgnArgTys
268268 rty = mkIty' ret in
269− do args' <- mapM (ir' env) args
270− -- wrap it in a prim__IO
271− -- return $ con_ 0 @@ impossible @@
272− return $ -- LLazyExp $
273− LForeign LANG_C rty fgnName (zip tys args')
269+ case maybeTys of
270+ Nothing -> fail $ "Foreign type specification is not a constant list: " ++ show (fgn:args)
271+ Just tys -> do
272+ args' <- mapM (ir' env) args
273+ -- wrap it in a prim__IO
274+ -- return $ con_ 0 @@ impossible @@
275+ return $ -- LLazyExp $
276+ LForeign LANG_C rty fgnName (zip tys args')
274277 | otherwise = fail "Badly formed foreign function call"
275278
276−getFTypes :: TT Name -> [FType]
279+getFTypes :: TT Name -> Maybe [FType]
277280getFTypes tm = case unApply tm of
278− (nil, []) -> []
281+ (nil, []) -> Just []
279282 (cons, [ty, xs]) ->
280− let rest = getFTypes xs in
281− mkIty' ty : rest
283+ fmap (mkIty' ty :) (getFTypes xs)
284+ _ -> Nothing
282285
283286mkIty' (P _ (UN ty) _) = mkIty ty
284287mkIty' _ = FAny