@@ -3,6 +3,9 @@ module Core.Execute (execute) where
33
44import Idris.AbsSyntax
55import Idris.AbsSyntaxTree
6+import IRTS.Lang( IntTy(..)
7+ , intTyToConst
8+ , FType(..))
69
710import Core.TT
811import Core.Evaluate
@@ -384,18 +387,16 @@ chooseAlt _ [] = Nothing
384387
385388
386389
387−data FTy = FInt | FFloat | FChar | FString | FPtr | FUnit deriving (Show, Read)
388−
389−idrisType :: FTy -> ExecVal
390+idrisType :: FType -> ExecVal
390391idrisType FUnit = EP Ref unitTy EErased
391392idrisType ft = EConstant (idr ft)
392− where idr FInt = IType
393− idr FFloat = FlType
393+ where idr (FInt ty) = intTyToConst ty
394+ idr FDouble = FlType
394395 idr FChar = ChType
395396 idr FString = StrType
396397 idr FPtr = PtrType
397398
398−data Foreign = FFun String [FTy] FTy deriving Show
399+data Foreign = FFun String [FType] FType deriving Show
399400
400401
401402call :: Foreign -> [ExecVal] -> Exec (Maybe ExecVal)
@@ -405,11 +406,19 @@ call (FFun name argTypes retType) args =
405406 Nothing -> return Nothing
406407 Just f -> do res <- call' f args retType
407408 return . Just . ioWrap $ res
408− where call' :: ForeignFun -> [ExecVal] -> FTy -> Exec ExecVal
409− call' (Fun _ h) args FInt = do res <- execIO $ callFFI h retCInt (prepArgs args)
410− return (EConstant (I (fromIntegral res)))
411− call' (Fun _ h) args FFloat = do res <- execIO $ callFFI h retCDouble (prepArgs args)
412− return (EConstant (Fl (realToFrac res)))
409+ where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal
410+ call' (Fun _ h) args (FInt ITNative) = do res <- execIO $ callFFI h retCInt (prepArgs args)
411+ return (EConstant (I (fromIntegral res)))
412+ call' (Fun _ h) args (FInt IT8) = do res <- execIO $ callFFI h retCChar (prepArgs args)
413+ return (EConstant (B8 (fromIntegral res)))
414+ call' (Fun _ h) args (FInt IT16) = do res <- execIO $ callFFI h retCWchar (prepArgs args)
415+ return (EConstant (B16 (fromIntegral res)))
416+ call' (Fun _ h) args (FInt IT32) = do res <- execIO $ callFFI h retCInt (prepArgs args)
417+ return (EConstant (B32 (fromIntegral res)))
418+ call' (Fun _ h) args (FInt IT64) = do res <- execIO $ callFFI h retCLong (prepArgs args)
419+ return (EConstant (B64 (fromIntegral res)))
420+ call' (Fun _ h) args FDouble = do res <- execIO $ callFFI h retCDouble (prepArgs args)
421+ return (EConstant (Fl (realToFrac res)))
413422 call' (Fun _ h) args FChar = do res <- execIO $ callFFI h retCChar (prepArgs args)
414423 return (EConstant (Ch (castCCharToChar res)))
415424 call' (Fun _ h) args FString = do res <- execIO $ callFFI h retCString (prepArgs args)
@@ -426,6 +435,10 @@ call (FFun name argTypes retType) args =
426435
427436 prepArgs = map prepArg
428437 prepArg (EConstant (I i)) = argCInt (fromIntegral i)
438+ prepArg (EConstant (B8 i)) = argCChar (fromIntegral i)
439+ prepArg (EConstant (B16 i)) = argCWchar (fromIntegral i)
440+ prepArg (EConstant (B32 i)) = argCInt (fromIntegral i)
441+ prepArg (EConstant (B64 i)) = argCLong (fromIntegral i)
429442 prepArg (EConstant (Fl f)) = argCDouble (realToFrac f)
430443 prepArg (EConstant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars
431444 prepArg (EConstant (Str s)) = argString s
@@ -443,11 +456,18 @@ foreignFromTT t = case (unApplyV t) of
443456 return $ FFun name argFTy retFTy
444457 _ -> trace "failed to construct ffun" Nothing
445458
446−getFTy :: ExecVal -> Maybe FTy
459+getFTy :: ExecVal -> Maybe FType
460+getFTy (EApp (EP _ (UN "FInt") _) (EP _ (UN intTy) _)) =
461+ case intTy of
462+ "ITNative" -> Just $ FInt ITNative
463+ "IT8" -> Just $ FInt IT8
464+ "IT16" -> Just $ FInt IT16
465+ "IT32" -> Just $ FInt IT32
466+ "IT64" -> Just $ FInt IT64
467+ _ -> Nothing
447468getFTy (EP _ (UN t) _) =
448469 case t of
449− "FInt" -> Just FInt
450− "FFloat" -> Just FFloat
470+ "FFloat" -> Just FDouble
451471 "FChar" -> Just FChar
452472 "FString" -> Just FString
453473 "FPtr" -> Just FPtr