From 50adbf5cdf9ef6924c47b6738dfd6139d19a0438 Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Mon, 9 Jan 2017 19:55:12 +1100 Subject: Moved old code to separate directory --- old/Storage.hs | 73 +++++++++++++++++++++++++++ old/preference_arrays.adb | 114 ++++++++++++++++++++++++++++++++++++++++++ old/preference_arrays.ads | 38 ++++++++++++++ old/testmain.hs | 21 ++++++++ src/Storage.hs.old | 73 --------------------------- src/preference_arrays.adb.old | 114 ------------------------------------------ src/preference_arrays.ads.old | 38 -------------- src/testmain.hs.old | 21 -------- 8 files changed, 246 insertions(+), 246 deletions(-) create mode 100644 old/Storage.hs create mode 100644 old/preference_arrays.adb create mode 100644 old/preference_arrays.ads create mode 100644 old/testmain.hs delete mode 100644 src/Storage.hs.old delete mode 100644 src/preference_arrays.adb.old delete mode 100644 src/preference_arrays.ads.old delete mode 100644 src/testmain.hs.old diff --git a/old/Storage.hs b/old/Storage.hs new file mode 100644 index 0000000..2697c39 --- /dev/null +++ b/old/Storage.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Storage( + PrefStorage, + createStorage, + pokePref, + peekPref + ) where + + + + +import Foreign +import Foreign.C + + + + +foreign import ccall "create_pref_array" + c_createPrefArray :: CInt -> CInt -> IO (Ptr PrefArray) + +foreign import ccall "free_pref_array" + c_freePrefArray :: CInt -> CInt -> Ptr PrefArray -> IO () + +foreign import ccall "wrapper" + wrap :: (Ptr PrefArray -> IO ()) -> IO (FunPtr (Ptr PrefArray -> IO ())) + +foreign import ccall "poke_pref_array" + c_pokePrefArray :: CInt -> CInt -> Ptr PrefArray -> CInt -> CInt -> CInt -> IO () + +foreign import ccall "peek_pref_array" + c_peekPrefArray :: CInt -> CInt -> Ptr PrefArray -> CInt -> CInt -> CInt -> IO CInt + + + + +newtype PrefArray = PrefArray (Ptr PrefArray) + +data PrefStorage = PrefStorage { pointer :: ForeignPtr PrefArray + , numBallots :: Int + , sizeOfBallot :: Int } + + + + +createStorage :: Int -> Int -> IO PrefStorage +createStorage n s = do + x <- c_createPrefArray (fromIntegral n) (fromIntegral s) + f <- wrap (c_freePrefArray (fromIntegral n) (fromIntegral s)) + y <- newForeignPtr f x + return (PrefStorage y n s) + + + + +pokePref :: PrefStorage -> Int -> Int -> Int -> IO () +pokePref p n s r = do + let numBal = fromIntegral (numBallots p) + sizeBal = fromIntegral (sizeOfBallot p) + func a = c_pokePrefArray numBal sizeBal a (fromIntegral n) (fromIntegral s) (fromIntegral r) + withForeignPtr (pointer p) func + + + + +peekPref :: PrefStorage -> Int -> Int -> Int -> IO Bool +peekPref p n s r = do + let numBal = fromIntegral (numBallots p) + sizeBal = fromIntegral (sizeOfBallot p) + func a = c_peekPrefArray numBal sizeBal a (fromIntegral n) (fromIntegral s) (fromIntegral r) + result <- withForeignPtr (pointer p) func + return (result /= 0) + diff --git a/old/preference_arrays.adb b/old/preference_arrays.adb new file mode 100644 index 0000000..0b1218a --- /dev/null +++ b/old/preference_arrays.adb @@ -0,0 +1,114 @@ + + +with Ada.Unchecked_Deallocation; +with System.Address_To_Access_Conversions; + + +package body Preference_Arrays is + + + type Ranking is range 1 .. 255; + + type Preference_Array is array (Positive range <>, Positive range <>) of Ranking; + pragma Pack (Preference_Array); + + + + + -- these following functions would be a lot smaller and neater + -- if the FFI could make use of fat pointers + + + + + function Create_Preference_Array + (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int) + return System.Address + is + subtype Constrained is Preference_Array + (1 .. Positive (Number_Of_Ballots), + 1 .. Positive (Size_Of_Ballot)); + + package Convert is new System.Address_To_Access_Conversions + (Object => Constrained); + + Pref_Array : Convert.Object_Pointer; + begin + Pref_Array := new Preference_Array + (1 .. Positive (Number_Of_Ballots), + 1 .. Positive (Size_Of_Ballot)); + return Convert.To_Address (Pref_Array); + end Create_Preference_Array; + + + + + procedure Free_Preference_Array + (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; + Pref_Array_Address : in System.Address) + is + subtype Constrained is Preference_Array + (1 .. Positive (Number_Of_Ballots), + 1 .. Positive (Size_Of_Ballot)); + + package Convert is new System.Address_To_Access_Conversions + (Object => Constrained); + procedure Free_Pref_Array is new Ada.Unchecked_Deallocation + (Object => Constrained, Name => Convert.Object_Pointer); + + Pref_Array : Convert.Object_Pointer; + begin + Pref_Array := Convert.To_Pointer (Pref_Array_Address); + Free_Pref_Array (Pref_Array); + end Free_Preference_Array; + + + + + procedure Poke_Preference_Array + (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; + Pref_Array_Address : in System.Address; + Ballot_Index, Box_Number, Rank : in Interfaces.C.int) + is + subtype Constrained is Preference_Array + (1 .. Positive (Number_Of_Ballots), + 1 .. Positive (Size_Of_Ballot)); + + package Convert is new System.Address_To_Access_Conversions + (Object => Constrained); + + Pref_Array : Convert.Object_Pointer; + begin + Pref_Array := Convert.To_Pointer (Pref_Array_Address); + Pref_Array (Positive (Ballot_Index), Positive (Box_Number)) := Ranking (Rank); + end Poke_Preference_Array; + + + + + function Peek_Preference_Array + (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; + Pref_Array_Address : in System.Address; + Ballot_Index, Box_Number, Rank : in Interfaces.C.int) + return Interfaces.C.int + is + subtype Constrained is Preference_Array + (1 .. Positive (Number_Of_Ballots), + 1 .. Positive (Size_Of_Ballot)); + + package Convert is new System.Address_To_Access_Conversions + (Object => Constrained); + + Pref_Array : Convert.Object_Pointer; + begin + Pref_Array := Convert.To_Pointer (Pref_Array_Address); + if Pref_Array (Positive (Ballot_Index), Positive (Box_Number)) = Ranking (Rank) then + return 1; + else + return 0; + end if; + end Peek_Preference_Array; + + +end Preference_Arrays; + diff --git a/old/preference_arrays.ads b/old/preference_arrays.ads new file mode 100644 index 0000000..c8245e0 --- /dev/null +++ b/old/preference_arrays.ads @@ -0,0 +1,38 @@ + + +with Interfaces.C; +with System; + + +package Preference_Arrays is + + + function Create_Preference_Array + (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int) + return System.Address; + pragma Export (C, Create_Preference_Array, "create_pref_array"); + + + procedure Free_Preference_Array + (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; + Pref_Array_Address : in System.Address); + pragma Export (C, Free_Preference_Array, "free_pref_array"); + + + procedure Poke_Preference_Array + (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; + Pref_Array_Address : in System.Address; + Ballot_Index, Box_Number, Rank : in Interfaces.C.int); + pragma Export (C, Poke_Preference_Array, "poke_pref_array"); + + + function Peek_Preference_Array + (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; + Pref_Array_Address : in System.Address; + Ballot_Index, Box_Number, Rank : in Interfaces.C.int) + return Interfaces.C.int; + pragma Export (C, Peek_Preference_Array, "peek_pref_array"); + + +end Preference_Arrays; + diff --git a/old/testmain.hs b/old/testmain.hs new file mode 100644 index 0000000..3f340c2 --- /dev/null +++ b/old/testmain.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + + + +import qualified Storage as Store + + + +foreign import ccall adainit :: IO Int +foreign import ccall adafinal :: IO Int + + + +main = do + adainit + s <- Store.createStorage 10 5 + Store.pokePref s 1 2 3 + r <- Store.peekPref s 1 2 3 + putStrLn (show r) + adafinal + diff --git a/src/Storage.hs.old b/src/Storage.hs.old deleted file mode 100644 index 2697c39..0000000 --- a/src/Storage.hs.old +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - -module Storage( - PrefStorage, - createStorage, - pokePref, - peekPref - ) where - - - - -import Foreign -import Foreign.C - - - - -foreign import ccall "create_pref_array" - c_createPrefArray :: CInt -> CInt -> IO (Ptr PrefArray) - -foreign import ccall "free_pref_array" - c_freePrefArray :: CInt -> CInt -> Ptr PrefArray -> IO () - -foreign import ccall "wrapper" - wrap :: (Ptr PrefArray -> IO ()) -> IO (FunPtr (Ptr PrefArray -> IO ())) - -foreign import ccall "poke_pref_array" - c_pokePrefArray :: CInt -> CInt -> Ptr PrefArray -> CInt -> CInt -> CInt -> IO () - -foreign import ccall "peek_pref_array" - c_peekPrefArray :: CInt -> CInt -> Ptr PrefArray -> CInt -> CInt -> CInt -> IO CInt - - - - -newtype PrefArray = PrefArray (Ptr PrefArray) - -data PrefStorage = PrefStorage { pointer :: ForeignPtr PrefArray - , numBallots :: Int - , sizeOfBallot :: Int } - - - - -createStorage :: Int -> Int -> IO PrefStorage -createStorage n s = do - x <- c_createPrefArray (fromIntegral n) (fromIntegral s) - f <- wrap (c_freePrefArray (fromIntegral n) (fromIntegral s)) - y <- newForeignPtr f x - return (PrefStorage y n s) - - - - -pokePref :: PrefStorage -> Int -> Int -> Int -> IO () -pokePref p n s r = do - let numBal = fromIntegral (numBallots p) - sizeBal = fromIntegral (sizeOfBallot p) - func a = c_pokePrefArray numBal sizeBal a (fromIntegral n) (fromIntegral s) (fromIntegral r) - withForeignPtr (pointer p) func - - - - -peekPref :: PrefStorage -> Int -> Int -> Int -> IO Bool -peekPref p n s r = do - let numBal = fromIntegral (numBallots p) - sizeBal = fromIntegral (sizeOfBallot p) - func a = c_peekPrefArray numBal sizeBal a (fromIntegral n) (fromIntegral s) (fromIntegral r) - result <- withForeignPtr (pointer p) func - return (result /= 0) - diff --git a/src/preference_arrays.adb.old b/src/preference_arrays.adb.old deleted file mode 100644 index 0b1218a..0000000 --- a/src/preference_arrays.adb.old +++ /dev/null @@ -1,114 +0,0 @@ - - -with Ada.Unchecked_Deallocation; -with System.Address_To_Access_Conversions; - - -package body Preference_Arrays is - - - type Ranking is range 1 .. 255; - - type Preference_Array is array (Positive range <>, Positive range <>) of Ranking; - pragma Pack (Preference_Array); - - - - - -- these following functions would be a lot smaller and neater - -- if the FFI could make use of fat pointers - - - - - function Create_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int) - return System.Address - is - subtype Constrained is Preference_Array - (1 .. Positive (Number_Of_Ballots), - 1 .. Positive (Size_Of_Ballot)); - - package Convert is new System.Address_To_Access_Conversions - (Object => Constrained); - - Pref_Array : Convert.Object_Pointer; - begin - Pref_Array := new Preference_Array - (1 .. Positive (Number_Of_Ballots), - 1 .. Positive (Size_Of_Ballot)); - return Convert.To_Address (Pref_Array); - end Create_Preference_Array; - - - - - procedure Free_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address) - is - subtype Constrained is Preference_Array - (1 .. Positive (Number_Of_Ballots), - 1 .. Positive (Size_Of_Ballot)); - - package Convert is new System.Address_To_Access_Conversions - (Object => Constrained); - procedure Free_Pref_Array is new Ada.Unchecked_Deallocation - (Object => Constrained, Name => Convert.Object_Pointer); - - Pref_Array : Convert.Object_Pointer; - begin - Pref_Array := Convert.To_Pointer (Pref_Array_Address); - Free_Pref_Array (Pref_Array); - end Free_Preference_Array; - - - - - procedure Poke_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address; - Ballot_Index, Box_Number, Rank : in Interfaces.C.int) - is - subtype Constrained is Preference_Array - (1 .. Positive (Number_Of_Ballots), - 1 .. Positive (Size_Of_Ballot)); - - package Convert is new System.Address_To_Access_Conversions - (Object => Constrained); - - Pref_Array : Convert.Object_Pointer; - begin - Pref_Array := Convert.To_Pointer (Pref_Array_Address); - Pref_Array (Positive (Ballot_Index), Positive (Box_Number)) := Ranking (Rank); - end Poke_Preference_Array; - - - - - function Peek_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address; - Ballot_Index, Box_Number, Rank : in Interfaces.C.int) - return Interfaces.C.int - is - subtype Constrained is Preference_Array - (1 .. Positive (Number_Of_Ballots), - 1 .. Positive (Size_Of_Ballot)); - - package Convert is new System.Address_To_Access_Conversions - (Object => Constrained); - - Pref_Array : Convert.Object_Pointer; - begin - Pref_Array := Convert.To_Pointer (Pref_Array_Address); - if Pref_Array (Positive (Ballot_Index), Positive (Box_Number)) = Ranking (Rank) then - return 1; - else - return 0; - end if; - end Peek_Preference_Array; - - -end Preference_Arrays; - diff --git a/src/preference_arrays.ads.old b/src/preference_arrays.ads.old deleted file mode 100644 index c8245e0..0000000 --- a/src/preference_arrays.ads.old +++ /dev/null @@ -1,38 +0,0 @@ - - -with Interfaces.C; -with System; - - -package Preference_Arrays is - - - function Create_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int) - return System.Address; - pragma Export (C, Create_Preference_Array, "create_pref_array"); - - - procedure Free_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address); - pragma Export (C, Free_Preference_Array, "free_pref_array"); - - - procedure Poke_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address; - Ballot_Index, Box_Number, Rank : in Interfaces.C.int); - pragma Export (C, Poke_Preference_Array, "poke_pref_array"); - - - function Peek_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address; - Ballot_Index, Box_Number, Rank : in Interfaces.C.int) - return Interfaces.C.int; - pragma Export (C, Peek_Preference_Array, "peek_pref_array"); - - -end Preference_Arrays; - diff --git a/src/testmain.hs.old b/src/testmain.hs.old deleted file mode 100644 index 3f340c2..0000000 --- a/src/testmain.hs.old +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - - - -import qualified Storage as Store - - - -foreign import ccall adainit :: IO Int -foreign import ccall adafinal :: IO Int - - - -main = do - adainit - s <- Store.createStorage 10 5 - Store.pokePref s 1 2 3 - r <- Store.peekPref s 1 2 3 - putStrLn (show r) - adafinal - -- cgit