From 1b6f0e17752445668237167e88229adbb14cb64d Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Sun, 8 Jan 2017 19:13:43 +1100 Subject: New preference data array structure in Ada, currently won't link --- .gitignore | 13 ------ bin/.gitignore | 8 ++++ build/.gitignore | 8 ++++ data/.gitignore | 8 ++++ makefile | 18 ++++++++ src/Storage.hs | 73 +++++++++++++++++++++++++++++ src/preference_arrays.adb | 114 ++++++++++++++++++++++++++++++++++++++++++++++ src/preference_arrays.ads | 38 ++++++++++++++++ src/testmain.hs | 21 +++++++++ 9 files changed, 288 insertions(+), 13 deletions(-) delete mode 100644 .gitignore create mode 100644 bin/.gitignore create mode 100644 build/.gitignore create mode 100644 data/.gitignore create mode 100644 makefile create mode 100644 src/Storage.hs create mode 100644 src/preference_arrays.adb create mode 100644 src/preference_arrays.ads create mode 100644 src/testmain.hs diff --git a/.gitignore b/.gitignore deleted file mode 100644 index a681d78..0000000 --- a/.gitignore +++ /dev/null @@ -1,13 +0,0 @@ - - -# ignore intermediate compilation files - -*.hi -*.o - - -# ignore any test data - -*.csv -*.csv# - diff --git a/bin/.gitignore b/bin/.gitignore new file mode 100644 index 0000000..fc50a55 --- /dev/null +++ b/bin/.gitignore @@ -0,0 +1,8 @@ + + +# ignore all in this directory except this file + +* +!.gitignore + + diff --git a/build/.gitignore b/build/.gitignore new file mode 100644 index 0000000..fc50a55 --- /dev/null +++ b/build/.gitignore @@ -0,0 +1,8 @@ + + +# ignore all in this directory except this file + +* +!.gitignore + + diff --git a/data/.gitignore b/data/.gitignore new file mode 100644 index 0000000..fc50a55 --- /dev/null +++ b/data/.gitignore @@ -0,0 +1,8 @@ + + +# ignore all in this directory except this file + +* +!.gitignore + + diff --git a/makefile b/makefile new file mode 100644 index 0000000..cb953a2 --- /dev/null +++ b/makefile @@ -0,0 +1,18 @@ + + +all: testmain + + + +testmain: ada_array + ghc --make src/testmain.hs -isrc:build -odir build -outputdir build \ + -hidir build -stubdir build -dumpdir build -o bin/testmain build/ada_array.o + + + +ada_array: + gnatmake -Isrc -D build -c preference_arrays + gnatbind -n build/preference_arrays + gnatlink -r -nostdlib -o build/ada_array.o build/preference_arrays.ali + + diff --git a/src/Storage.hs b/src/Storage.hs new file mode 100644 index 0000000..2697c39 --- /dev/null +++ b/src/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/src/preference_arrays.adb b/src/preference_arrays.adb new file mode 100644 index 0000000..0b1218a --- /dev/null +++ b/src/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/src/preference_arrays.ads b/src/preference_arrays.ads new file mode 100644 index 0000000..c8245e0 --- /dev/null +++ b/src/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/src/testmain.hs b/src/testmain.hs new file mode 100644 index 0000000..3f340c2 --- /dev/null +++ b/src/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 + -- cgit