primitive pattern matching

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

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)}))
 

devel/compiler/Eval.hs

@@ -4,11 +4,12 @@ import AbsSrc
 import AbsTgt
 import SMacros
 import TMacros
-
+import Match
-import ComposOp
-import STM
 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
+  ETab ty cs -> do
-    vs <- mapM eval [e | Cas _ e <- cs] ---- expand and pattern match
+--    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

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
+

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

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

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] "}" ;
+ETab. Exp1 ::= "table" Type "{" [Case] "}" ;
-ETbv. Exp1  ::= "table" "(" Type ")" "{" [Exp] "}" ;
 ECat. Exp  ::= Exp "++" Exp1 ;
 EAbs. Exp  ::= "\\" Ident "->" Exp ;
 

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

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@)} 
 } ;
--}