From fd518ed2a3fe50238e0e9e7947e33cc9d5de9bce Mon Sep 17 00:00:00 2001
From: aarne <aarne@cs.chalmers.se>
Date: Tue, 27 Mar 2007 20:54:49 +0000
Subject: [PATCH] primitive pattern matching

---
 devel/compiler/Compile.hs |  5 +++--
 devel/compiler/Env.hs     |  6 +++++-
 devel/compiler/Eval.hs    | 15 +++++++++------
 devel/compiler/Match.hs   | 21 +++++++++++++++++++++
 devel/compiler/Param.hs   |  9 +--------
 devel/compiler/PrEnv.hs   |  7 ++++---
 devel/compiler/Src.cf     |  3 +--
 devel/compiler/TMacros.hs |  6 +++++-
 devel/compiler/ex.src     | 18 ++++++++++++------
 9 files changed, 61 insertions(+), 29 deletions(-)
 create mode 100644 devel/compiler/Match.hs

diff --git a/devel/compiler/Compile.hs b/devel/compiler/Compile.hs
index 7ebb65f0e..f21fca632 100644
--- a/devel/compiler/Compile.hs
+++ b/devel/compiler/Compile.hs
@@ -27,9 +27,10 @@ compDef d = case d of
     addOper f exp
   DPar  p cs -> do
     v <- sizeParType cs
-    addTypedef p $ TVal $ toInteger $ fst v
+    let ty = TBas p
+    addParsize ty $ fst v
     vals <- allParVals cs
-    addPartype (TBas p) vals
+    addPartype ty vals
     mapM_ (uncurry addParVal) (zip vals (map VPar [0..])) 
   DOpty a ty -> do
     addTypedef a ty
diff --git a/devel/compiler/Env.hs b/devel/compiler/Env.hs
index d29b9a3a5..7e1d23983 100644
--- a/devel/compiler/Env.hs
+++ b/devel/compiler/Env.hs
@@ -11,13 +11,14 @@ data Env = Env {
   types    :: M.Map Ident Type,
   opers    :: M.Map Ident Exp,
   typedefs :: M.Map Ident Type,
+  parsizes :: M.Map Type  Int,
   partypes :: M.Map Type  [Exp],
   parvals  :: M.Map Exp   Val,
   vars     :: M.Map Ident Val
 ---  constrs  :: M.Map Ident ([Int] -> Int)
   }
 
-emptyEnv = Env M.empty M.empty M.empty M.empty M.empty M.empty M.empty
+emptyEnv = Env M.empty M.empty M.empty M.empty M.empty M.empty M.empty M.empty
 
 lookEnv :: (Show i, Ord i) => (Env -> M.Map i a) -> i -> STM Env a
 lookEnv field c = do
@@ -36,6 +37,9 @@ addOper c v = updateSTM (\env -> (env{opers = M.insert c v (opers env)}))
 addTypedef :: Ident -> Type -> STM Env ()
 addTypedef c v = updateSTM (\env -> (env{typedefs = M.insert c v (typedefs env)}))
 
+addParsize :: Type -> Int -> STM Env ()
+addParsize c v = updateSTM (\env -> (env{parsizes = M.insert c v (parsizes env)}))
+
 addPartype :: Type -> [Exp] -> STM Env ()
 addPartype c v = updateSTM (\env -> (env{partypes = M.insert c v (partypes env)}))
 
diff --git a/devel/compiler/Eval.hs b/devel/compiler/Eval.hs
index cc1b22467..b59fb53f2 100644
--- a/devel/compiler/Eval.hs
+++ b/devel/compiler/Eval.hs
@@ -4,11 +4,12 @@ import AbsSrc
 import AbsTgt
 import SMacros
 import TMacros
-
-import ComposOp
-import STM
+import Match
 import Env
 
+import STM
+
+
 eval :: Exp -> STM Env Val
 eval e = case e of
   EAbs x b -> do
@@ -38,11 +39,13 @@ eval e = case e of
     vs <- mapM eval [e | FExp _ e <- fs]
     return $ VRec vs
 
-  ETab cs -> do
-    vs <- mapM eval [e | Cas _ e <- cs] ---- expand and pattern match
+  ETab ty cs -> do
+--    sz <- lookEnv parsizes ty
+--    let ps = map (VPar . toInteger) [0..sz-1]
+    ps <- lookEnv partypes ty
+    vs <- mapM (\p -> match cs p >>= eval) ps
     return $ VRec vs
    
-
   ESel t v -> do
     t' <- eval t
     v' <- eval v
diff --git a/devel/compiler/Match.hs b/devel/compiler/Match.hs
new file mode 100644
index 000000000..a9ac839ef
--- /dev/null
+++ b/devel/compiler/Match.hs
@@ -0,0 +1,21 @@
+module Match where
+
+import AbsSrc
+import AbsTgt
+
+import Env
+import STM
+
+match :: [Case] -> Exp -> STM Env Exp
+match cs v = checks $ map (tryMatch v) cs
+
+---- return substitution  
+tryMatch :: Exp -> Case -> STM Env Exp
+tryMatch e (Cas p v) = if fit (e, p) then return v else raise "no fit" where
+  fit (exp,patt) = case (exp,patt) of
+    (ECst c es, PCon d ps) ->
+      c == d  &&
+      length es == length ps &&
+      all fit (zip es ps)
+    (_,PVar _) -> True ---- not is exp contains variables
+
diff --git a/devel/compiler/Param.hs b/devel/compiler/Param.hs
index 7eea9f03f..5137faa7b 100644
--- a/devel/compiler/Param.hs
+++ b/devel/compiler/Param.hs
@@ -12,16 +12,9 @@ sizeParType cs = do
   return (sum scs, length cs)
  where
   sizeC (Con c ts) = do
-    ats <- mapM lookParTypeSize ts
+    ats <- mapM (lookEnv parsizes) ts
     return $ product ats
 
-lookParTypeSize :: Type -> STM Env Int
-lookParTypeSize ty = case ty of
-  TBas c -> do
-    ty' <- lookEnv typedefs c
-    lookParTypeSize ty'
-  TVal i -> return $ fromInteger i
-
 allParVals :: [Constr] -> STM Env [Exp]
 allParVals cs = do
   ess <- mapM alls cs
diff --git a/devel/compiler/PrEnv.hs b/devel/compiler/PrEnv.hs
index d669e131d..910626a42 100644
--- a/devel/compiler/PrEnv.hs
+++ b/devel/compiler/PrEnv.hs
@@ -12,9 +12,6 @@ import qualified Data.Map as M
 
 prEnv :: Env -> IO ()
 prEnv env = do
-  putStrLn "--# values"
-  mapM_ putStrLn 
-    [prs c ++ " = " ++ prt val | (c,val) <- M.toList $ values env]
   putStrLn "--# types"
   mapM_ putStrLn 
     [prs c ++ " : " ++ prs val | (c,val) <- M.toList $ types env]
@@ -27,6 +24,10 @@ prEnv env = do
   putStrLn "--# parvals"
   mapM_ putStrLn 
     [prs c ++ " = " ++ prt val | (c,val) <- M.toList $ parvals env]
+  putStrLn "--# values"
+  mapM_ putStrLn 
+    [prs c ++ " = " ++ prt val | (c,val) <- M.toList $ values env]
+
 
 prs :: (S.Print a) => a -> String
 prs = S.printTree
diff --git a/devel/compiler/Src.cf b/devel/compiler/Src.cf
index ccf9ec04b..d3b29ee45 100644
--- a/devel/compiler/Src.cf
+++ b/devel/compiler/Src.cf
@@ -34,8 +34,7 @@ ERec. Exp2 ::= "{" [Assign] "}" ;
 EApp. Exp1 ::= Exp1 Exp2 ;
 ESel. Exp1 ::= Exp1 "!" Exp2 ;
 EPro. Exp1 ::= Exp1 "." Exp2 ;
-ETab. Exp1  ::= "table" "{" [Case] "}" ;
-ETbv. Exp1  ::= "table" "(" Type ")" "{" [Exp] "}" ;
+ETab. Exp1 ::= "table" Type "{" [Case] "}" ;
 ECat. Exp  ::= Exp "++" Exp1 ;
 EAbs. Exp  ::= "\\" Ident "->" Exp ;
 
diff --git a/devel/compiler/TMacros.hs b/devel/compiler/TMacros.hs
index 467b6ce4f..f06c34d6d 100644
--- a/devel/compiler/TMacros.hs
+++ b/devel/compiler/TMacros.hs
@@ -11,6 +11,10 @@ compVal args = comp where
     VRec vs  -> VRec $ map comp vs
     VPro r p -> case (comp r, comp p) of
       (VRec vs, VPar i) -> vs !! fromInteger i 
-    VArg i   -> args !! fromInteger i
+      (r',p') -> VPro r' p' ---- not at runtime
+    VArg j
+      | i < length args -> args !! i ---- not needed at runtime
+      | otherwise -> val   ---- not the right thing at compiletime either
+          where i = fromInteger j
     VCat x y -> VCat (comp x) (comp y)
     _ -> val
diff --git a/devel/compiler/ex.src b/devel/compiler/ex.src
index e8f0c6374..6169cb5ee 100644
--- a/devel/compiler/ex.src
+++ b/devel/compiler/ex.src
@@ -8,14 +8,13 @@ oper Agr = {g : Gen ; n : Num} ;
 oper CN = {s : Num -> Str ; g : Gen} ;
 oper NP = {s : Str ; a : Agr} ;
 
-oper artDef : Gen -> Str = \g -> table {
+oper artDef : Gen -> Str = \g -> table Gen {
   (Masc) => "le" ;
   (Fem) => "la"
 } ! $g ;
 
-
 lin Voiture : CN = {
-  s = table {
+  s = table Num {
     (Sg) => "voiture" ;
     (Pl) => "voitures"
   } ;
@@ -24,13 +23,20 @@ lin Voiture : CN = {
 
 
 lin Bus : CN = {
-  s = table {$x => "bus"} ;
+  s = table Num {$x => "bus"} ;
   g = (Masc@)
 } ;
 
-{-
+lin Indef : CN -> NP = \cn -> {
+  s = table Gen {
+        (Masc) => "un" ;
+        $x     => "une"
+        } ! $cn.g ++ $cn.s ! (Sg@) ;
+  a = {g = $cn.g ; n = (Sg@)} 
+} ;
+
+
 lin Def : CN -> NP = \cn -> {
   s = &artDef $cn.g ++ $cn.s ! (Sg@) ;
   a = {g = $cn.g ; n = (Sg@)} 
 } ;
--}
\ No newline at end of file