fadeecd · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Fix Core.Execute to use IRTS.Lang.FType

fadeecdBenjamin Saunders13 years ago

src/Core/Execute.hs+34−14

compare with master

unifiedsplit

@@ -3,6 +3,9 @@ module Core.Execute (execute) where

4import Idris.AbsSyntax

5import Idris.AbsSyntaxTree

6+import IRTS.Lang( IntTy(..)

7+ , intTyToConst

8+ , FType(..))

7import Core.TT

10import Core.TT

8import Core.Evaluate

11import Core.Evaluate

@@ -384,18 +387,16 @@ chooseAlt _ [] = Nothing

384

387

385

388

386

389

388−

389−idrisType :: FTy -> ExecVal

390+idrisType :: FType -> ExecVal

390idrisType FUnit = EP Ref unitTy EErased

391idrisType FUnit = EP Ref unitTy EErased

391idrisType ft = EConstant (idr ft)

392idrisType ft = EConstant (idr ft)

392− where idr FInt = IType

393+ where idr (FInt ty) = intTyToConst ty

393− idr FFloat = FlType

394+ idr FDouble = FlType

394 idr FChar = ChType

395 idr FChar = ChType

395 idr FString = StrType

396 idr FString = StrType

396 idr FPtr = PtrType

397 idr FPtr = PtrType

397

398

398−data Foreign = FFun String [FTy] FTy deriving Show

399+data Foreign = FFun String [FType] FType deriving Show

399

400

401

401call :: Foreign -> [ExecVal] -> Exec (Maybe ExecVal)

402call :: Foreign -> [ExecVal] -> Exec (Maybe ExecVal)

@@ -405,11 +406,19 @@ call (FFun name argTypes retType) args =

405 Nothing -> return Nothing

406 Nothing -> return Nothing

406 Just f -> do res <- call' f args retType

407 Just f -> do res <- call' f args retType

407 return . Just . ioWrap $ res

408 return . Just . ioWrap $ res

408− where call' :: ForeignFun -> [ExecVal] -> FTy -> Exec ExecVal

409+ where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal

409− call' (Fun _ h) args FInt = do res <- execIO $ callFFI h retCInt (prepArgs args)

410+ call' (Fun _ h) args (FInt ITNative) = do res <- execIO $ callFFI h retCInt (prepArgs args)

410− return (EConstant (I (fromIntegral res)))

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)))

411− call' (Fun _ h) args FFloat = do res <- execIO $ callFFI h retCDouble (prepArgs args)

420+ call' (Fun _ h) args FDouble = do res <- execIO $ callFFI h retCDouble (prepArgs args)

412− return (EConstant (Fl (realToFrac res)))

421+ return (EConstant (Fl (realToFrac res)))

413 call' (Fun _ h) args FChar = do res <- execIO $ callFFI h retCChar (prepArgs args)

422 call' (Fun _ h) args FChar = do res <- execIO $ callFFI h retCChar (prepArgs args)

414 return (EConstant (Ch (castCCharToChar res)))

423 return (EConstant (Ch (castCCharToChar res)))

415 call' (Fun _ h) args FString = do res <- execIO $ callFFI h retCString (prepArgs args)

424 call' (Fun _ h) args FString = do res <- execIO $ callFFI h retCString (prepArgs args)

@@ -426,6 +435,10 @@ call (FFun name argTypes retType) args =

426

435

427 prepArgs = map prepArg

436 prepArgs = map prepArg

428 prepArg (EConstant (I i)) = argCInt (fromIntegral i)

437 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)

429 prepArg (EConstant (Fl f)) = argCDouble (realToFrac f)

442 prepArg (EConstant (Fl f)) = argCDouble (realToFrac f)

430 prepArg (EConstant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars

443 prepArg (EConstant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars

431 prepArg (EConstant (Str s)) = argString s

444 prepArg (EConstant (Str s)) = argString s

@@ -443,11 +456,18 @@ foreignFromTT t = case (unApplyV t) of

443 return $ FFun name argFTy retFTy

456 return $ FFun name argFTy retFTy

444 _ -> trace "failed to construct ffun" Nothing

457 _ -> trace "failed to construct ffun" Nothing

445

458

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

447getFTy (EP _ (UN t) _) =

468getFTy (EP _ (UN t) _) =

448 case t of

469 case t of

449− "FInt" -> Just FInt

450− "FFloat" -> Just FFloat

470+ "FFloat" -> Just FDouble

451 "FChar" -> Just FChar

471 "FChar" -> Just FChar

452 "FString" -> Just FString

472 "FString" -> Just FString

453 "FPtr" -> Just FPtr

473 "FPtr" -> Just FPtr