New preference data array structure in Ada, currently won't link

4 files changed, 246 insertions, 0 deletions

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
+