From ae17fd1dfb5599436cdc901123b2b01d3ecaa8fb Mon Sep 17 00:00:00 2001
From: Francis Russell <francis@unchartedbackwaters.co.uk>
Date: Thu, 27 Sep 2012 23:20:25 +0100
Subject: [PATCH] Build complete second-level symbol table.

---
 OFC/Parser.hs        |  2 +-
 OFC/SecondLevel.hs   | 19 +++++++++++++++----
 OFC/TargetMapping.hs | 25 +++++++++++++++++++++++--
 3 files changed, 39 insertions(+), 7 deletions(-)

diff --git a/OFC/Parser.hs b/OFC/Parser.hs
index 903c220..86c5504 100644
--- a/OFC/Parser.hs
+++ b/OFC/Parser.hs
@@ -207,7 +207,7 @@ parseFortranParam = do
   properties <- lCommaSep parseFortranParamProperty
   return $ FortranParameter properties
 
-parseFortranParamProperty :: OFLParser FortranParameterProperty
+parseFortranParamProperty :: OFLParser FortranParamProperty
 parseFortranParamProperty =
   parseNameProperty 
   <|> parseTypeProperty 
diff --git a/OFC/SecondLevel.hs b/OFC/SecondLevel.hs
index e32f0d8..e0dd068 100644
--- a/OFC/SecondLevel.hs
+++ b/OFC/SecondLevel.hs
@@ -1,7 +1,7 @@
 module OFC.SecondLevel where
 import OFC.Common
 import OFC.TargetMapping (MappingTable, FortranFunction)
-import qualified OFC.TargetMapping as TargetMapping
+import qualified OFC.TargetMapping as TM
 import OFC.TopLevel (OFL)
 import qualified OFC.TopLevel as TopLevel
 import Data.Complex
@@ -110,6 +110,17 @@ addValue ofl table name = Map.insert name symbolType table where
   valueType = getTargetValueType $ TopLevel.getTargetType ofl name
   indexTypes = TopLevel.getIndices ofl name
 
-getTargetValueType :: TargetMapping.TargetType -> ValueType
-getTargetValueType (TargetMapping.PPDFunctionSet _) = Psinc 1
-getTargetValueType t = error $ "Not implemented translation of " ++ show t ++ " to second-level value type."
+getTargetValueType :: TM.TargetType -> ValueType
+getTargetValueType (TM.PPDFunctionSet _) = Psinc 1
+getTargetValueType (TM.FortranParameter properties) = case TM.findSpace properties of
+  Just (TM.CoarsePsinc _) -> Psinc 1
+  Just (TM.FinePsinc _) -> Psinc 2
+  Nothing -> case TM.findParamType properties of
+    Just fortranType -> fortranToValueType fortranType
+    Nothing -> error $ "Unable to infer type from supplied properties: " ++ show properties
+    where 
+    fortranToValueType TM.SPAM3 = RealType
+    fortranToValueType TM.Double = RealType
+    fortranToValueType TM.FunctionBasis = error "ONETEP function basis cannot be mapped to value types."
+    fortranToValueType TM.Integer = IntegerType
+    fortranToValueType (TM.Array t _) = fortranToValueType t
diff --git a/OFC/TargetMapping.hs b/OFC/TargetMapping.hs
index 2cbe4dc..feea412 100644
--- a/OFC/TargetMapping.hs
+++ b/OFC/TargetMapping.hs
@@ -1,10 +1,11 @@
 module OFC.TargetMapping where
 import Data.Map (Map)
+import Data.Maybe (catMaybes)
 
 type MappingTable = Map String TargetType
 
 data TargetType = 
-  FortranParameter [FortranParameterProperty] |
+  FortranParameter [FortranParamProperty] |
   PPDFunctionSet [PPDFunctionSetProperty]
   deriving Show
 
@@ -26,7 +27,7 @@ data SpaceInfo =
   FinePsinc [String]
   deriving Show
 
-data FortranParameterProperty =
+data FortranParamProperty =
   ParamName String |
   ParamType FortranType |
   Space SpaceInfo |
@@ -46,3 +47,23 @@ data FortranFunctionProperty =
   FortranFunctionName String |
   FortranFunctionParams [String]
   deriving Show
+
+findSpace :: [FortranParamProperty] -> Maybe SpaceInfo
+findSpace properties = getProperty toSpaceInfo properties
+  where
+  toSpaceInfo (Space info) = Just info
+  toSpaceInfo _ = Nothing
+
+findParamType :: [FortranParamProperty] -> Maybe FortranType
+findParamType properties = getProperty toFortranType properties
+  where
+  toFortranType (ParamType t) = Just t
+  toFortranType _ = Nothing
+
+
+getProperty :: (Show a) => (FortranParamProperty -> Maybe a) -> [FortranParamProperty] -> Maybe a
+getProperty getter properties = case catMaybes $ map getter properties of
+  [] -> Nothing
+  [x] -> Just x
+  dups -> error $ "Duplicate properties found: " ++ show dups
+  
-- 
2.47.3