Merge pull request #207 from krangelov/majestic

Majestic

src/compiler/api/GF/Command/Importing.hs

@@ -1,7 +1,7 @@
 module GF.Command.Importing (importGrammar, importSource) where
 
 import PGF2
-import PGF2.Transactions
+import PGF2.Transactions hiding (Rule(..))
 
 import GF.Compile
 import GF.Compile.Multi (readMulti)

src/compiler/api/GF/Command/SourceCommands.hs

@@ -19,8 +19,8 @@ import GF.Grammar.Analyse
 import GF.Grammar.ShowTerm
 import GF.Grammar.Lookup (allOpers,allOpersTo)
 import GF.Compile.Rename(renameSourceTerm)
-import GF.Compile.Compute.Concrete2(normalForm,normalFlatForm,Globals(..),stdPredef)
+import GF.Compile.Compute(normalForm,normalFlatForm,Globals(..),stdPredef)
-import GF.Compile.TypeCheck.Concrete as TC(inferLType)
+import GF.Compile.TypeCheck as TC(inferLType)
 
 import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
 import GF.Command.CommandInfo
@@ -253,7 +253,7 @@ checkComputeTerm os sgr t =
     -- ** Try to compute pre{...} tokens in token sequences
     singleton x = [x]
 
-    g = Gl sgr (stdPredef g)
+    g = Gl sgr (stdPredef g) False
 
     evalStr t =
       case t of

src/compiler/api/GF/Compile/CheckGrammar.hs

@@ -26,13 +26,13 @@ import Prelude hiding ((<>))
 import GF.Infra.Ident
 import GF.Infra.Option
 
-import GF.Compile.TypeCheck.Abstract
+import GF.Compile.TypeCheck(checkLType,inferLType,checkContext,checkDef)
-import GF.Compile.TypeCheck.Concrete(checkLType,inferLType)
+import GF.Compile.Compute(normalForm,Globals(..),noPredef,stdPredef)
-import GF.Compile.Compute.Concrete2(normalForm,Globals(..),stdPredef)
 
 import GF.Grammar
 import GF.Grammar.Lexer
 import GF.Grammar.Lookup
+import GF.Grammar.Lockfield
 
 import GF.Data.Operations
 import GF.Infra.CheckM
@@ -52,8 +52,8 @@ checkModule opts cwd sgr mo@(m,mi) = do
                              abs <- lookupModule gr a
                              checkCompleteGrammar opts cwd gr (a,abs) mo
           _            -> return mo
-  infoss <- checkInModule cwd mi NoLoc empty $ topoSortJments2 mo
+  infos <- checkInModule cwd mi NoLoc empty $ topoSortJments mo
-  foldM (foldM (checkInfo opts cwd sgr)) mo infoss
+  foldM (checkInfo opts cwd sgr) mo infos
 
 -- check if restricted inheritance modules are still coherent
 -- i.e. that the defs of remaining names don't depend on omitted names
@@ -70,7 +70,7 @@ checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty
      let incld c   = Set.member c (Set.fromList incl)
      let illegal c = Set.member c (Set.fromList excl)
      let illegals = [(f,is) |
-           (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
+           (f,_,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
      case illegals of
        [] -> return ()
        cs -> checkWarn ("In inherited module" <+> i <> ", dependence of excluded constants:" $$
@@ -92,7 +92,7 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
   where
    checkAbs js i@(c,info) =
      case info of
-       AbsFun (Just (L loc ty)) _ _ _
+       AbsFun (Just (L loc ty)) _
            -> do let mb_def = do
                        let (cxt,(_,i),_) = typeForm ty
                        info <- lookupIdent i js
@@ -134,7 +134,7 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
    checkCnc js (c,info) =
      case info of
        CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
-                             Ok (_,AbsFun (Just (L loc ty)) _ _ _) ->
+                             Ok (_,AbsFun (Just (L loc ty)) _) ->
                                         do linty <- linTypeOfType gr cm (L loc ty)
                                            return $ Map.insert c (CncFun (Just linty) d mn mf) js
                              _       -> do checkWarn ("function" <+> c <+> "is not in abstract")
@@ -156,57 +156,69 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
   checkReservedId c
   case info of
     AbsCat (Just (L loc cont)) ->
-      mkCheck loc "the category" $
+      chIn loc "the category" $ do
-        checkContext gr cont
+        cont <- checkContext ga cont
+        update sm c (AbsCat (Just (L loc cont)))
 
-    AbsFun (Just (L loc typ)) ma md moper -> do
+    AbsFun (Just (L loc typ)) md -> do
-      mkCheck loc "the type of function" $
+      (typ,_) <- chIn loc "the type of function" $
-        checkTyp gr typ
+                   checkLType ga typ typeType
-      typ <- compAbsTyp [] typ   -- to calculate let definitions
+      typ <- normalForm ga typ   -- to calculate let definitions
-      case md of
+      sm <- update sm c (AbsFun (Just (L loc typ)) md)
-        Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
+      let gr' = prependModule sgr sm
-                                          checkDef gr (fst sm,c) typ eq) eqs
+          ga' = Gl gr' noPredef True
-        Nothing  -> return ()
+      md <- case md of
-      update sm c (AbsFun (Just (L loc typ)) ma md moper)
+              Just (_,eqs) -> do eqs <- mapM (\(L loc eq) -> chIn loc "the definition of function" $
+                                                            fmap (L loc) (checkDef ga (fst sm,c) typ eq)) eqs
+                                 arity <-
+                                    case [length ps | L _ (ps,_) <- eqs] of
+                                      []                   -> return 0
+                                      (arity : as) 
+                                        | all (==arity) as -> return arity
+                                      _ -> checkError ("The following equations have different arities" $$
+                                                       nest 4 (vcat [ppQIdent Unqualified (fst sm,c) <+> hsep (map (ppPatt Unqualified 2) ps) | L _ (ps,_) <- eqs]))
+                                 return (Just (arity,eqs))
+              Nothing  -> return Nothing
+      update sm c (AbsFun (Just (L loc typ)) md)
 
     CncCat mty mdef mref mpr mpmcfg -> do
       mty  <- case mty of
                 Just (L loc typ) -> chIn loc "linearization type of" $ do
-                                      (typ,_) <- checkLType g typ typeType
+                                      (typ,_) <- checkLType gc typ typeType
-                                      typ  <- normalForm g typ
+                                      typ  <- normalForm gc typ
                                       return (Just (L loc typ))
                 Nothing          -> return Nothing
       mdef <- case (mty,mdef) of
                 (Just (L _ typ),Just (L loc def)) ->
                     chIn loc "default linearization of" $ do
-                       (def,_) <- checkLType g def (mkFunType [typeStr] typ)
+                       (def,_) <- checkLType gc def (mkFunType [typeStr] typ)
                        return (Just (L loc def))
                 _ -> return Nothing
       mref <- case (mty,mref) of
                 (Just (L _ typ),Just (L loc ref)) ->
                     chIn loc "reference linearization of" $ do
-                       (ref,_) <- checkLType g ref (mkFunType [typ] typeStr)
+                       (ref,_) <- checkLType gc ref (mkFunType [typ] typeStr)
                        return (Just (L loc ref))
                 _ -> return Nothing
       mpr  <- case mpr of
                 (Just (L loc t)) ->
                     chIn loc "print name of" $ do
-                       (t,_) <- checkLType g t typeStr
+                       (t,_) <- checkLType gc t typeStr
                        return (Just (L loc t))
                 _ -> return Nothing
       update sm c (CncCat mty mdef mref mpr mpmcfg)
 
     CncFun mty mt mpr mpmcfg -> do
       mt <- case (mty,mt) of
-              (Just (_,cat,cont,val),Just (L loc trm)) ->
+              (Just (args,cat,cont,val),Just (L loc trm)) ->
                   chIn loc "linearization of" $ do
-                     (trm,_) <- checkLType g trm (mkFunType (map (\(_,_,ty) -> ty) cont) val)  -- erases arg vars
+                     (trm,_) <- checkLType gc trm (mkFunType (zipWith (\cat (_,_,ty) -> lock cat ty) args cont) val)  -- erases arg vars
                      return (Just (L loc (etaExpand [] trm cont)))
               _ -> return mt
       mpr  <- case mpr of
                 (Just (L loc t)) ->
                     chIn loc "print name of" $ do
-                       (t,_) <- checkLType g t typeStr
+                       (t,_) <- checkLType gc t typeStr
                        return (Just (L loc t))
                 _ -> return Nothing
       update sm c (CncFun mty mt mpr mpmcfg)
@@ -215,14 +227,14 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
       (pty', pde') <- case (pty,pde) of
          (Just (L loct ty), Just (L locd de)) -> do
            ty'     <- chIn loct "operation" $ do
-                         (ty,_) <- checkLType g ty typeType
+                         (ty,_) <- checkLType gc ty typeType
-                         normalForm g ty
+                         normalForm gc ty
            (de',_) <- chIn locd "operation" $
-                         checkLType g de ty'
+                         checkLType gc de ty'
            return (Just (L loct ty'), Just (L locd de'))
          (Nothing         , Just (L locd de)) -> do
            (de',ty') <- chIn locd "operation" $
-                          inferLType g de
+                          inferLType gc de
            return (Just (L locd ty'), Just (L locd de'))
          (Just (L loct ty), Nothing) -> do
            chIn loct "operation" $
@@ -230,10 +242,10 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
       update sm c (ResOper pty' pde')
 
     ResOverload os tysts -> chIn NoLoc "overloading" $ do
-      tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType g t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts  -- return explicit ones
+      tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gc t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts  -- return explicit ones
       tysts0 <- lookupOverload gr (fst sm,c)  -- check against inherited ones too
       tysts1 <- sequence
-                  [checkLType g tr (mkFunType args val) | (args,(val,tr)) <- tysts0]
+                  [checkLType gc tr (mkFunType args val) | (args,(val,tr)) <- tysts0]
       --- this can only be a partial guarantee, since matching
       --- with value type is only possible if expected type is given
       --checkUniq $
@@ -248,12 +260,13 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
     _ ->  return sm
  where
    gr = prependModule sgr sm
-   g = Gl gr (stdPredef g)
+   ga = Gl gr noPredef True
+   gc = Gl gr (stdPredef gc) False
    chIn loc cat = checkInModule cwd (snd sm) loc ("Happened in" <+> cat <+> c)
 
    mkParamValues sm         c cnt ts []           = return (sm,cnt,[],[])
    mkParamValues sm@(mn,mi) c cnt ts ((p,co):pcs) = do
-     co <- mapM (\(b,v,ty) -> normalForm g ty >>= \ty -> return (b,v,ty)) co
+     co <- mapM (\(b,v,ty) -> normalForm gc ty >>= \ty -> return (b,v,ty)) co
      sm <- case lookupIdent p (jments mi) of
              Ok (ResValue (L loc _) _) -> update sm p (ResValue (L loc (mkProdSimple co (QC (mn,c)))) cnt)
              Bad msg                   -> checkError (pp msg)
@@ -268,22 +281,6 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
       | otherwise -> checkUniq $ y:xs
      _ -> return ()
 
-   mkCheck loc cat ss = case ss of
-     [] -> return sm
-     _ -> chIn loc cat $ checkError (vcat ss)
-
-   compAbsTyp g t = case t of
-     Vr x -> maybe (checkError ("no value given to variable" <+> x)) return $ lookup x g
-     Let (x,(_,a)) b -> do
-       a' <- compAbsTyp g a
-       compAbsTyp ((x, a'):g) b
-     Prod b x a t -> do
-       a' <- compAbsTyp g a
-       t' <- compAbsTyp ((x,Vr x):g) t
-       return $ Prod b x a' t'
-     Abs _ _ _ -> return t
-     _ -> composOp (compAbsTyp g) t
-
    etaExpand xs t            []               = t
    etaExpand xs (Abs bt x t) (_        :cont) = Abs bt x (etaExpand (x:xs) t              cont)
    etaExpand xs t            ((bt,_,ty):cont) = Abs bt x (etaExpand (x:xs) (App t (Vr x)) cont)
@@ -330,4 +327,4 @@ linTypeOfType cnc m (L loc typ) = do
       lookupLincat cnc m c >>= normalForm g
      ,return defLinType
      ]
-   g = Gl cnc (stdPredef g)
+   g = Gl cnc (stdPredef g) False

src/compiler/api/GF/Compile/Compute.hs

@@ -1,23 +1,22 @@
 {-# LANGUAGE RankNTypes, BangPatterns, GeneralizedNewtypeDeriving, TupleSections #-}
 
-module GF.Compile.Compute.Concrete2
+module GF.Compile.Compute
            (Env, Scope, Value(..), Variants(..), OptionInfo(..),
-            ConstValue(..), Globals(..), PredefTable, EvalM,
+            ConstValue(..), Globals(..), PredefTable, EvalM(..),
             mapVariantsC, unvariants,
-            runEvalM, runEvalMWithInput, stdPredef, globals,
+            runEvalM, runEvalMWithInput, stdPredef, noPredef, globals,
-            PredefImpl, Predef(..), ($\),
+            PredefImpl, Predef, pdArity,
-            pdCanonicalArgs, pdArity,
             normalForm, normalFlatForm,
             eval, apply, value2term, value2termM, value2string, value2int, value2float, value2expr, string2value, bubble, patternMatch, vtableSelect, State(..),
             newResiduation, checkpoint, getMeta, setMeta, MetaState(..), variants, try,
-            evalError, evalWarn, ppValue, Choice(..), unit, poison, split, split3, split4, mapC, mapCM) where
+            evalError, evalWarn, ppValue, Choice(..), unit, split, split3, split4, mapC, mapCM) where
 
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 import GF.Infra.Ident
 import GF.Infra.CheckM
 import GF.Data.Operations(Err(..))
 import GF.Data.Utilities(maybeAt,splitAt',(<||>),anyM,secondM,bimapM)
-import GF.Grammar.Lookup(lookupResDef,lookupOrigInfo)
+import GF.Grammar.Lookup
 import GF.Grammar.Grammar
 import GF.Grammar.Macros
 import GF.Grammar.Predef
@@ -37,31 +36,20 @@ import Data.Char
 import PGF2(Expr(..),Literal(..))
 
 type PredefImpl = Globals -> Choice -> [Value] -> ConstValue Value
-newtype Predef = Predef { runPredef :: PredefImpl }
+data Predef = Predef { predefArity :: Int, predefRun :: PredefImpl }
 
-infix 1 $\
+pdArity :: Int -> PredefImpl -> Predef
-
+pdArity n def = Predef n def
-($\) :: (Predef -> Predef) -> PredefImpl -> Predef
-k $\ f = k (Predef f)
-
-pdCanonicalArgs :: Bool -> Predef -> Predef
-pdCanonicalArgs flat def = Predef $ \g c args ->
-  if all (isCanonicalForm flat) args then runPredef def g c args else RunTime
-
-pdArity :: Int -> Predef -> Predef
-pdArity n def = Predef $ \g c args ->
-  case splitAt' n args of
-    Nothing -> RunTime
-    Just (usedArgs, remArgs) ->
-      runPredef def g c usedArgs <&> \v -> apply g v remArgs
 
 type Env  = [(Ident,Value)]
 type Scope = [(Ident,Value)]
 type PredefTable = Map.Map Ident Predef
-data Globals = Gl Grammar PredefTable
+data Globals = Gl Grammar PredefTable Bool {- True for abstract, False for concrete -}
 
 data Value
-  = VApp Choice QIdent [Value]
+  = VApp QIdent [Value]           -- application of a constructor
+  | VPAP Choice QIdent [Value]    -- partially applied function
+  | VConst QIdent [Value]         -- function application that cannot be evaluated
   | VMeta {-# UNPACK #-} !MetaId [Value]
   | VSusp {-# UNPACK #-} !MetaId (Value -> Value) [Value]
   | VGen  {-# UNPACK #-} !Int [Value]
@@ -87,7 +75,7 @@ data Value
   | VFV Choice (Variants Value)
   | VAlts Value [(Value, Value)]
   | VStrs [Value]
-  | VMarkup Ident [(Ident,Value)] [Value]
+  | VMarkup Ident [(Ident,Value)] [L Value]
   | VReset Ident (Maybe Value) Value (Maybe QIdent)
   | VSymCat Int LIndex [(LIndex, (Value, Type))]
   | VError Doc
@@ -126,7 +114,7 @@ isCanonicalForm True  (VFV {})            = False
 isCanonicalForm False (VFV c vs)          = all (isCanonicalForm False) (unvariants vs)
 isCanonicalForm flat  (VAlts d vs)        = all (isCanonicalForm flat . snd) vs
 isCanonicalForm flat  (VStrs vs)          = all (isCanonicalForm flat) vs
-isCanonicalForm flat  (VMarkup tag as vs) = all (isCanonicalForm flat . snd) as && all (isCanonicalForm flat) vs
+isCanonicalForm flat  (VMarkup tag as vs) = all (isCanonicalForm flat . snd) as && all (isCanonicalForm flat . unLoc) vs
 isCanonicalForm flat  (VReset ctl cv v _) = maybe True (isCanonicalForm flat) cv && isCanonicalForm flat v
 isCanonicalForm flat  _ = False
 
@@ -186,7 +174,14 @@ eval g env s (Prod b x t1 t2)[]
   | otherwise                   = let (s1,s2) = split s
                                   in VProd b x (eval g env s1 t1 []) (VClosure env s2 t2)
 eval g env s (Typed t ty)   vs  = eval g env s t vs
-eval g env s (RecType lbls) []  = VRecType (mapC (\s (lbl,ty) -> (lbl, True, eval g env s ty [])) s lbls) False
+eval g env c (RecType rs)   []  = VRecType
+                                      (mapC (\c (lbl,deps,ty) ->
+                                                   let v = case deps of
+                                                             [] -> eval g env c ty []
+                                                             xs -> VClosure env c (foldr (Abs Explicit) ty deps)
+                                                   in (lbl,True,v))
+                                            c rs)
+                                      False
 eval g env s (R as)         []  = VR (mapC (\s (lbl,(ty,t)) -> (lbl, eval g env s t [])) s as)
 eval g env s (P t lbl)      vs  = let project (VR as)        = case lookup lbl as of
                                                                  Nothing -> VError ("Missing value for label" <+> pp lbl $$
@@ -195,6 +190,7 @@ eval g env s (P t lbl)      vs  = let project (VR as)        = case lookup lbl a
                                       project (VFV s fvs)    = VFV s (fmap project fvs)
                                       project (VMeta i vs)   = VSusp i (\v -> project (apply g v vs)) []
                                       project (VSusp i k vs) = VSusp i (\v -> project (apply g (k v) vs)) []
+                                      project (VError msg)   = VError msg
                                       project v              = VP v lbl vs
                                   in project (eval g env s t [])
 eval g env s (ExtR t1 t2)   []  = let (s1,s2) = split s
@@ -207,6 +203,8 @@ eval g env s (ExtR t1 t2)   []  = let (s1,s2) = split s
                                       extend v1             (VMeta i vs)     = VSusp i (\v -> extend v1 (apply g v vs)) []
                                       extend (VSusp i k vs) v2               = VSusp i (\v -> extend (apply g (k v) vs) v2) []
                                       extend v1             (VSusp i k vs)   = VSusp i (\v -> extend v1 (apply g (k v) vs)) []
+                                      extend (VError msg)   v2               = VError msg
+                                      extend v1             (VError msg)     = VError msg
                                       extend v1             v2               = VExtR v1 v2
 
                                   in extend (eval g env s1 t1 []) (eval g env s2 t2 [])
@@ -224,15 +222,11 @@ eval g env s (S t1 t2)      vs  = let (!s1,!s2) = split s
                                       v0 = VS v1 v2 vs
 
                                       select (VT _  env s cs) = patternMatch g s v0 (map (\(p,t) -> (env,[p],v2:vs,t)) cs)
-                                      select (VV vty tvs)     = case value2termM False (map fst env) vty of
+                                      select (VV vty tvs)     = vtableSelect g v0 vty tvs v2 vs
-                                                                  EvalM f -> case f g (\x state xs ws -> Success (x:xs) ws) empty [] [] of
-                                                                               Fail   msg  ws -> VError msg
-                                                                               Success tys ws -> case tys of
-                                                                                                   [ty] -> vtableSelect g v0 ty tvs v2 vs
-                                                                                                   tys  -> vtableSelect g v0 (FV (reverse tys)) tvs v2 vs
                                       select (VFV i fvs)      = VFV i (fmap select fvs)
                                       select (VMeta i vs)     = VSusp i (\v -> select (apply g v vs)) []
                                       select (VSusp i k vs)   = VSusp i (\v -> select (apply g (k v) vs)) []
+                                      select (VError msg)     = VError msg
                                       select v1               = v0
                                           
                                       -- FIXME: options=[] is definitely not correct and this shouldn't be using value2termM at all
@@ -243,12 +237,13 @@ eval g env s (Let (x,(_,t1)) t2) vs = let (!s1,!s2) = split s
                                       in eval g ((x,eval g env s1 t1 []):env) s2 t2 vs
 eval g env c (Q q@(m,id))  vs
   | m == cPredef              = evalPredef g c id vs
+  | isAbstract                = evalAbsDef g c q  vs
   | otherwise                 = case lookupResDef gr q of
-                                  Ok t    -> eval g env c t vs
+                                  Ok t    -> eval g [] c t vs
                                   Bad msg -> error msg
   where
-    Gl gr predef = g
+    Gl gr predef isAbstract = g
-eval g env s (QC q)         vs  = VApp s q vs
+eval g env c (QC q)         vs  = VApp q vs
 eval g env s (C t1 t2)      []  = let (!s1,!s2) = split s
 
                                       concat v1           VEmpty = v1
@@ -259,6 +254,8 @@ eval g env s (C t1 t2)      []  = let (!s1,!s2) = split s
                                       concat v1     (VMeta i vs) = VSusp i (\v -> concat v1 (apply g v vs)) []
                                       concat (VSusp i k vs)   v2 = VSusp i (\v -> concat (apply g (k v) vs) v2) []
                                       concat v1   (VSusp i k vs) = VSusp i (\v -> concat v1 (apply g (k v) vs)) []
+                                      concat (VError msg)     v2 = VError msg
+                                      concat v1     (VError msg) = VError msg
                                       concat v1               v2 = VC v1 v2
 
                                   in concat (eval g env s1 t1 []) (eval g env s2 t2 [])
@@ -266,12 +263,12 @@ eval g env s (Glue t1 t2)   []  = let (!s1,!s2) = split s
 
                                       glue VEmpty        v             = v
                                       glue (VC v1 v2)    v             = VC v1 (glue v2 v)
-                                      glue (VApp c q []) v
+                                      glue (VApp q [])   v
-                                        | q == (cPredef,cNonExist)     = VApp c q []
+                                        | q == (cPredef,cNonExist)     = VApp q []
                                       glue v             VEmpty        = v
                                       glue v             (VC v1 v2)    = VC (glue v v1) v2
-                                      glue v             (VApp c q [])
+                                      glue v             (VApp q [])
-                                        | q == (cPredef,cNonExist)     = VApp c q []
+                                        | q == (cPredef,cNonExist)     = VApp q []
                                       glue (VStr s1)     (VStr s2)     = VStr (s1++s2)
                                       glue v             (VAlts d vas) = VAlts (glue v d) [(glue v v',ss) | (v',ss) <- vas]
                                       glue (VAlts d vas) (VStr s)      = pre d vas s
@@ -282,6 +279,8 @@ eval g env s (Glue t1 t2)   []  = let (!s1,!s2) = split s
                                       glue v1            (VMeta i vs)  = VSusp i (\v -> glue v1 (apply g v vs)) []
                                       glue (VSusp i k vs) v2           = VSusp i (\v -> glue (apply g (k v) vs) v2) []
                                       glue v1            (VSusp i k vs)= VSusp i (\v -> glue v1 (apply g (k v) vs)) []
+                                      glue (VError msg)  v2            = VError msg
+                                      glue v1            (VError msg)  = VError msg
                                       glue v1            v2            = VGlue v1 v2
 
                                       pre vd []                 s              = glue vd (VStr s)
@@ -294,7 +293,7 @@ eval g env s (EPatt min max p) [] = VPatt min max p
 eval g env s (EPattType t)  []  = VPattType (eval g env s t [])
 eval g env s (ELincat c ty) []  = let lbl = lockLabel c
                                       lty = RecType []
-                                  in eval g env s (ExtR ty (RecType [(lbl,lty)])) []
+                                  in eval g env s (ExtR ty (RecType [(lbl,[],lty)])) []
 eval g env s (ELin c t)     []  = let lbl = lockLabel c
                                       lt  = R []
                                   in eval g env s (ExtR t (R [(lbl,(Nothing,lt))])) []
@@ -308,7 +307,7 @@ eval g env c (Strs ts)      []  = VStrs (mapC (\c t -> eval g env c t []) c ts)
 eval g env c (Markup tag as ts) [] =
                               let (c1,c2) = split c
                                   vas = mapC (\c (id,t) -> (id,eval g env c t [])) c1 as
-                                  vs  = mapC (\c t -> eval g env c t []) c2 ts
+                                  vs  = mapC (\c (L loc t) -> L loc (eval g env c t [])) c2 ts
                               in (VMarkup tag vas vs)
 eval g env c (Reset ctl mb_ct t qid) [] = VReset ctl (fmap (\t -> eval g env c t []) mb_ct) (eval g env c t []) qid
 eval g env c (TSymCat d r rs) []= VSymCat d r [(i,(fromJust (lookup pv env),ty)) | (i,(pv,ty)) <- rs]
@@ -320,51 +319,71 @@ eval g env c t@(Opts n cs)  vs  = if null cs
                                        in VFV c3 (VarOpts vn vcs)
   where evalOpt c' (Just l, t) = let (c1,c2) = split c' in (eval g env c1 l [], eval g env c2 t vs)
         evalOpt c' (Nothing,t) = let v = eval g env c' t vs in (v, v)
-eval g env c t              vs  = VError ("Cannot reduce term" <+> pp t)
+eval g env c t              vs = VError ("Cannot reduce term" <+> pp t)
 
 evalPredef :: Globals -> Choice -> Ident -> [Value] -> Value
-evalPredef g@(Gl gr pds) c n args =
+evalPredef g@(Gl gr pds _) c n args =
   case Map.lookup n pds of
-    Nothing  -> VApp c (cPredef,n) args
+    Nothing             -> VApp (cPredef,n) args
-    Just def -> let valueOf (Const res) = res
+    Just (Predef k def) -> case splitAt' k args of
-                    valueOf (CFV i vs)  = VFV i (fmap valueOf vs)
+                             Nothing -> VPAP c (cPredef,n) args
-                    valueOf (CSusp i k) = VSusp i (valueOf . k) []
+                             Just (usedArgs, remArgs) ->
-                    valueOf RunTime     = VApp c (cPredef,n) args
+                                apply g (valueOf (def g c usedArgs)) remArgs
-                    valueOf NonExist    = VApp c (cPredef,cNonExist) []
+  where
-                in valueOf (runPredef def g c args)
+    valueOf (Const res) = res
+    valueOf (CFV i vs)  = VFV i (fmap valueOf vs)
+    valueOf (CSusp i k) = VSusp i (valueOf . k) []
+    valueOf RunTime     = VConst (cPredef,n) args
+    valueOf NonExist    = VApp (cPredef,cNonExist) []
+
+noPredef :: PredefTable
+noPredef = Map.empty
 
 stdPredef :: Globals -> PredefTable
 stdPredef g = Map.fromList
-  [(cInts,   pdArity 1 $\ \g c vs -> Const (case vs of {[VInt i] -> VInts i False; vs -> VApp c (cPredef,cInts) vs}))
+  [(cInts,   pdArity 1 $ \g c vs -> Const (case vs of {[VInt i] -> VInts i False; vs -> VApp (cPredef,cInts) vs}))
-  ,(cLength, pdArity 1 $\ \g c [v] -> fmap (VInt . genericLength) (value2string g v))
+  ,(cLength, pdArity 1 $ \g c [v] -> fmap (VInt . genericLength) (value2string g v))
-  ,(cTake,   pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericTake (value2int g v1) (value2string g v2)))
+  ,(cTake,   pdArity 2 $ \g c [v1,v2] -> fmap string2value (liftA2 genericTake (value2int g v1) (value2string g v2)))
-  ,(cDrop,   pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericDrop (value2int g v1) (value2string g v2)))
+  ,(cDrop,   pdArity 2 $ \g c [v1,v2] -> fmap string2value (liftA2 genericDrop (value2int g v1) (value2string g v2)))
-  ,(cTk,     pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericTk (value2int g v1) (value2string g v2)))
+  ,(cTk,     pdArity 2 $ \g c [v1,v2] -> fmap string2value (liftA2 genericTk (value2int g v1) (value2string g v2)))
-  ,(cDp,     pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericDp (value2int g v1) (value2string g v2)))
+  ,(cDp,     pdArity 2 $ \g c [v1,v2] -> fmap string2value (liftA2 genericDp (value2int g v1) (value2string g v2)))
-  ,(cIsUpper,pdArity 1 $\ \g c [v]     -> fmap toPBool (liftA (all isUpper) (value2string g v)))
+  ,(cIsUpper,pdArity 1 $ \g c [v]     -> fmap toPBool (liftA (all isUpper) (value2string g v)))
-  ,(cToUpper,pdArity 1 $\ \g c [v]     -> fmap string2value (liftA (map toUpper) (value2string g v)))
+  ,(cToUpper,pdArity 1 $ \g c [v]     -> fmap string2value (liftA (map toUpper) (value2string g v)))
-  ,(cToLower,pdArity 1 $\ \g c [v]     -> fmap string2value (liftA (map toLower) (value2string g v)))
+  ,(cToLower,pdArity 1 $ \g c [v]     -> fmap string2value (liftA (map toLower) (value2string g v)))
-  ,(cEqStr,  pdArity 2 $\ \g c [v1,v2] -> fmap toPBool (liftA2 (==) (value2string g v1) (value2string g v2)))
+  ,(cEqStr,  pdArity 2 $ \g c [v1,v2] -> fmap toPBool (liftA2 (==) (value2string g v1) (value2string g v2)))
-  ,(cOccur,  pdArity 2 $\ \g c [v1,v2] -> fmap toPBool (liftA2 occur (value2string g v1) (value2string g v2)))
+  ,(cOccur,  pdArity 2 $ \g c [v1,v2] -> fmap toPBool (liftA2 occur (value2string g v1) (value2string g v2)))
-  ,(cOccurs, pdArity 2 $\ \g c [v1,v2] -> fmap toPBool (liftA2 occurs (value2string g v1) (value2string g v2)))
+  ,(cOccurs, pdArity 2 $ \g c [v1,v2] -> fmap toPBool (liftA2 occurs (value2string g v1) (value2string g v2)))
-  ,(cEqInt,  pdArity 2 $\ \g c [v1,v2] -> fmap toPBool (liftA2 (==) (value2int g v1) (value2int g v2)))
+  ,(cEqInt,  pdArity 2 $ \g c [v1,v2] -> fmap toPBool (liftA2 (==) (value2int g v1) (value2int g v2)))
-  ,(cLessInt,pdArity 2 $\ \g c [v1,v2] -> fmap toPBool (liftA2 (<) (value2int g v1) (value2int g v2)))
+  ,(cLessInt,pdArity 2 $ \g c [v1,v2] -> fmap toPBool (liftA2 (<) (value2int g v1) (value2int g v2)))
-  ,(cPlus,   pdArity 2 $\ \g c [v1,v2] -> fmap VInt (liftA2 (+) (value2int g v1) (value2int g v2)))
+  ,(cPlus,   pdArity 2 $ \g c [v1,v2] -> fmap VInt (liftA2 (+) (value2int g v1) (value2int g v2)))
-  ,(cError,  pdArity 1 $\ \g c [v]     -> fmap (VError . pp) (value2string g v))
+  ,(cError,  pdArity 1 $ \g c [v]     -> fmap (VError . pp) (value2string g v))
   ]
   where
     genericTk n = reverse . genericDrop n . reverse
     genericDp n = reverse . genericTake n . reverse
 
+evalAbsDef :: Globals -> Choice -> QIdent -> [Value] -> Value
+evalAbsDef g@(Gl gr pds _) c q args =
+  case lookupAbsDef gr q of
+    Ok (Just (arity,eqs)) ->
+      case splitAt' arity args of
+        Nothing -> VPAP c q args
+        Just (_,_) -> patternMatch g c (VConst q args) (map (\(ps,t) -> ([],ps,args,t)) eqs)
+    Ok Nothing -> VApp q args
+    Bad msg -> error msg
+
 apply g (VMeta i vs0)                   vs  = VMeta i   (vs0++vs)
 apply g (VSusp i k vs0)                 vs  = VSusp i k (vs0++vs)
-apply g (VApp c f@(m,n)  vs0)           vs
+apply g (VApp f vs0)                    vs  = VApp f (vs0++vs)
+apply g (VPAP c q@(m,n) vs0)            vs
   | m == cPredef                            = evalPredef g c n (vs0++vs)
-  | otherwise                               = VApp c f (vs0++vs)
+  | otherwise                               = evalAbsDef g c q (vs0++vs)
-apply g (VGen i  vs0)                   vs  = VGen i (vs0++vs)
+apply g (VConst f vs0)                  vs  = VConst f (vs0++vs)
+apply g (VGen i vs0)                    vs  = VGen i (vs0++vs)
 apply g (VFV i fvs)                     vs  = VFV i (fmap (\v -> apply g v vs) fvs)
 apply g (VS v1 v2 vs')                  vs  = VS v1 v2 (vs'++vs)
 apply g (VClosure env s (Abs b x t)) (v:vs) = eval g ((x,v):env) s t vs
+apply g (VError msg)                    _   = VError msg
 apply g v                               []  = v
 
 data BubbleVariants
@@ -373,7 +392,9 @@ data BubbleVariants
 
 bubble v = snd (bubble v)
   where
-    bubble (VApp c f vs) = liftL (VApp c f) vs
+    bubble (VApp f vs) = liftL (VApp f) vs
+    bubble (VPAP c f vs) = liftL (VPAP c f) vs
+    bubble (VConst f vs) = liftL (VConst f) vs
     bubble (VMeta metaid vs) = liftL (VMeta metaid) vs
     bubble (VSusp metaid k vs) = liftL (VSusp metaid k) vs
     bubble (VGen i vs) = liftL (VGen i) vs
@@ -410,7 +431,7 @@ bubble v = snd (bubble v)
     bubble (VStrs vs) = liftL VStrs vs
     bubble (VMarkup tag attrs vs) =
       let (union1,attrs') = mapAccumL descend' Map.empty attrs
-          (union2,vs')    = mapAccumL descend  union1 vs
+          (union2,vs')    = mapAccumL descendL union1 vs
       in (union2, VMarkup tag attrs' vs')
     bubble (VReset ctl mb_cv v id) =
       let (union,v') = bubble v
@@ -481,6 +502,10 @@ bubble v = snd (bubble v)
       let (choices,v') = bubble v
       in (mergeChoices1 union choices,(i,(v',ty)))
 
+    descendL union (L loc v) =
+      let (choices,v') = bubble v
+      in (mergeChoices1 union choices,L loc v')
+
     descendR union (l,b,v) =
       let (choices,v') = bubble v
       in (mergeChoices1 union choices,(l,b,v'))
@@ -497,8 +522,8 @@ bubble v = snd (bubble v)
     mergeChoices1 = Map.mergeWithKey (\c (n,cnt) _ -> Just (n,cnt+1)) id unitfy
     mergeChoices2 = Map.mergeWithKey (\c (n,cnt) _ -> Just (n,2)) unitfy unitfy
 
-toPBool True  = VApp poison (cPredef,cPTrue)  []
+toPBool True  = VApp (cPredef,cPTrue)  []
-toPBool False = VApp poison (cPredef,cPFalse) []
+toPBool False = VApp (cPredef,cPFalse) []
 
 occur s1 []          = False
 occur s1 s2@(_:tail) = check s1 s2
@@ -534,20 +559,25 @@ patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
                                                                                         (pp t))
                                                  Bad msg -> error msg
                                                where
-                                                 Gl gr _ = g
+                                                 Gl gr _ _ = g
-    match env (PV v      :ps) eqs (arg:args) = match ((v,arg):env) ps eqs args
+    match env (PV v      :ps) eqs (arg:args)
+      | v == identW                          = match          env  ps eqs args
+      | otherwise                            = match ((v,arg):env) ps eqs args
     match env (PAs v p   :ps) eqs (arg:args) = match ((v,arg):env) (p:ps) eqs (arg:args)
-    match env (PW        :ps) eqs (arg:args) = match env ps eqs args
     match env (PTilde _  :ps) eqs (arg:args) = match env ps eqs args
     match env (p         :ps) eqs (arg:args) = match' env p ps eqs arg args
 
     match' env p ps eqs arg args =
       case (p,arg) of
+        (p,       VConst q  vs) -> v0
         (p,       VMeta i   vs) -> VSusp i (\v -> match' env p ps eqs (apply g v vs) args) []
         (p,       VGen  i   vs) -> v0
         (p,       VSusp i k vs) -> VSusp i (\v -> match' env p ps eqs (apply g (k v) vs) args) []
         (p,           VFV s vs) -> VFV s (fmap (\arg -> match' env p ps eqs arg args) vs)
-        (PP q qs,  VApp c r vs)
+        (p,           VP _ _ _) -> v0
+        (p,           VS _ _ _) -> v0
+        (p,      VSymCat _ _ _) -> v0
+        (PP q qs, VApp r    vs)
           | q == r              -> match env (qs++ps) eqs (vs++args)
         (PR pas,  VR as)        -> matchRec env (reverse pas) as ps eqs args
         (PString s1, VStr s2)
@@ -555,24 +585,27 @@ patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
         (PString s1, VEmpty)
           | null s1             -> match env ps eqs args
         (PSeq min1 max1 p1 min2 max2 p2,v)
-                          -> case value2string g v of
+                    -> let match_seq (Const str) = let n  = length str
-                               Const str -> let n  = length str
+                                                       lo = min1 `max` (n-fromMaybe n max2)
-                                                lo = min1 `max` (n-fromMaybe n max2)
+                                                       hi = (n-min2) `min` fromMaybe n max1
-                                                hi = (n-min2) `min` fromMaybe n max1
+                                                       (ds,cs) = splitAt lo str
-                                                (ds,cs) = splitAt lo str
 
-                                                eqs' = matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args
+                                                       eqs' = matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args
-
+                                                   in patternMatch g s v0 eqs'
-                                            in patternMatch g s v0 eqs'
+                           match_seq (CSusp i k) = VSusp i (match_seq . k) []
-                               RunTime   -> v0
+                           match_seq (CFV c vs)  = VFV c (fmap match_seq vs)
-                               NonExist  -> patternMatch g s v0 eqs
+                           match_seq RunTime     = v0
+                           match_seq NonExist    = patternMatch g s v0 eqs
+                       in match_seq (value2string g v)
         (PRep minp maxp p, v)
-                          -> case value2string g v of
+                    -> let match_rep (Const str) = let n = length (str::String) `div` (max minp 1)
-                               Const str -> let n = length (str::String) `div` (max minp 1)
+                                                       eqs' = matchRep env n minp maxp p minp maxp p ps ((env,PString []:ps,(arg:args),t) : eqs) (arg:args)
-                                                eqs' = matchRep env n minp maxp p minp maxp p ps ((env,PString []:ps,(arg:args),t) : eqs) (arg:args)
+                                                   in patternMatch g s v0 eqs'
-                                            in patternMatch g s v0 eqs'
+                           match_rep (CSusp i k) = VSusp i (match_rep . k) []
-                               RunTime   -> v0
+                           match_rep (CFV c vs)  = VFV c (fmap match_rep vs)
-                               NonExist  -> patternMatch g s v0 eqs
+                           match_rep RunTime     = v0
+                           match_rep NonExist    = patternMatch g s v0 eqs
+                       in match_rep (value2string g v)
         (PChar, VStr [_]) -> match env ps eqs args
         (PChars cs, VStr [c])
           | elem c cs     -> match env ps eqs args
@@ -608,19 +641,19 @@ vtableSelect g v0 ty cs v2 vs =
     select (CFV c vs)    = VFV c (fmap select vs)
     select _             = v0
 
-    value2index (VMeta i vs)      ty = CSusp i (\v -> value2index (apply g v vs) ty)
+    value2index (VMeta i vs)      vty = CSusp i (\v -> value2index (apply g v vs) vty)
-    value2index (VSusp i k vs)    ty = CSusp i (\v -> value2index (apply g (k v) vs) ty)
+    value2index (VSusp i k vs)    vty = CSusp i (\v -> value2index (apply g (k v) vs) vty)
-    value2index (VR as) (RecType lbls) = compute lbls
+    value2index (VR as) (VRecType lbls _) = compute lbls
       where
-        compute []              = pure (0,1)
+        compute []                 = pure (0,1)
-        compute ((lbl,ty):lbls) =
+        compute ((lbl,_,vty):lbls) =
           case lookup lbl as of
             Just v  -> liftA2 (\(r, cnt) (r',cnt') -> (r*cnt'+r',cnt*cnt'))
-                              (value2index v ty)
+                              (value2index v vty)
                               (compute lbls)
             Nothing -> error (show ("Missing value for label" <+> pp lbl $$
                                     "among" <+> hsep (punctuate (pp ',') (map fst as))))
-    value2index (VApp c q args) ty =
+    value2index (VApp q args) vty =
       let (r ,ctxt,cnt ) = getIdxCnt q
       in fmap (\(r', cnt') -> (r+r',cnt)) (compute ctxt args)
       where
@@ -633,7 +666,7 @@ vtableSelect g v0 ty cs v2 vs =
         compute []              []     = pure (0,1)
         compute ((_,_,ty):ctxt) (v:vs) =
           liftA2 (\(r, cnt) (r',cnt') -> (r*cnt'+r',cnt*cnt'))
-                 (value2index v ty)
+                 (value2index v (eval g [] unit ty []))
                  (compute ctxt vs)
 
         getInfo :: QIdent -> (ModuleName,Info)
@@ -642,11 +675,11 @@ vtableSelect g v0 ty cs v2 vs =
             Ok res  -> res
             Bad msg -> error msg
 
-        Gl gr _ = g
+        Gl gr _ _ = g
-    value2index (VInt n)          ty
+    value2index (VInt n) (VApp c [VInt max])
-      | Just max <- isTypeInts ty    = Const (fromIntegral n,fromIntegral max+1)
+      | Q c == cnPredef cInts         = Const (fromIntegral n,fromIntegral max+1)
-    value2index (VFV c vs)        ty = CFV c (fmap (\v -> value2index v ty) vs)
+    value2index (VFV c vs)        vty = CFV c (fmap (\v -> value2index v vty) vs)
-    value2index v ty = RunTime
+    value2index v vty = RunTime
 
 
 value2term :: Globals -> [Ident] -> Value -> Check Term
@@ -658,7 +691,7 @@ value2term g xs v = do
 
 data MetaState
   = Bound Scope Value
-  | Narrowing   Type
+  | Narrowing   Choice Type
   | Residuation Scope
 data OptionInfo
   = OptionInfo
@@ -805,8 +838,12 @@ setMeta i ms = EvalM (\g k (State input choices metas opts) r msgs ->
   in k () state' r msgs)
 
 value2termM :: Bool -> [Ident] -> Value -> EvalM Term
-value2termM flat xs (VApp c q vs) =
+value2termM flat xs (VApp q vs) =
-  foldM (\t v -> fmap (App t) (value2termM flat xs v)) (if fst q == cPredef then Q q else QC q) vs
+  vapp2termM flat xs q (QC q) vs
+value2termM flat xs (VPAP _ q vs) =
+  vapp2termM flat xs q (Q q) vs
+value2termM flat xs (VConst q vs) =
+  vapp2termM flat xs q (Q q) vs
 value2termM flat xs (VMeta i vs) = do
   mv <- getMeta i
   case mv of
@@ -835,9 +872,16 @@ value2termM flat xs (VProd b x v1 v2) = do
   t1 <- value2termM flat xs v1
   t2 <- value2termM flat xs v2
   return (Prod b x t1 t2)
-value2termM flat xs (VRecType lbls _) = do
+value2termM flat xs (VRecType lbls ext) = do
-  lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
+  g <- globals
+  lbls <- mapM (\(lbl,_,v) -> uncover g lbl xs v) lbls
   return (RecType lbls)
+  where
+    uncover g lbl xs (VClosure env c (Abs b x t)) = do (lbl,deps,t) <- uncover g lbl (x:xs) (VClosure ((x,VGen (length xs) []):env) c t)
+                                                       return (lbl,x:deps,t)
+    uncover g lbl xs (VClosure env c t)           = fmap ((,,) lbl []) (value2termM flat xs (eval g env c t []))
+    uncover g lbl xs v                            = fmap ((,,) lbl []) (value2termM flat xs v)
+
 value2termM flat xs (VR as) = do
   as <- mapM (\(lbl,v) -> fmap (\t -> (lbl,(Nothing,t))) (value2termM flat xs v)) as
   return (R as)
@@ -934,7 +978,7 @@ value2termM flat xs (VStrs vs) = do
   return (Strs ts)
 value2termM flat xs (VMarkup tag as vs) = do
   as <- mapM (\(id,v) -> value2termM flat xs v >>= \t -> return (id,t)) as
-  ts <- mapM (value2termM flat xs) vs
+  ts <- mapM (mapM (value2termM flat xs)) vs
   return (Markup tag as ts)
 value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
   ts <- reset (value2termM True xs v)
@@ -948,7 +992,7 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
                  _             -> evalError (pp "[concat: .. | ..] requires an integer constant")
          case ts of
            [t] -> return t
-           ts  -> return (Markup identW [] ts)
+           ts  -> return (Markup identW [] (map noLoc ts))
       | ctl == cConcat' = do
          ts <- case mb_cv of
                  Just (VInt n) -> return (genericTake n ts)
@@ -957,7 +1001,7 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
          case ts of
            []  -> mzero
            [t] -> return t
-           ts  -> return (Markup identW [] ts)
+           ts  -> return (Markup identW [] (map noLoc ts))
       | ctl == cOne =
          case (ts,mb_cv) of
            ([]  ,Nothing) -> mzero
@@ -979,6 +1023,16 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
                                _    -> evalError (pp "The term must be a record")
                            select n (t:ts) = select (n-1) ts
            _             -> evalError (pp "[select: .. | ..] requires an integer constant")
+      | ctl == cFilter =
+          let filter []     = mzero
+              filter (t:ts) =
+                case t of
+                  R rs -> case (lookup (ident2label cp1) rs, lookup (ident2label cp2) rs) of
+                            (Just (_,t), Just (_,Q q))
+                                | q == (cPredef,cTrue) -> pure t `mplus` filter ts
+                            _                          ->                filter ts
+                  _    -> evalError (pp "The term must be a record")
+          in filter ts
       | ctl == cDefault =
          case (ts,mb_cv) of
            ([]  ,Nothing) -> mzero
@@ -1000,6 +1054,11 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
            Just cv  -> do g <- globals
                           value2termM True xs (apply g cv [VInt (genericLength ts)])
            Nothing  -> return (EInt (genericLength ts))
+      | ctl == cConst =
+          case mb_cv of
+            Just cv -> do ct <- value2termM flat xs cv
+                          msum (map (pure . const ct) ts)
+            _       -> evalError (pp "[const: .. | ..] requires an argument")
       | otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
 
     listify mn cat [t1,t2] = do return (App (App (QC (mn,identS ("Base"++cat))) t1) t2)
@@ -1014,6 +1073,18 @@ value2termM flat xs (VError msg) = evalError msg
 value2termM flat xs (VInts n _) = return (App (Q (cPredef,cInts)) (EInt n))
 value2termM flat xs v = evalError ("value2termM" <+> ppValue Unqualified 5 v)
 
+vapp2termM flat xs q t vs = do
+  g@(Gl gr _ isAbstract) <- globals
+  case (if isAbstract then fmap snd (lookupAbsType gr q) else lookupResType gr q) of
+    Bad msg -> evalError (pp msg)
+    Ok ty   -> do (t,_) <- foldM app (t,ty) vs
+                  return t
+  where
+    app (t,Prod bt _ _ ty) v = do
+      arg <- value2termM flat xs v
+      case bt of
+        Explicit -> return (App t arg,ty)
+        Implicit -> return (App t (ImplArg arg),ty)
 
 pattVars st (PP _ ps)    = foldl pattVars st ps
 pattVars st (PV x)       = case st of
@@ -1028,10 +1099,23 @@ pattVars st _            = st
 
 
 
-ppValue q d (VApp c f vs) = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) vs))
+ppValue q d (VApp f vs)
-ppValue q d (VMeta i vs) = prec d 4 (hsep ((if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs))
+  | null vs   = ppQIdent q f
+  | otherwise = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) vs))
+ppValue q d (VPAP _ f vs)
+  | null vs   = ppQIdent q f
+  | otherwise = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) vs))
+ppValue q d (VConst f vs)
+  | null vs   = ppQIdent q f
+  | otherwise = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) vs))
+ppValue q d (VMeta i vs)
+  | null vs   = meta
+  | otherwise = prec d 4 (hsep (meta : map (ppValue q 5) vs))
+  where
+    meta | i > 0     = pp "?" <> pp i
+         | otherwise = pp "?"
 ppValue q d (VSusp i k vs) = prec d 4 (hsep (pp "#susp" : (if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs))
-ppValue q d (VGen _ _) = pp "VGen"
+ppValue q d (VGen i vs) = prec d 4 (hsep (pp "#gen" : pp i : map (ppValue q 5) vs))
 ppValue q d (VClosure env c t) = pp "[|" <> ppTerm q 4 t <> pp "|]"
 ppValue q d (VProd bt x a b) =
   if x == identW && bt == Explicit
@@ -1043,8 +1127,9 @@ ppValue q d (VRecType xs ext)
                            _     -> doc
   | otherwise          = doc
   where
-    doc = braces (fsep (punctuate ';' ([l <+> (if o then ":" else ":?") <+> ppValue q 0 v | (l,o,v) <- xs] ++ [pp ".." | ext])))
+    doc  = braces (fsep (punctuate ';' ([l <+> (if o then ":" else ":?") <+> ppValue q 0 v | (l,o,v) <- xs] ++ [pp ".." | ext])))
-ppValue q d (VR _) = pp "VR"
+ppValue q d (VR [])     = pp "<>" -- to distinguish from {} empty RecType
+ppValue q d (VR xs)     = braces (fsep (punctuate ';' [l <+> '=' <+> ppValue q 0 v | (l,v) <- xs]))
 ppValue q d (VP v l vs) = prec d 5 (hsep (ppValue q 5 v <> '.' <> l : map (ppValue q 5) vs))
 ppValue q d (VExtR _ _) = pp "VExtR"
 ppValue q d (VTable kt vt) = prec d 0 (ppValue q 3 kt <+> "=>" <+> ppValue q 0 vt)
@@ -1096,24 +1181,24 @@ value2string' g (VC v1 v2)       b ws      qs = concat v1 (value2string' g v2 b
     concat v1 (Const (b,ws,qs)) = value2string' g v1 b ws qs
     concat v1 (CFV c vs)        = CFV c (fmap (concat v1) vs)
     concat v1 res               = res
-value2string' g (VApp c q []) b   ws     qs
+value2string' g (VApp q [])   b   ws     qs
   | q == (cPredef,cNonExist)              = NonExist
-value2string' g (VApp c q []) b   ws     qs
+value2string' g (VApp q [])   b   ws     qs
   | q == (cPredef,cSOFT_SPACE)            = if null ws
                                               then Const (b,ws,q:qs)
                                               else Const (b,ws,qs)
-value2string' g (VApp c q []) b   ws     qs
+value2string' g (VApp q [])   b   ws     qs
   | q == (cPredef,cBIND) || q == (cPredef,cSOFT_BIND) 
                                           = if null ws
                                               then Const (True,ws,q:qs)
                                               else Const (True,ws,qs)
-value2string' g (VApp c q []) b   ws     qs
+value2string' g (VApp q [])   b   ws     qs
   | q == (cPredef,cCAPIT) = capit ws
   where
     capit []            = Const (b,[],q:qs)
     capit ((c:cs) : ws) = Const (b,(toUpper c : cs) : ws,qs)
     capit ws            = Const (b,ws,qs)
-value2string' g (VApp c q []) b   ws     qs
+value2string' g (VApp q [])   b   ws     qs
   | q == (cPredef,cALL_CAPIT) = all_capit ws
   where
     all_capit []       = Const (b,[],q:qs)
@@ -1154,7 +1239,7 @@ value2float g (VFlt f)         = Const f
 value2float g (VFV s vs)       = CFV s (fmap (value2float g) vs)
 value2float g _                = RunTime
 
-value2expr g xs (VApp _ (m,f) vs)
+value2expr g xs (VApp (m,f) vs)
   | m /= cPredef               = foldl (\e v -> fmap EApp e <*> value2expr g xs v) (pure (EFun (showIdent f))) vs
 value2expr g xs (VMeta i vs)   = CSusp i (\v -> value2expr g xs (apply g v vs))
 value2expr g xs (VSusp i k vs) = CSusp i (\v -> value2expr g xs (apply g (k v) vs))
@@ -1174,9 +1259,6 @@ newtype Choice = Choice { unchoice :: Integer }
 unit :: Choice
 unit = Choice 1
 
-poison :: Choice
-poison = Choice (-1)
-
 split :: Choice -> (Choice,Choice)
 split (Choice c) = (Choice (2*c), Choice (2*c+1))
 

src/compiler/api/GF/Compile/Compute/Abstract.hs

@@ -1,138 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : GF.Compile.Abstract.Compute
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/10/02 20:50:19 $ 
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.8 $
---
--- computation in abstract syntax w.r.t. explicit definitions.
---
--- old GF computation; to be updated
------------------------------------------------------------------------------
-
-module GF.Compile.Compute.Abstract (LookDef,
-		   compute, 
-		   computeAbsTerm, 
-		   computeAbsTermIn, 
-		   beta
-		  ) where
-
-import GF.Data.Operations
-
-import GF.Grammar
-import GF.Grammar.Lookup
-
-import Debug.Trace
-import Data.List(intersperse)
-import Control.Monad (liftM, liftM2)
-import GF.Text.Pretty
-
--- for debugging
-tracd m t = t 
--- tracd = trace
-
-compute :: SourceGrammar -> Term -> Err Term
-compute = computeAbsTerm
-
-computeAbsTerm :: SourceGrammar -> Term -> Err Term
-computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) []
-
--- | a hack to make compute work on source grammar as well
-type LookDef = Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
-
-computeAbsTermIn :: LookDef -> [Ident] -> Term -> Err Term
-computeAbsTermIn lookd xs e = errIn (render (text "computing" <+> ppTerm Unqualified 0 e)) $ compt xs e where
-  compt vv t = case t of
---    Prod x a b  -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b)
---    Abs x b     -> liftM  (Abs  x)              (compt (x:vv) b)
-    _ -> do
-      let t' = beta vv t
-      (yy,f,aa) <- termForm t'
-      let vv' = map snd yy ++ vv
-      aa'    <- mapM (compt vv') aa
-      case look f of
-        Just eqs -> tracd (text "\nmatching" <+> ppTerm Unqualified 0 f) $ 
-                          case findMatch eqs aa' of
-          Ok (d,g) -> do
-            --- let (xs,ts) = unzip g
-            --- ts' <- alphaFreshAll vv' ts
-            let g' = g --- zip xs ts'
-            d' <- compt vv' $ substTerm vv' g' d
-            tracd (text "by Egs:" <+> ppTerm Unqualified 0 d') $ return $ mkAbs yy $ d'
-          _ -> tracd (text "no match" <+> ppTerm Unqualified 0 t') $ 
-               do
-            let v = mkApp f aa'
-            return $ mkAbs yy $ v
-        _ -> do
-          let t2 = mkAbs yy $ mkApp f aa'
-          tracd (text "not defined" <+> ppTerm Unqualified 0 t2) $ return t2
-
-  look t = case t of
-     (Q (m,f)) -> case lookd m f of
-       Ok (_,md) -> md
-       _ -> Nothing
-     _ -> Nothing
-
-beta :: [Ident] -> Exp -> Exp
-beta vv c = case c of
-  Let (x,(_,a)) b -> beta vv $ substTerm vv [(x,beta vv a)] (beta (x:vv) b) 
-  App f         a -> 
-    let (a',f') = (beta vv a, beta vv f) in 
-    case f' of
-      Abs _ x b -> beta vv $ substTerm vv [(x,a')] (beta (x:vv) b) 
-      _ ->               (if a'==a && f'==f then id else beta vv) $ App f' a'
-  Prod b x a t      -> Prod b x (beta vv a) (beta (x:vv) t)
-  Abs b x t       -> Abs b x (beta (x:vv) t)
-  _               -> c
-
--- special version of pattern matching, to deal with comp under lambda
-
-findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
-findMatch cases terms = case cases of
-  [] -> Bad $ render (text "no applicable case for" <+> hcat (punctuate comma (map (ppTerm Unqualified 0) terms)))
-  (patts,_):_ | length patts /= length terms -> 
-       Bad (render (text "wrong number of args for patterns :" <+> 
-                    hsep (map (ppPatt Unqualified 0) patts) <+> text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms)))
-  (patts,val):cc -> case mapM tryMatch (zip patts terms) of
-     Ok substs -> return (tracd (text "value" <+> ppTerm Unqualified 0 val) val, concat substs)
-     _         -> findMatch cc terms
-
-tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
-tryMatch (p,t) = do 
-  t' <- termForm t
-  trym p t'
- where
-
-  trym p t' = err (\s -> tracd s (Bad s)) (\t -> tracd (prtm p t) (return t)) $ ---- 
-              case (p,t') of
-    (PW,    _) | notMeta t -> return [] -- optimization with wildcard
-    (PV x,  _) | notMeta t -> return [(x,t)]
-    (PString s, ([],K i,[])) | s==i -> return []
-    (PInt s, ([],EInt i,[])) | s==i -> return []
-    (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
-    (PP (q,p) pp, ([], QC (r,f), tt)) | 
-       p `eqStrIdent` f && length pp == length tt -> do
-         matches <- mapM tryMatch (zip pp tt)
-         return (concat matches)
-    (PP (q,p) pp, ([], Q (r,f), tt)) | 
-       p `eqStrIdent` f && length pp == length tt -> do
-         matches <- mapM tryMatch (zip pp tt)
-         return (concat matches)
-    (PT _ p',_) -> trym p' t'
-    (PAs x p',_) -> do
-       subst <- trym p' t'
-       return $ (x,t) : subst
-    _ -> Bad (render (text "no match in pattern" <+> ppPatt Unqualified 0 p <+> text "for" <+> ppTerm Unqualified 0 t))
-
-  notMeta e = case e of
-    Meta _  -> False
-    App f a -> notMeta f &&  notMeta a  
-    Abs _ _ b -> notMeta b
-    _ -> True
-
-  prtm p g = 
-    ppPatt Unqualified 0 p <+> colon $$ hsep (punctuate semi [ppIdent x <+> char '=' <+> ppTerm Unqualified 0 y | (x,y) <- g])

src/compiler/api/GF/Compile/ConcreteToHaskell.hs

@@ -93,7 +93,7 @@ concrete2haskell opts abstr@(absname,_) concr@(cncname,mi) =
       | s == cStr = tcon0 (identS "Str")
     convLinType (QC (_,p)) = tcon0 (gId p)
     convLinType (RecType lbls) = tcon (rcon' ls) (map convLinType ts)
-      where (ls,ts) = unzip $ sortOn fst lbls
+      where (ls,_,ts) = unzip3 $ sortOn (\(l,_,_)->l) lbls
     convLinType (Table pt lt) = Fun (convLinType pt) (convLinType lt)
 
     lincatDef c ty = tsyn0 (lincatName c) (convLinType ty)
@@ -170,8 +170,9 @@ concrete2haskell opts abstr@(absname,_) concr@(cncname,mi) =
 
     convertPatt (PC c     ps) = ConP (gId c) (map convertPatt ps)
     convertPatt (PP (_,c) ps) = ConP (gId c) (map convertPatt ps)
-    convertPatt (PV v)        = VarP v
+    convertPatt (PV v)
-    convertPatt PW            = WildP
+      | v == identW           = WildP
+      | otherwise             = VarP v
     convertPatt (PR lbls)     = ConP (rcon' ls) (map convertPatt ps)
       where (ls,ps) = unzip $ sortOn fst lbls
     convertPatt (PString s)   = Lit s

src/compiler/api/GF/Compile/Export.hs

@@ -49,7 +49,6 @@ exportPGF opts fmt pgf =
       FmtSLF          -> single "slf"  slfPrinter
       FmtRegExp       -> single "rexp" regexpPrinter
       FmtFA           -> single "dot"  slfGraphvizPrinter
-      FmtLR           -> single "dot"  (\_ -> graphvizLRAutomaton)
  where
    name = fromMaybe (abstractName pgf) (flag optName opts)
 

src/compiler/api/GF/Compile/GenerateBC.hs

@@ -50,8 +50,9 @@ compileEquations gr arity st (i:is) eqs       fl bs = whilePP eqs Map.empty
                                                              in (bs3,[PUSH_FRAME, EVAL (shiftIVal (st+2) i) RecCall] ++ instrs1)
 
     whilePV []                           vrs = compileEquations gr arity st is vrs fl bs
-    whilePV ((vs, PV x     : ps, t):eqs) vrs = whilePV eqs (((x,i):vs,ps,t) : vrs)
+    whilePV ((vs, PV x     : ps, t):eqs) vrs
-    whilePV ((vs, PW       : ps, t):eqs) vrs = whilePV eqs ((      vs,ps,t) : vrs)
+      | x == identW                          = whilePV eqs ((      vs,ps,t) : vrs)
+      | otherwise                            = whilePV eqs (((x,i):vs,ps,t) : vrs)
     whilePV ((vs, PTilde _ : ps, t):eqs) vrs = whilePV eqs ((      vs,ps,t) : vrs)
     whilePV ((vs, PImplArg p:ps, t):eqs) vrs = whilePV ((vs,p:ps,t):eqs) vrs
     whilePV ((vs, PT _ p   : ps, t):eqs) vrs = whilePV ((vs,p:ps,t):eqs) vrs
@@ -101,11 +102,11 @@ compileFun gr eval st vs (App e1 e2) h0 bs args =
   let (h1,bs1,arg,is1) = compileArg gr st vs e2 h0 bs
       (h2,bs2,is2) = compileFun gr eval st vs e1 h1 bs1 (arg:args)
   in (h2,bs2,is1++is2)
-compileFun gr eval st vs (Q (m,id))  h0 bs args =
+compileFun gr eval st vs (Q q@(m,id))  h0 bs args =
-  case lookupAbsDef gr m id of
+  case lookupAbsDef gr q of
-    Ok (_,Just _)
+    Ok (Just _)
        -> (h0,bs,eval st (GLOBAL (showIdent id)) args)
-    _  -> let Ok ty = lookupFunType gr m id
+    _  -> let Ok ty = lookupFunType gr q
               (ctxt,_,_) = typeForm ty
               c_arity    = length ctxt
               n_args = length args
@@ -164,10 +165,10 @@ compileFun gr eval st vs e@(Glue e1 e2) h0 bs args =
   in (h1,bs1,[PUSH_ACCUM (LFlt 0)]++is++[POP_ACCUM]++eval (st+1) (ARG_VAR st) [])
 compileFun gr eval st vs e _ _ _ = error (show e)
 
-compileArg gr st vs (Q(m,id)) h0 bs =
+compileArg gr st vs (Q q@(m,id)) h0 bs =
-  case lookupAbsDef gr m id of
+  case lookupAbsDef gr q of
-    Ok (_,Just _) -> (h0,bs,GLOBAL (showIdent id),[])
+    Ok (Just _)   -> (h0,bs,GLOBAL (showIdent id),[])
-    _             -> let Ok ty = lookupFunType gr m id
+    _             -> let Ok ty = lookupFunType gr q
                          (ctxt,_,_) = typeForm ty
                          c_arity    = length ctxt
                      in if c_arity == 0
@@ -201,17 +202,9 @@ compileArg gr st vs (ImplArg e) h0 bs =
   compileArg gr st vs e h0 bs
 compileArg gr st vs e           h0 bs =
   let (f,es)   = appForm e
-      isConstr = case f of
+  in case f of
-                   Q c@(m,id) -> case lookupAbsDef gr m id of
+       QC q@(m,id) ->
-                                   Ok (_,Just _) -> Nothing
+            let Ok ty = lookupFunType gr q
-                                   _             -> Just c
-                   QC c@(m,id) -> case lookupAbsDef gr m id of
-                                    Ok (_,Just _) -> Nothing
-                                    _             -> Just c
-                   _        -> Nothing
-  in case isConstr of
-       Just (m,id) ->
-            let Ok ty = lookupFunType gr m id
                 (ctxt,_,_) = typeForm ty
                 c_arity    = length ctxt
                 ((h1,bs1,is1),args) = mapAccumL (\(h,bs,is) e -> let (h1,bs1,arg,is1) = compileArg gr st vs e h bs
@@ -234,7 +227,7 @@ compileArg gr st vs e           h0 bs =
                                 EVAL (HEAP h0) (TailCall diff) :
                                 []
                       in (h2,b:bs1,HEAP h1,is1 ++ (PUT_CLOSURE (length bs):is2))
-       Nothing -> compileLambda gr st vs [] e h0 bs
+       _ -> compileLambda gr st vs [] e h0 bs
 
 compileLambda gr st vs xs (Abs _ x e) h0 bs =
   compileLambda gr st vs (x:xs) e h0 bs

src/compiler/api/GF/Compile/GeneratePMCFG.hs

@@ -1,235 +1,327 @@
-{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
+{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------
--- |
--- Maintainer  : Krasimir Angelov
--- Stability   : (stable)
--- Portability : (portable)
---
--- Convert PGF grammar to PMCFG grammar.
---
------------------------------------------------------------------------------
-
 module GF.Compile.GeneratePMCFG
     (generatePMCFG, pmcfgForm, type2fields
     ) where
 
-import GF.Grammar hiding (VApp,VRecType)
+import GF.Infra.Ident
-import GF.Grammar.Predef
-import GF.Grammar.Lookup
-import GF.Infra.CheckM
 import GF.Infra.Option
-import GF.Text.Pretty
+import GF.Infra.CheckM
-import GF.Compile.Compute.Concrete
+import GF.Data.Operations
-import GF.Data.Operations(Err(..))
+import GF.Grammar.Grammar
-import PGF2.Transactions
+import GF.Grammar.Lookup
-import Control.Monad
+import GF.Grammar.Macros
-import Control.Monad.State
+import GF.Grammar.Predef
-import Control.Monad.ST
+import GF.Grammar.Printer hiding (ppValue)
-import qualified Data.Map.Strict as Map
+import GF.Text.Pretty hiding (empty)
-import qualified Data.Sequence as Seq
+import GF.Compile.Compute hiding ( getMeta, setMeta, globals, variants )
-import Data.List(mapAccumL,sortOn,sortBy)
+import qualified GF.Text.Pretty as PP
-import Data.Maybe(fromMaybe,isNothing)
+import qualified Data.Map as Map
-import Data.STRef
+import qualified Data.Set as Set
+import Control.Applicative
+import Control.Monad (foldM,zipWithM,liftM,liftM2,forM,MonadPlus(..))
+import Control.Monad.Fix
+import Data.Maybe
+import Data.List(mapAccumL,sortBy,sortOn,intersperse)
+import Data.Containers.ListUtils(nubOrd)
+import Prelude hiding ((<>))
+
 
 generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
 generatePMCFG opts cwd gr cmo@(cm,cmi)
-  | mstatus cmi == MSComplete && isModCnc cmi && isNothing (mseqs cmi) =
+  | mstatus cmi == MSComplete && isModCnc cmi =
                 do let gr' = prependModule gr cmo
-                   (js,seqs) <- runStateT (Map.traverseWithKey (\id info -> StateT (addPMCFG opts cwd gr' cmi id info)) (jments cmi)) Map.empty
+                       g   = Gl gr' (stdPredef g) False
-                   return (cm,cmi{jments = js, mseqs=Just (mapToSequence seqs)})
+                   js <- Map.traverseWithKey (addPMCFG cwd g cmi) (jments cmi)
+                   return (cm,cmi{jments = js})
   | otherwise = return cmo
-  where
-    mapToSequence m = Seq.fromList (map fst (sortOn snd (Map.toList m)))
 
-type SequenceSet = Map.Map [Symbol] Int
+addPMCFG cwd g cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) = do
-
+  defs <- case mdef of
-addPMCFG opts cwd gr cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) seqs = do
+            Nothing        -> checkInModule cwd cmi loc ("Happened in the rule generation for the lindef of" <+> id) $ do
-  (defs,seqs) <-
+                                t <- mkLinDefault sgr ty
-          case mdef of
+                                pmcfgForm g t [(Explicit,identW,Sort cStr)] ty
-            Nothing           -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
+            Just (L loc t) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
-                                   term <- mkLinDefault gr ty
+                                pmcfgForm g t [(Explicit,identW,Sort cStr)] ty
-                                   pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs
+  refs <- case mref of
-            Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
+            Nothing        -> checkInModule cwd cmi loc ("Happened in the rule generation for the linref of" <+> id) $ do
-                                   pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs
+                                t <- mkLinReference sgr ty
-  (refs,seqs) <- 
+                                pmcfgForm g t [(Explicit,identW,ty)] (Sort cStr)
-          case mref of
+            Just (L loc t) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
-            Nothing           -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
+                                pmcfgForm g t [(Explicit,identW,ty)] (Sort cStr)
-                                   term <- mkLinReference gr ty
-                                   pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs
-            Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
-                                   pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs
   mprn  <- case mprn of
              Nothing          -> return Nothing
              Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
-                                   prn <- normalForm (Gl gr stdPredef) prn
+                                   prn <- normalForm g prn
                                    return (Just (L loc prn))
-  return (CncCat mty mdef mref mprn (Just (defs,refs)),seqs)
+  return (CncCat mty mdef mref mprn (Just (defs,refs)))
-addPMCFG opts cwd gr cmi id (CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) seqs = do
+  where
-  (rules,seqs) <-
+    Gl sgr _ _ = g
-           checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $
+addPMCFG cwd g cmi id (CncFun (Just lty@(cats,cat,ctxt,ty)) mlin@(Just (L loc term)) mprn Nothing) = do
-             pmcfgForm gr term ctxt val seqs
+  rules <- checkInModule cwd cmi loc ("Happened in the rule generation for" <+> id) $
+             pmcfgForm g term ctxt ty
   mprn  <- case mprn of
              Nothing          -> return Nothing
              Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
-                                   prn <- normalForm (Gl gr stdPredef) prn
+                                   prn <- normalForm g prn
                                    return (Just (L loc prn))
-  return (CncFun mty mlin mprn (Just rules),seqs)
+  return (CncFun (Just lty) mlin mprn (Just rules))
-addPMCFG opts cwd gr cmi id info seqs = return (info,seqs)
-
-pmcfgForm :: Grammar -> Term -> Context -> Type -> SequenceSet -> Check ([Production],SequenceSet)
-pmcfgForm gr t ctxt ty seqs = do
-  res <- runEvalM (Gl gr stdPredef) $ do
-           (_,args) <- mapAccumM (\arg_no (_,_,ty) -> do
-                                          t <- EvalM (\(Gl gr _) k e mt d r msgs -> do (mt,_,t) <- type2metaTerm gr arg_no mt 0 [] ty
-                                                                                       k t mt d r msgs)
-                                          tnk <- newThunk [] t
-                                          return (arg_no+1,tnk))
-                                      0 ctxt
-           v <- eval [] t args
-           (lins,params) <- flatten v ty ([],[])
-           lins <- fmap reverse $ mapM str2lin lins
-           (r,rs,_) <- compute params
-           args <- zipWithM tnk2lparam args ctxt
-           vars <- getVariables
-           let res = LParam r (order rs)
-           return (vars,args,res,lins)
-  return (runState (mapM mkProduction res) seqs)
   where
-    tnk2lparam tnk (_,_,ty) = do
+    Gl sgr _ _ = g
-      v <- force tnk
-      (_,params) <- flatten v ty ([],[])
-      (r,rs,_) <- compute params
-      return (PArg [] (LParam r (order rs)))
 
-    compute []              = return (0,[],1)
+addPMCFG cwd g cmi id info = return info
-    compute ((v,ty):params) = do
-      (r, rs ,cnt ) <- param2int v ty
-      (r',rs',cnt') <- compute params
-      return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
 
-    mkProduction (vars,args,res,lins) = do
+pmcfgForm g t ctxt ty = do
-      lins <- mapM getSeqId lins
+  let (ms,s',t',arg_params) = apply 0 Map.empty unit ctxt t []
-      return (Production vars args res lins)
+  let v = eval g [] s' t' []
+  (ms,_,_,fn) <- breakDown g ms unit 0 [] v ty (return []) empty
+  res <- fmap nubOrd $ runGenM g ms [] $ do
+            (r,rs,v,res_params) <- fn
+            (subst,arg_params) <- mapAccumM params2int Map.empty arg_params
+            (subst,res_params) <- params2int subst res_params
+            (subst,lin_idx)    <- params2int' subst r rs
+            (subst,seq)        <- flatten subst v
+            qs <- quantifiers (Map.toList subst)
+            return (Rule qs res_params arg_params lin_idx seq)
+  length res `seq` return res
+  where
+    Gl sgr _ _ = g
+
+    quantifiers vars = GenM (\(Gl sgr _ _) k svs ms ->
+      k [boundsOf sgr ms variable | (variable,v) <- sortOn snd vars]
+        svs ms)
       where
-        getSeqId :: [Symbol] -> State (Map.Map [Symbol] SeqId) SeqId
+        boundsOf sgr ms i =
-        getSeqId lin = state $ \m ->
+          case Map.lookup i ms of
-          case Map.lookup lin m of
+            Just (Narrowing _ pty) -> case countParamValues sgr pty of
-            Just seqid -> (seqid,m)
+                                        Ok c    -> c
-            Nothing    -> let seqid = Map.size m
+                                        Bad msg -> error msg
-                          in (seqid,Map.insert lin seqid m)
+            _                      -> error (show (ppLVar i <+> "is not a free variable"))
 
-type2metaTerm :: SourceGrammar -> Int -> MetaThunks s -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> ST s (MetaThunks s,Int,Term)
+    apply d ms s []              t args = (ms,s,t,reverse args)
-type2metaTerm gr d ms r rs (Sort s) | s == cStr =
+    apply d ms s ((_,_,ty):ctxt) t args =
-  return (ms,r+1,TSymCat d r rs)
+       let (ms',s',_,t2,params) = type2metaTerm sgr d ms s 0 [] ty []
-type2metaTerm gr d ms r rs (RecType lbls) = do
+       in apply (d+1) ms' s' ctxt (App t t2) (params:args)
-  ((ms',r'),ass) <- mapAccumM (\(ms,r) (lbl,ty) -> case lbl of
+
-                                                        LVar j -> return ((ms,r),(lbl,(Just ty,TSymVar d j)))
+type2fields :: SourceGrammar -> Type -> [String]
-                                                        lbl    -> do (ms',r',t) <- type2metaTerm gr d ms r rs ty
+type2fields gr = type2fields PP.empty
-                                                                     return ((ms',r'),(lbl,(Just ty,t))))
-                                 (ms,r) lbls
-  return (ms',r',R ass)
-type2metaTerm gr d ms r rs (Table p q)
-  | count == 1 = do (ms',r',t) <- type2metaTerm gr d ms r rs q
-                    return (ms',r+(r'-r),T (TTyped p) [(PW,t)])
-  | null (collectParams q)
-               = do let pv    = varX (length rs+1)
-                    (ms',delta,t) <-
-                        fixST $ \(~(_,delta,_)) ->
-                                     do (ms',r',t) <- type2metaTerm gr d ms r ((delta,(pv,p)):rs) q
-                                        return (ms',r'-r,t)
-                    return (ms',r+delta*count,T (TTyped p) [(PV pv,t)])
-  | otherwise = do ((ms',r'),ts) <- mapAccumM (\(ms,r) _ -> do (ms',r',t) <- type2metaTerm gr d ms r rs q
-                                                               return ((ms',r'),t))
-                                              (ms,r) [0..count-1]
-                   return (ms',r+(r'-r),V p ts)
   where
-    collectParams (QC q)      = [q]
+    type2fields d (Sort s) | s == cStr = [show d]
-    collectParams (Table _ t) = collectParams t
+    type2fields d (RecType lbls) =
-    collectParams t           = collectOp collectParams t
+      concatMap (\(lbl,_,ty) -> type2fields (d <+> pp lbl) ty) lbls
+    type2fields d (Table p q) =
+      let Ok ts = allParamValues gr p
+      in concatMap (\t -> type2fields (d <+> ppTerm Unqualified 5 t) q) ts
+    type2fields d _ = []
 
-    count = case allParamValues gr p of
+
-              Ok ts   -> length ts
+mkLinDefault :: SourceGrammar -> Type -> Check Term
+mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
+ where
+   mkDefField ty =
+     case ty of
+       Table p t  -> do t' <- mkDefField t
+                        let T _ cs = mkWildCases t'
+                        return $ T (TWild p) cs
+       Sort s | s == cStr -> return (Vr varStr)
+       QC p       -> case allParamValues gr ty of
+                       Ok []    -> checkError ("no parameter values given to type" <+> ppQIdent Qualified p)
+                       Ok (v:_) -> return v
+                       Bad msg  -> fail msg
+       RecType r -> do
+         let (ls,_,ts) = unzip3 r
+         ts <- mapM mkDefField ts
+         return $ R (zipWith assign ls ts)
+       _ | Just _ <- isTypeInts ty -> return $ EInt 0 -- exists in all as first val
+       _ -> checkError ("a field in a linearization type cannot be" <+> ty)
+
+mkLinReference :: SourceGrammar -> Type -> Check Term
+mkLinReference gr typ = do
+  mb_term <- mkRefField typ (Vr varStr)
+  return (Abs Explicit varStr (fromMaybe Empty mb_term))
+  where
+    mkRefField ty trm =
+      case ty of
+        Table pty ty -> do ps <- allParamValues gr pty
+                           case ps of
+                             []     -> fail (render ("no parameter values given to type" <+> pty))
+                             (p:ps) -> mkRefField ty (S trm p)
+        Sort s | s == cStr -> return (Just trm)
+        QC p       -> return Nothing
+        RecType rs -> traverse rs trm
+        _ | Just _ <- isTypeInts ty -> return Nothing
+        _ -> fail (render ("a field in a linearization type cannot be" <+> typ))
+
+    traverse []            trm = return Nothing
+    traverse ((l,_,ty):rs) trm = do res <- mkRefField ty (P trm l)
+                                    case res of
+                                      Just trm -> return (Just trm)
+                                      Nothing  -> traverse rs trm
+
+
+type2metaTerm :: SourceGrammar -> Int -> MetaVars -> Choice -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> [(Value,Type)] -> (MetaVars,Choice,Int,Term,[(Value,Type)])
+type2metaTerm gr d ms s r rs (Sort srt)     params | srt == cStr = (ms,s,r+1,TSymCat d r rs,params)
+type2metaTerm gr d ms s r rs (RecType lbls) params =
+  let ((ms',s',r',params'),ass) =
+          mapAccumL (\(ms,s,r,params) (lbl,_,ty) -> case lbl of
+                                                      LVar j -> ((ms,s,r,params),(lbl,(Just ty,TSymVar d j)))
+                                                      lbl    -> let (ms',s',r',t,params') = type2metaTerm gr d ms s r rs ty params
+                                                                in ((ms',s',r',params'),(lbl,(Just ty,t))))
+                    (ms,s,r,params) lbls
+  in (ms',s',r',R ass,params')
+type2metaTerm gr d ms s r rs (Table p q) params
+  | count == 1 = let (ms',s',r',t,params') = type2metaTerm gr d ms s r rs q params
+                 in (ms',s',r+(r'-r),T (TTyped p) [(PV identW,t)],params')
+  | otherwise  = let pv     = varX (length rs+1)
+                     (ms',s',r',t,params') = type2metaTerm gr d ms s r ((delta,(pv,p)):rs) q params
+                     delta  = r'-r
+                 in (ms',s',r+delta*count,T (TTyped p) [(PV pv,t)],params')
+  where
+    count = case countParamValues gr p of
+              Ok c    -> c
               Bad msg -> error msg
-type2metaTerm gr d ms r rs ty@(QC q) = do
+type2metaTerm gr d ms c r rs ty@(QC q) params =
   let i = Map.size ms + 1
-  tnk <- newSTRef (Narrowing i ty)
+      (c1,c2) = split c
-  return (Map.insert i tnk ms,r,Meta i)
+  in (Map.insert i (Narrowing c1 ty) ms,c2,r,Meta i,(VMeta i [],ty):params)
-type2metaTerm gr d ms r rs ty
+type2metaTerm gr d ms c r rs ty params
-  | Just n <- isTypeInts ty = do
+  | Just n <- isTypeInts ty =
       let i = Map.size ms + 1
-      tnk <- newSTRef (Narrowing i ty)
+          (c1,c2) = split c
-      return (Map.insert i tnk ms,r,Meta i)
+      in (Map.insert i (Narrowing c1 ty) ms,c2,r,Meta i,(VMeta i [],ty):params)
 
-flatten (VR as) (RecType lbls) st = do
-  foldM collect st lbls
-  where
-    collect st (lbl,ty) =
-      case lookup lbl as of
-        Just tnk -> do v <- force tnk
-                       flatten v ty st
-        Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
-                               "among" <+> hsep (punctuate (pp ',') (map fst as)))
-flatten v@(VT _ env cs) (Table p q) st = do
-  ts <- getAllParamValues p
-  foldM collect st ts
-  where
-    collect st t = do
-      tnk <- newThunk [] t
-      let v0 = VS v tnk []
-      v <- patternMatch v0 (map (\(p,t) -> (env,[p],[tnk],t)) cs)
-      flatten v q st
-flatten (VV _ tnks) (Table _ q) st = do
-  foldM collect st tnks
-  where
-    collect st tnk = do
-      v <- force tnk
-      flatten v q st
-flatten v (Sort s) (lins,params) | s == cStr = do
-  deepForce v
-  return (v:lins,params)
-flatten v ty@(QC q) (lins,params) = do
-  deepForce v
-  return (lins,(v,ty):params)
-flatten v ty (lins,params)
-  | Just n <- isTypeInts ty = do deepForce v
-                                 return (lins,(v,ty):params)
-  | otherwise               = evalError (pp (showValue v))
 
-deepForce (VR as)          = mapM_ (\(lbl,v) -> force v >>= deepForce) as
+breakDown g ms s r rs v (Sort sort)    fn0 fn
-deepForce (VApp q tnks)    = mapM_ (\tnk -> force tnk >>= deepForce) tnks
+  | sort == cStr                              =
-deepForce (VC v1 v2)       = deepForce v1 >> deepForce v2
+      let fn' = do params <- fn0
-deepForce (VAlts def alts) = do deepForce def
+                   v      <- force v
-                                mapM_ (\(v,_) -> deepForce v) alts
+                   return (r,rs,v,params)
-deepForce (VSymCat d r rs) = mapM_ (\(_,(tnk,_)) -> force tnk >>= deepForce) rs
+                <|>
-deepForce _                = return ()
+                do fn
-
+      in return (ms,r+1,fn0,fn')
-str2lin (VApp q [])
+breakDown g ms s r rs v (RecType lbls) fn0 fn = traverse ms r rs lbls fn0 fn
-  | q == (cPredef, cBIND)       = return [SymBIND]
-  | q == (cPredef, cNonExist)   = return [SymNE]
-  | q == (cPredef, cSOFT_BIND)  = return [SymSOFT_BIND]
-  | q == (cPredef, cSOFT_SPACE) = return [SymSOFT_SPACE]
-  | q == (cPredef, cCAPIT)      = return [SymCAPIT]
-  | q == (cPredef, cALL_CAPIT)  = return [SymALL_CAPIT]
-str2lin (VStr s)         = return [SymKS s]
-str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs
-                              return [SymCat d (LParam r (order rs))]
   where
-    compute r' []                     = return (r',[])
+    traverse ms r rs []                fn0 fn = return (ms,r,fn0,fn)
-    compute r' ((cnt',(tnk,ty)):tnks) = do
+    traverse ms r rs ((lbl,_,ty):lbls) fn0 fn = do (ms,r,fn0,fn) <- breakDown g ms s r rs (project v) ty fn0 fn
-      v <- force tnk
+                                                   traverse ms r rs lbls fn0 fn
-      (r, rs, cnt) <- param2int v ty
+      where
-      (r',rs') <- compute r' tnks
+        project (VR as)       = case lookup lbl as of
-      return (r*cnt'+r',combine cnt' rs rs')
+                                  Nothing -> error (render ("Missing value for label" <+> pp lbl $$
-str2lin (VSymVar d r)    = return [SymVar d r]
+                                                            "in" <+> ppValue Unqualified 0 (VR as)))
-str2lin VEmpty           = return []
+                                  Just v  -> v
-str2lin (VC v1 v2)       = liftM2 (++) (str2lin v1) (str2lin v2)
+        project (VFV c fvs)   = VFV c (fmap project fvs)
-str2lin v0@(VAlts def alts)
+        project (VMeta i vs)  = VSusp i (\v -> project (apply g v vs)) []
-                         = do def <- str2lin def
+        project (VSusp i k vs)= VSusp i (\v -> project (apply g (k v) vs)) []
-                              alts <- forM alts $ \(v1,v2) -> do
+        project (VError msg)  = VError msg
-                                lin <- str2lin v1
+        project v             = VP v lbl []
-                                ss  <- to_strs v2
+breakDown g ms c r rs v (Table p q) fn0 fn = do
-                                return (lin,ss)
+  let i  = Map.size ms + 1
-                              return [SymKP def alts]
+      v2 = VMeta i []
+      v0 = VS v v2 []
+      (c1,c2) = split c
+      Gl gr _ _ = g
+  cnt <- countParamValues gr p
+  (ms,r',fn0,fn) <- mfix $ \(~(_,r',_,_)) ->
+       breakDown g (Map.insert i (Narrowing c1 p) ms) c2 r ((r'-r,(v2,p)):rs) (select v0 v v2) q fn0 fn
+  return (ms,r+(r'-r)*cnt,fn0,fn)
+  where
+    select v0 (VT _  env s cs) v2 = patternMatch g s v0 (map (\(p,t) -> (env,[p],[v2],t)) cs)
+    select v0 (VV vty tvs)     v2 = vtableSelect g v0 vty tvs v2 []
+    select v0 (VFV i fvs)      v2 = VFV i (fmap (\v1 -> select v0 v1 v2) fvs)
+    select v0 (VMeta i vs)     v2 = VSusp i (\v -> select v0 (apply g v vs) v2) []
+    select v0 (VSusp i k vs)   v2 = VSusp i (\v -> select v0 (apply g (k v) vs) v2) []
+    select v0 (VError msg)     v2 = VError msg
+    select v0 v1               v2 = v0
+breakDown g ms s r rs v ty@(QC q) fn0 fn =
+  let fn0' = do params <- fn0
+                v <- force v
+                return ((v,ty):params)
+      fn'  = do (r,rs,v',res_params) <- fn
+                v <- force v
+                return (r,rs,v',(v,ty):res_params)
+  in return (ms,r,fn0',fn')
+breakDown g ms s r rs v ty@(App (Q q) _) fn0 fn =
+  let fn0' = do params <- fn0
+                v <- force v
+                return ((v,ty):params)
+      fn'  = do (r,rs,v',res_params) <- fn
+                v <- force v
+                return (r,rs,v',(v,ty):res_params)
+  in return (ms,r,fn0',fn')
+
+force (VStr s) = return (VStr s)
+force (VInt n) = return (VInt n)
+force (VFlt d) = return (VFlt d)
+force (VSymCat d r rs) = do
+  rs <- mapM force_ rs
+  return (VSymCat d r rs)
+  where
+    force_ (factor, (v, ty)) = do
+      v <- force v
+      return (factor, (v, ty))
+force (VApp q vs) = do
+  vs <- mapM force vs
+  return (VApp q vs)
+force (VAlts def alts) = do
+  def  <- force def
+  alts <- mapM force_ alts
+  return (VAlts def alts)
+  where
+    force_ (x,y) = do
+      x <- force x
+      y <- force y
+      return (x,y)
+force VEmpty     = return VEmpty
+force (VC v1 v2) = do
+  v1 <- force v1
+  v2 <- force v2
+  return (VC v1 v2)
+force (VMeta i vs) = do
+  vs <- mapM force vs
+  return (VMeta i vs)
+force (VSusp i k vs) = do
+  vs <- mapM force vs
+  st <- getMeta i
+  v <- case st of
+         Narrowing c ty -> do v <- chooseMetaValue c ty
+                              setMeta i (Bound undefined v)
+                              return v
+         Bound _ v      -> return v
+  g <- globals
+  force (apply g (k v) vs)
+force (VStrs vs) = do
+  vs <- mapM force vs
+  return (VStrs vs)
+force (VR as) = do
+  as <- mapM (\(l,v) -> fmap ((,) l) (force v)) as
+  return (VR as)
+force v@(VPatt _ _ _) = return v
+force (VFV c vs) = do
+  v <- variants c (unvariants vs)
+  force v
+force (VError msg) = compileError msg
+force v = compileError ("Cannot evaluate" <+> ppValue Unqualified 0 v)
+
+
+flatten subst (VStr s) = return (subst,[SymKS s])
+flatten subst (VSymCat d r rs) = do
+  (subst,lin_index) <- params2int' subst r rs
+  return (subst,[SymCat d lin_index])
+flatten subst (VApp (m,id) [])
+  | m == cPredef && id == cBIND       = return (subst,[SymBIND])
+  | m == cPredef && id == cSOFT_BIND  = return (subst,[SymSOFT_BIND])
+  | m == cPredef && id == cSOFT_SPACE = return (subst,[SymSOFT_SPACE])
+  | m == cPredef && id == cNonExist   = return (subst,[SymNE])
+  | m == cPredef && id == cCAPIT      = return (subst,[SymCAPIT])
+  | m == cPredef && id == cALL_CAPIT  = return (subst,[SymALL_CAPIT])
+flatten subst v0@(VAlts def alts) = do
+  (subst,def) <- flatten subst def
+  (subst,alts) <- mapAccumM (\subst (alt,ps) -> do
+                                (subst,alt) <- flatten subst alt
+                                ps  <- to_strs ps
+                                return (subst,(alt,ps)))
+                            subst
+                            alts
+  return (subst,[SymKP def alts])
   where
     to_strs (VStrs vs)    = mapM to_str vs
     to_strs (VPatt _ _ p) = from_patt p
@@ -244,50 +336,94 @@ str2lin v0@(VAlts def alts)
     from_patt (PChars cs)  = return (map (:[]) cs)
     from_patt _            = fail
 
-    fail = evalError ("Complex patterns are not supported in:" $$ nest 2 (pp (showValue v0)))
+    fail = compileError ("Complex patterns are not supported in:" $$ nest 2 (ppValue Unqualified 0 v0))
-str2lin v                = do t <- value2term False [] v
+flatten subst VEmpty     = return (subst,[])
-                              evalError ("the string:" <+> ppTerm Unqualified 0 t $$
+flatten subst (VC v1 v2) = do
-                                         "cannot be evaluated at compile time.")
+  (subst,s1) <- flatten subst v1
+  (subst,s2) <- flatten subst v2
+  return (subst,s1++s2)
+flatten subst (VSusp i k vs) = do
+  st <- getMeta i
+  v <- case st of
+         Narrowing c ty -> do v <- chooseMetaValue c ty
+                              setMeta i (Bound undefined v)
+                              return v
+         Bound _ v      -> return v
+  g <- globals
+  flatten subst (apply g (k v) vs)
+flatten subst (VFV c vs) = do
+  v <- variants c (unvariants vs)
+  flatten subst v
+flatten subst (VError msg) = compileError msg
+flatten subst v = compileError ("Cannot evaluate" <+> ppValue Unqualified 0 v  <+> "to a string")
 
-param2int (VR as) (RecType lbls) = compute lbls
+
+params2int subst rs = do
+  (subst,r,rs,_) <- compute subst rs
+  return (subst,LParam r (order rs))
   where
-    compute []              = return (0,[],1)
+    compute subst []              = return (subst,0,[],1)
-    compute ((lbl,ty):lbls) = do
+    compute subst ((v,ty):params) = do
+      (subst, r, rs, cnt ) <- param2int subst v ty
+      (subst, r',rs',cnt') <- compute subst params
+      return (subst, r*cnt'+r',combine cnt' rs rs',cnt*cnt')
+
+params2int' subst r0 rs = do
+  (subst,r,rs) <- compute subst rs
+  return (subst,LParam (r0+r) (order rs))
+  where
+    compute subst []                     = return (subst,0,[])
+    compute subst ((cnt',(v,ty)):params) = do
+      (subst, r, rs, cnt) <- param2int subst v ty
+      (subst, r',rs')     <- compute subst params
+      return (subst,r*cnt'+r',combine cnt' rs rs')
+
+param2int subst (VR as) (RecType lbls) = compute subst lbls
+  where
+    compute subst []                = return (subst,0,[],1)
+    compute subst ((lbl,_,ty):lbls) = do
       case lookup lbl as of
-        Just tnk -> do v <- force tnk
+        Just v   -> do (subst, r, rs ,cnt ) <- param2int subst v ty
-                       (r, rs ,cnt ) <- param2int v ty
+                       (subst, r',rs',cnt') <- compute subst lbls
-                       (r',rs',cnt') <- compute lbls
+                       return (subst,r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
-                       return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
+        Nothing  -> compileError ("Missing value for label" <+> pp lbl $$
-        Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
+                                  "among" <+> hsep (punctuate (pp ',') (map fst as)))
-                               "among" <+> hsep (punctuate (pp ',') (map fst as)))
+param2int subst (VApp q vs) ty = do
-param2int (VApp q tnks) ty = do
+  (      r ,    ctxt,cnt ) <- getIdxCnt q
-  (r ,    ctxt,cnt ) <- getIdxCnt q
+  (subst,r',rs',     cnt') <- compute subst ctxt vs
-  (r',rs',     cnt') <- compute ctxt tnks
+  return (subst,r+r',rs',cnt)
-  return (r+r',rs',cnt)
   where
-    getIdxCnt q = do
+    compute subst []              []     = return (subst,0,[],1)
-      (_,ResValue (L _ ty) idx) <- getInfo q
+    compute subst ((_,_,ty):ctxt) (v:vs) = do
-      let (ctxt,QC p) = typeFormCnc ty
+      (subst, r, rs ,cnt ) <- param2int subst v ty
-      (_,ResParam _ (Just (_,cnt))) <- getInfo p
+      (subst, r',rs',cnt') <- compute subst ctxt vs
-      return (idx,ctxt,cnt)
+      return (subst,r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
-
+param2int subst (VInt n) ty
-    compute []              []         = return (0,[],1)
+  | Just max <- isTypeInts ty= return (subst,fromIntegral n,[],fromIntegral max+1)
-    compute ((_,_,ty):ctxt) (tnk:tnks) = do
+param2int subst (VMeta i _) ty = do
-      v <- force tnk
+  st <- getMeta i
-      (r, rs ,cnt ) <- param2int v ty
+  case st of
-      (r',rs',cnt') <- compute ctxt tnks
+    Narrowing c ty -> do count <- getCnt ty
-      return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
+                         case Map.lookup i subst of
-param2int (VInt n)        ty
+                           Just v  -> return (subst,0,[(1,v)],count)
-  | Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1)
+                           Nothing -> let v      = Map.size subst
-param2int (VMeta tnk _) ty = do
+                                          subst' = Map.insert i v subst
-  tnk_st <- getRef tnk
+                                      in return (subst',0,[(1,v)],count)
-  case tnk_st of
+    Bound _ v      -> param2int subst v ty
-    Evaluated _ v  -> param2int v ty
+param2int subst (VSusp i k vs) ty = do
-    Narrowing j ty -> do ts <- getAllParamValues ty
+  st <- getMeta i
-                         return (0,[(1,j-1)],length ts)
+  v <- case st of
-param2int v ty = do t <- value2term True [] v
+         Narrowing c ty -> do v <- chooseMetaValue c ty
-                    evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
+                              setMeta i (Bound undefined v)
-                               "cannot be evaluated at compile time.")
+                              return v
+         Bound _ v      -> return v
+  g <- globals
+  param2int subst (apply g (k v) vs) ty
+param2int subst (VFV c vs) ty = do
+  v <- variants c (unvariants vs)
+  param2int subst v ty
+param2int subst v ty = compileError ("the parameter:" <+> ppValue Unqualified 0 v $$
+                                     "cannot be evaluated at compile time.")
 
 combine' 1   rs 1    rs' = []
 combine' 1   rs cnt' rs' = rs'
@@ -302,63 +438,101 @@ combine cnt' ((r,pv):rs) ((r',pv'):rs') =
     EQ -> (r*cnt'+r',pv ) : combine cnt' rs ((r',pv'):rs')
     GT -> (       r',pv') : combine cnt' ((r,pv):rs) rs'
 
+
+type ChoiceMap = Map.Map Choice Int
+type MetaVars = Map.Map Int MetaState
+
+newtype GenM a = GenM {unGen :: forall r . Globals -> (a -> ChoiceMap -> MetaVars -> r -> Check r) -> ChoiceMap -> MetaVars -> r -> Check r}
+
+instance Functor GenM where
+  fmap f (GenM m) = GenM (\g k -> m g (k . f))
+
+instance Applicative GenM where
+  pure x = GenM (\g k -> k x)
+  (GenM f) <*> (GenM h) = GenM (\g k -> f g (\fn -> h g (\x -> k (fn x))))
+
+instance Alternative GenM where
+  empty = GenM (\g k svs ms r -> pure r)
+  (GenM f) <|> (GenM h) = GenM (\g k svs ms r -> f g k svs ms r >>= h g k svs ms)
+
+instance Monad GenM where
+  (GenM f) >>= h = GenM (\g k -> f g (\x -> case h x of {GenM h -> h g k}))
+
+instance MonadFail GenM where
+  fail msg = GenM (\_ _ _ _ _ -> fail msg)
+
+runGenM g ms r (GenM f) = f g (\x svs ms xs -> pure (x:xs)) Map.empty ms r
+
+compileError d = GenM (\_ _ _ _ _ -> checkError d)
+
+globals = GenM $ \g k -> k g
+
+variants :: Choice -> [a] -> GenM a
+variants c xs = GenM (\g k svs ms r ->
+                          case Map.lookup c svs of
+                            Just j  -> k (xs !! j) svs ms r
+                            Nothing -> foldM (\r (j,x) -> k x (Map.insert c j svs) ms r) r (zip [0..] xs))
+
+newMeta c ty = GenM $ \_ k svs ms ->
+  let i = Map.size ms + 1
+  in k i svs (Map.insert i (Narrowing c ty) ms)
+
+getMeta i = GenM $ \_ k svs ms r ->
+  case Map.lookup i ms of
+    Just v  -> k v svs ms r
+    Nothing -> checkError (pp "Meta variable" <+> ppMeta i <+> "is not defined")
+
+setMeta i st = GenM $ \_ k svs ms ->
+  k () svs (Map.insert i st ms)
+
+getCnt ty = GenM $ \(Gl gr _ _) k svs ms r ->
+  case countParamValues gr ty of
+    Ok c    -> k c svs ms r
+    Bad msg -> checkError (pp msg)
+
+getIdxCnt q = GenM $ \(Gl gr _ _) k svs ms r ->
+  case lookupOrigInfo gr q of
+    Ok (_,ResValue (L _ ty) idx) -> 
+      let (ctxt,QC p) = typeFormCnc ty
+      in case lookupOrigInfo gr p of
+           Ok (_,ResParam _ (Just (_,cnt))) -> k (idx,ctxt,cnt) svs ms r
+           Bad msg -> checkError (pp msg)
+    Bad msg -> checkError (pp msg)
+
+chooseMetaValue :: Choice -> Type -> GenM Value
+chooseMetaValue s ptyp = GenM $ \g@(Gl gr _ _) k svs ms r ->
+  case ptyp of
+    _ | Just n <- isTypeInts ptyp -> foldM (\r i -> k (VInt i) svs ms r) r [0..n]
+    QC c -> do (mod,info) <- lookupOrigInfo gr c
+               case info of
+                 ResParam (Just ps) _ -> mkValue mod k svs ms r 0 (unLoc ps)
+                 _                    -> checkError (ppQIdent Qualified c <+> "has no parameter values defined")
+    Q  c -> lookupResDef gr c >>= \ty -> unGen (chooseMetaValue s ty) g k svs ms r
+    RecType lbls -> unGen (mapAccumM mkField s lbls >>= \(_,lbls) -> return (VR lbls)) g k svs ms r
+    _ -> checkError ("cannot find parameter values for" <+> ptyp)
+  where
+    mkValue mod k svs ms r idx []             = return r
+    mkValue mod k svs ms r idx ((id,ctxt):ps) = do
+      let (ms',args) = mkVars ms s ctxt
+      r <- k (VApp (mod,id) args) (Map.insert s idx svs) ms' r
+      mkValue mod k svs ms r (idx+1) ps
+
+    mkVars ms c []              = (ms,[])
+    mkVars ms c ((_,_,ty):ctxt) =
+      let i = Map.size ms + 1
+          (c1,c2) = split c
+          (ms',args) = mkVars (Map.insert i (Narrowing c1 ty) ms) c2 ctxt
+      in (ms',VMeta i []:args)
+
+    mkField c (l,_,ty) = do
+       let (c1,c2) = split c
+       v <- chooseMetaValue c1 ty
+       return (c2,(l,v))
+
+order :: Ord a => [(a,b)] -> [(a,b)]
 order = sortBy (\(r1,_) (r2,_) -> compare r2 r1)
 
 mapAccumM f a []     = return (a,[])
 mapAccumM f a (x:xs) = do (a, y) <- f a x
                           (a,ys) <- mapAccumM f a xs
                           return (a,y:ys)
-
-type2fields :: SourceGrammar -> Type -> [String]
-type2fields gr = type2fields empty
-  where
-    type2fields d (Sort s) | s == cStr = [show d]
-    type2fields d (RecType lbls) =
-      concatMap (\(lbl,ty) -> type2fields (d <+> pp lbl) ty) lbls
-    type2fields d (Table p q) =
-      let Ok ts = allParamValues gr p
-      in concatMap (\t -> type2fields (d <+> ppTerm Unqualified 5 t) q) ts
-    type2fields d _ = []
-
-mkLinDefault :: SourceGrammar -> Type -> Check Term
-mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
- where
-   mkDefField ty =
-     case ty of
-       Table p t  -> do t' <- mkDefField t
-                        let T _ cs = mkWildCases t'
-                        return $ T (TWild p) cs
-       Sort s | s == cStr -> return (Vr varStr)
-       QC p       -> case lookupParamValues gr p of
-                       Ok []    -> checkError ("no parameter values given to type" <+> ppQIdent Qualified p)
-                       Ok (v:_) -> return v
-                       Bad msg  -> fail msg
-       RecType r -> do
-         let (ls,ts) = unzip r
-         ts <- mapM mkDefField ts
-         return $ R (zipWith assign ls ts)
-       _ | Just _ <- isTypeInts ty -> return $ EInt 0 -- exists in all as first val
-       _ -> checkError ("a field in a linearization type cannot be" <+> ty)
-
-mkLinReference :: SourceGrammar -> Type -> Check Term
-mkLinReference gr typ = do
-  mb_term <- mkRefField typ (Vr varStr)
-  return (Abs Explicit varStr (fromMaybe Empty mb_term))
-  where
-    mkRefField ty trm =
-      case ty of
-        Table pty ty -> case allParamValues gr pty of
-                          Ok []     -> checkError ("no parameter values given to type" <+> pty)
-                          Ok (p:ps) -> mkRefField ty (S trm p)
-                          Bad msg   -> fail msg
-        Sort s | s == cStr -> return (Just trm)
-        QC p       -> return Nothing
-        RecType rs -> traverse rs trm
-        _ | Just _ <- isTypeInts ty -> return Nothing
-        _ -> checkError ("a field in a linearization type cannot be" <+> typ)
-
-    traverse []          trm = return Nothing
-    traverse ((l,ty):rs) trm = do res <- mkRefField ty (P trm l)
-                                  case res of
-                                    Just trm -> return (Just trm)
-                                    Nothing  -> traverse rs trm

src/compiler/api/GF/Compile/GrammarToCanonical.hs

@@ -9,7 +9,7 @@ import GF.Grammar
 import GF.Grammar.Lookup(allOrigInfos,lookupOrigInfo)
 import GF.Infra.Option(Options,noOptions)
 import GF.Infra.CheckM
-import GF.Compile.Compute.Concrete2
+import GF.Compile.Compute
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Data.Maybe(mapMaybe,fromMaybe)
@@ -36,7 +36,6 @@ abstract2canonical absname gr = do
                      mopens  = [],
                      mexdeps = [],
                      msrc    = "",
-                     mseqs   = Nothing,
                      jments  = Map.fromList infos
                    })
 
@@ -74,7 +73,6 @@ concretes2canonical opts absname gr = do
         mopens  = [],
         mexdeps = [],
         msrc    = "",
-        mseqs   = Nothing,
         jments  = Map.empty
       }
 
@@ -83,7 +81,7 @@ type QSet = Set.Set (ModuleName,Ident)
 -- | Generate Canonical GF for the given concrete module.
 concrete2canonical :: Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check (QSet,Module)
 concrete2canonical gr absname cncname modinfo = do
-  let g = Gl gr (stdPredef g)
+  let g = Gl gr (stdPredef g) False
   infos <- mapM (convInfo g) (allOrigInfos gr cncname)
   let pts = Set.unions (map fst infos)
   return (pts,
@@ -96,17 +94,16 @@ concrete2canonical gr absname cncname modinfo = do
                       mopens  = [],
                       mexdeps = [],
                       msrc    = "",
-                      mseqs   = Nothing,
                       jments  = Map.fromList (mapMaybe snd infos)
                     }))
   where
-    convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mb_prods) = do
+    convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mpmcfg) = do
       typ <- normalForm g typ
       let pts = paramTypes typ
-      return (pts,Just (id,CncCat (Just (L loc typ)) lindef linref pprn mb_prods))
+      return (pts,Just (id,CncCat (Just (L loc typ)) lindef linref pprn mpmcfg))
-    convInfo g ((mn,id), CncFun mb_ty@(Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn mb_prods) = do
+    convInfo g ((mn,id), CncFun mb_ty@(Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn mpmcfg) = do
       def <- normalForm g (eta_expand def ctx)
-      return (Set.empty,Just (id,CncFun mb_ty (Just (L loc def)) pprn mb_prods))
+      return (Set.empty,Just (id,CncFun mb_ty (Just (L loc def)) pprn mpmcfg))
     convInfo g  _ = return (Set.empty,Nothing)
 
     eta_expand t []                   = t
@@ -114,7 +111,7 @@ concrete2canonical gr absname cncname modinfo = do
     eta_expand t ((Explicit,x,_):ctx) = Abs Explicit x (eta_expand (App t (Vr x))           ctx)
 
 
-paramTypes (RecType fs) = Set.unions (map (paramTypes.snd) fs)
+paramTypes (RecType fs) = Set.unions (map (\(_,_,t)->paramTypes t) fs)
 paramTypes (Table t1 t2) = Set.union (paramTypes t1) (paramTypes t2)
 paramTypes (App tf ta) = Set.union (paramTypes tf) (paramTypes ta)
 paramTypes (Sort _) = Set.empty

src/compiler/api/GF/Compile/GrammarToPGF.hs

@@ -57,18 +57,17 @@ grammar2PGF opts mb_pgf gr am probs = do
       createConcrete (mi2i cm) $ do
         let cflags = err (const noOptions) mflags (lookupModule gr cm)
         sequence_ [setConcreteFlag name value | (name,value) <- optionsPGF cflags]
-        let infos = ( Seq.fromList [Left [SymCat 0 (LParam 0 [])]]
+        let infos = ( let z       = LParam 0 []
-                    , let id_prod = Production [] [PArg [] (LParam 0 [])] (LParam 0 []) [0]
+                          id_rule = Rule [] z [z] z [SymCat 0 z]
-                          prods   = ([id_prod],[id_prod])
+                          rules   = ([id_rule],[id_rule])
-                      in [(cInt,   CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
+                      in [((cm,cInt),   CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules))
-                         ,(cString,CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
+                         ,((cm,cString),CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules))
-                         ,(cFloat, CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
+                         ,((cm,cFloat), CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules))
                          ]
                     )
-                    : prepareSeqTbls (Look.allOrigInfos gr cm)
+                    ++ Look.allOrigInfos gr cm
-        infos <- processInfos createCncCats infos
+        mapM_ createCncCats infos
-        infos <- processInfos createCncFuns infos
+        mapM_ createCncFuns infos
-        return ()
   return pgf
   where
     aflags = err (const noOptions) mflags (lookupModule gr am)
@@ -83,13 +82,13 @@ grammar2PGF opts mb_pgf gr am probs = do
                                ((m,c),AbsCat (Just (L _ cont))) <- adefs, let c' = i2i c]
 
     funs = [(f', mkType [] ty, arity, bcode, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) |
-                               ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
+                               ((m,f),AbsFun (Just (L _ ty)) mdef) <- adefs,
-                               let arity = mkArity ma mdef ty,
+                               let arity = mkArity mdef ty,
-                               let bcode = mkDef gr arity mdef,
+                               let bcode = mkDef gr mdef,
                                let f' = i2i f]
                                
     funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
-                    [(i2i cat,[(i2i f,Map.lookup f' probs)]) | ((m,f),AbsFun (Just (L _ ty)) _ _ _) <- adefs,
+                    [(i2i cat,[(i2i f,Map.lookup f' probs)]) | ((m,f),AbsFun (Just (L _ ty)) _) <- adefs,
                                                                let (_,(_,cat),_) = GM.typeForm ty,
                                                                let f' = i2i f]
       where
@@ -100,38 +99,19 @@ grammar2PGF opts mb_pgf gr am probs = do
                       0 -> 0
                       n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
 
-    prepareSeqTbls infos = 
+    createCncCats ((_,c),CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do
-       (map addSeqTable . Map.toList . Map.fromListWith (++))
+      createLincat (i2i c) (type2fields gr ty) lindefs linrefs
-               [(m,[(c,info)]) | ((m,c),info) <- infos]
-       where
-         addSeqTable (m,infos) = 
-           case lookupModule gr m of
-             Ok mi   -> case mseqs mi of
-                          Just seqs -> (fmap Left seqs,infos)
-                          Nothing   -> (Seq.empty,[])
-             Bad msg -> error msg
-
-    processInfos f []                    = return []
-    processInfos f ((seqtbl,infos):rest) = do
-      seqtbl <- foldM f seqtbl infos
-      rest <- processInfos f rest
-      return ((seqtbl,infos):rest)
-
-    createCncCats seqtbl (c,CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do
-      seqtbl <- createLincat (i2i c) (type2fields gr ty) lindefs linrefs seqtbl
       case mprn of
         Nothing        -> return ()
         Just (L _ prn) -> setPrintName (i2i c) (unwords (term2tokens prn))
-      return seqtbl
+    createCncCats _ = return ()
-    createCncCats seqtbl _ = return seqtbl
 
-    createCncFuns seqtbl (f,CncFun _ _ mprn (Just prods)) = do
+    createCncFuns ((_,f),CncFun _ _ mprn (Just rules)) = do
-      seqtbl <- createLin (i2i f) prods seqtbl
+      createLin (i2i f) rules
       case mprn of
         Nothing        -> return ()
         Just (L _ prn) -> setPrintName (i2i f) (unwords (term2tokens prn))
-      return seqtbl
+    createCncFuns _ = return ()
-    createCncFuns seqtbl _ = return seqtbl
 
     term2tokens (K tok)     = [tok]
     term2tokens (C t1 t2)   = term2tokens t1 ++ term2tokens t2
@@ -173,7 +153,6 @@ mkPatt scope p =
     A.PV x      -> (x:scope,C.PVar (i2i x))
     A.PAs x p   -> let (scope',p') = mkPatt scope p
                    in (x:scope',C.PAs (i2i x) p')
-    A.PW        -> (  scope,C.PWild)
     A.PInt i    -> (  scope,C.PLit (C.LInt (fromIntegral i)))
     A.PFloat f  -> (  scope,C.PLit (C.LFlt f))
     A.PString s -> (  scope,C.PLit (C.LStr s))
@@ -188,13 +167,12 @@ mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
                                                            then (  scope,(bt,i2i x,ty'))
                                                            else (x:scope,(bt,i2i x,ty'))) scope hyps 
 
-mkDef gr arity (Just eqs) = generateByteCode gr arity eqs
+mkDef gr (Just (arity,eqs)) = generateByteCode gr arity eqs
-mkDef gr arity Nothing    = []
+mkDef gr Nothing    = []
 
-mkArity (Just a) _        ty = a   -- known arity, i.e. defined function
+mkArity (Just (a,_)) ty = a   -- known arity, i.e. defined function
-mkArity Nothing  (Just _) ty = 0   -- defined function with no arity - must be an axiom
+mkArity Nothing      ty = let (ctxt, _, _) = GM.typeForm ty  -- constructor
-mkArity Nothing  _        ty = let (ctxt, _, _) = GM.typeForm ty  -- constructor
+                          in length ctxt
-                               in length ctxt
 {-
 genCncCats gr am cm cdefs = mkCncCats 0 cdefs
   where

src/compiler/api/GF/Compile/Rename.hs

@@ -30,7 +30,6 @@ module GF.Compile.Rename (
 import GF.Infra.Ident
 import GF.Infra.CheckM
 import GF.Grammar.Grammar
-import GF.Grammar.Values
 import GF.Grammar.Predef
 import GF.Grammar.Lookup
 import GF.Grammar.Macros
@@ -87,7 +86,7 @@ renameIdentTerm' env@(act,imps) t0 =
 
     -- this facility is mainly for BWC with GF1: you need not import PredefAbs
     predefAbs c s
-      | isPredefCat c = return (Q (cPredefAbs,c))
+      | isPredefCat c = return (QC (cPredefAbs,c))
       | otherwise     = checkError s
 
     ident alt c =
@@ -106,7 +105,8 @@ renameIdentTerm' env@(act,imps) t0 =
 
 info2status :: Maybe ModuleName -> Ident -> Info -> Term
 info2status mq c i = case i of
-  AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq c
+  AbsCat _ -> maybe Con (curry QC) mq c
+  AbsFun _ Nothing -> maybe Con (curry QC) mq c
   ResValue _ _ -> maybe Con (curry QC) mq c
   ResParam _ _ -> maybe Con (curry QC) mq c
   AnyInd True m -> maybe Con (const (curry QC m)) mq c
@@ -159,7 +159,7 @@ renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info
 renameInfo cwd status (m,mi) i info =
   case info of
     AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco)
-    AbsFun  pty pa ptr poper -> liftM4 AbsFun (renTerm pty) (return pa) (renMaybe (mapM (renLoc (renEquation status))) ptr) (return poper)
+    AbsFun  pty ptr -> liftM2 AbsFun (renTerm pty) (renMaybe (\(a,eqs) -> fmap ((,) a) (mapM (renLoc (renEquation status)) eqs)) ptr)
     ResOper pty ptr -> liftM2 ResOper (renTerm pty) (renTerm ptr)
     ResOverload os tysts -> liftM (ResOverload os) (mapM (renPair (renameTerm status [])) tysts)
     ResParam (Just pp) m -> do
@@ -218,6 +218,13 @@ renameTerm env vars = ren vars where
         _ -> return i
       liftM (T i') $ mapM (renCase vs) cs
 
+    RecType rs -> do
+      rs <- forM rs $ \(l,deps,t) -> do
+              t <- renameTerm env (deps++vs) t
+              let deps' = L.intersect deps (freeVars vs t)
+              return (l,deps',t)
+      return (RecType rs)
+
     Let (x,(m,a)) b -> do
       m' <- case m of
         Just ty -> liftM Just $ ren vs ty
@@ -255,6 +262,11 @@ renameTerm env vars = ren vars where
     return (p',t')
   renpatt = renamePattern env
 
+  freeVars xs (Abs _ x e) = freeVars (x:xs) e
+  freeVars xs (Vr x)
+    | not (elem x xs)     = [x]
+  freeVars xs e           = collectOp (freeVars xs) e
+
 -- | vars not needed in env, since patterns always overshadow old vars
 renamePattern :: Status -> Patt -> Check (Patt,[Ident])
 renamePattern env patt =
@@ -293,7 +305,8 @@ renamePattern env patt =
                 _      -> checkError ("not a pattern macro" <+> ppPatt Qualified 0 patt)
         return (PM c', [])
 
-      PV x -> checks [ renid' (Vr x) >>= \t' -> case t' of
+      PV x | x /= identW
+           -> checks [ renid' (Vr x) >>= \t' -> case t' of
                                                  QC c -> return (PP c [],[])
                                                  _    -> checkError (pp "not a constructor")
                      , return (patt, [x])
@@ -327,6 +340,10 @@ renamePattern env patt =
         (p',vs) <- renp p
         return (PAs x p', x:vs)
 
+      PImplArg p -> do
+        (p,vs) <- renp p
+        return (PImplArg p, vs)
+
       _ -> return (patt,[])
 
     renid = renameIdentTerm env

src/compiler/api/GF/Compile/SubExOpt.hs

@@ -31,6 +31,7 @@ import qualified GF.Grammar.Macros as C
 import GF.Data.ErrM(fromErr)
 
 import Control.Monad.State.Strict(State,evalState,get,put)
+import Data.Maybe(isJust)
 import Data.Map (Map)
 import qualified Data.Map as Map
 
@@ -136,6 +137,6 @@ operIdent :: Int -> Ident
 operIdent i = identC (operPrefix `prefixRawIdent` (rawIdentS (show i))) ---
 
 isOperIdent :: Ident -> Bool
-isOperIdent id = isPrefixOf operPrefix (ident2raw id)
+isOperIdent id = isJust (isPrefixOf operPrefix (ident2raw id))
 
 operPrefix = rawIdentS ("A''")

src/compiler/api/GF/Compile/Tags.hs

@@ -28,8 +28,8 @@ getLocalTags x (m,mi) =
   where
     getLocations :: Info -> [(String,String,String)]
     getLocations (AbsCat mb_ctxt)               = maybe (loc "cat")          mb_ctxt
-    getLocations (AbsFun mb_type _ mb_eqs _)    = maybe (ltype "fun")        mb_type ++
+    getLocations (AbsFun mb_type mb_eqs)        = maybe (ltype "fun")        mb_type ++
-                                                  maybe (list (loc "def"))   mb_eqs  
+                                                  maybe (list (loc "def") . snd) mb_eqs  
     getLocations (ResParam mb_params _)         = maybe (loc "param")        mb_params
     getLocations (ResValue mb_type _)           = ltype "param-value"          mb_type
     getLocations (ResOper  mb_type mb_def)      = maybe (ltype "oper-type")  mb_type ++

src/compiler/api/GF/Compile/TerminationCheck.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE BangPatterns #-}
+module GF.Compile.TerminationCheck where
+
+import GF.Grammar
+import Debug.Trace
+
+callGraph m c (ps,t) =
+  let (_,xs) = foldl (\(i,xs) p -> (i+1,patts i EQ xs p)) (0,[]) ps
+      cs     = calls m 0 xs t [] []
+  in trace (show (c,cs)) $ return ()
+
+patts i ord xs (PP _ ps)    = foldl (patts i LT) xs ps
+patts i ord xs (PV x)
+  | x /= identW             = (x,(i,ord)):xs
+patts i ord xs (PR as)      = foldl (\xs (_,p) -> patts i ord xs p) xs as
+patts i ord xs (PT ty p)    = patts i ord xs p
+patts i ord xs (PAs x p)    = patts i ord ((x,(i,ord)):xs) p
+patts i ord xs (PImplArg p) = patts i ord xs p
+patts i ord xs (PSeq _ _ p1 _ _ p2) = patts i LT (patts i LT xs p1) p2
+patts i ord xs _            = xs
+
+
+calls m i xs (App t1 t2) args cs =
+  let args' = case t2 of
+                Vr x -> case lookup x xs of
+                          Just (j,ord) -> (i,j,ord):args
+                          Nothing -> args
+                _    -> args
+  in calls m (i+1) xs t1 args' (calls m 0 xs t2 [] cs)
+calls m i xs (Q (m',q)) args cs
+  | m == m' =
+      let args' = [(i-i'-1,j,ord) | (i',j,ord) <- args]
+      in (q,args') : cs
+calls m i xs _ args cs = cs
+
+
+matmul a b =
+  sum [(i,k,mul ord1 ord2) | (i ,j,ord1) <- a
+                           , (j',k,ord2) <- b
+                           , j==j'
+                           ]
+      []
+  where
+    sum []                 ys = ys
+    sum (x@(i,k,ord) : xs) ys = sum xs (accumulate ys)
+      where
+        accumulate []      = [x]
+        accumulate (y@(i',k',ord') : ys)
+          | i==i' && k==k' = let !sum = add ord ord'
+                             in (i',k',sum):ys
+          | otherwise      = y : accumulate ys
+
+    add LT LT = LT
+    add LT EQ = LT
+    add LT GT = LT
+    add EQ LT = LT
+    add EQ EQ = EQ
+    add EQ GT = EQ
+    add GT LT = LT
+    add GT EQ = EQ
+    add GT GT = GT
+
+    mul LT LT = LT
+    mul LT EQ = LT
+    mul LT GT = GT
+    mul EQ LT = LT
+    mul EQ EQ = EQ
+    mul EQ GT = GT
+    mul GT LT = GT
+    mul GT EQ = GT
+    mul GT GT = GT

src/compiler/api/GF/Compile/TypeCheck/Abstract.hs

@@ -1,82 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : TypeCheck
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/09/15 16:22:02 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.16 $
---
--- (Description of the module)
------------------------------------------------------------------------------
-
-module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly.
-    checkContext,
-    checkTyp,
-    checkDef,
-    checkConstrs,
-   ) where
-
-import GF.Data.Operations
-
-import GF.Infra.CheckM
-import GF.Grammar
-import GF.Grammar.Lookup
-import GF.Grammar.Unify
---import GF.Compile.Refresh
---import GF.Compile.Compute.Abstract
-import GF.Compile.TypeCheck.TC
-
-import GF.Text.Pretty
---import Control.Monad (foldM, liftM, liftM2)
-
--- | invariant way of creating TCEnv from context
-initTCEnv gamma =
-  (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
-
--- interface to TC type checker
-
-type2val :: Type -> Val
-type2val = VClos []
-
-cont2exp :: Context -> Term
-cont2exp c = mkProd c eType [] -- to check a context
-
-cont2val :: Context -> Val
-cont2val = type2val . cont2exp
-
--- some top-level batch-mode checkers for the compiler
-
-justTypeCheck :: SourceGrammar -> Term -> Val -> Err Constraints
-justTypeCheck gr e v = do
-  (_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v
-  (constrs1,_) <- unifyVal constrs0
-  return $ filter notJustMeta constrs1
-
-notJustMeta (c,k) = case (c,k) of
-    (VClos g1 (Meta m1), VClos g2 (Meta m2)) -> False
-    _ -> True
-
-grammar2theory :: SourceGrammar -> Theory
-grammar2theory gr (m,f) = case lookupFunType gr m f of
-  Ok t -> return $ type2val t
-  Bad s -> case lookupCatContext gr m f of
-    Ok cont -> return $ cont2val cont
-    _ -> Bad s
-
-checkContext :: SourceGrammar -> Context -> [Message]
-checkContext st = checkTyp st . cont2exp
-
-checkTyp :: SourceGrammar -> Type -> [Message]
-checkTyp gr typ = err (\x -> [pp x]) ppConstrs $ justTypeCheck gr typ vType
-
-checkDef :: SourceGrammar -> Fun -> Type -> Equation -> [Message]
-checkDef gr (m,fun) typ eq = err (\x -> [pp x]) ppConstrs $ do
-  (b,cs) <- checkBranch (grammar2theory gr) (initTCEnv []) eq (type2val typ)
-  (constrs,_) <- unifyVal cs
-  return $ filter notJustMeta constrs
-
-checkConstrs :: SourceGrammar -> Cat -> [Ident] -> [String]
-checkConstrs gr cat _ = [] ---- check constructors!

src/compiler/api/GF/Compile/TypeCheck/TC.hs

@@ -1,324 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : TC
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/10/02 20:50:19 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.11 $
---
--- Thierry Coquand's type checking algorithm that creates a trace
------------------------------------------------------------------------------
-
-module GF.Compile.TypeCheck.TC (
-    AExp(..),
-    Theory,
-    checkExp,
-    inferExp,
-    checkBranch,
-    eqVal,
-    whnf
-  ) where
-
-import GF.Data.Operations
-import GF.Grammar
-import GF.Grammar.Predef
-
-import Control.Monad
---import Data.List (sortBy)
-import Data.Maybe
-import GF.Text.Pretty
-
-data AExp =
-     AVr   Ident Val
-   | ACn   QIdent Val
-   | AType
-   | AInt  Integer
-   | AFloat Double
-   | AStr  String
-   | AMeta MetaId Val
-   | ALet  (Ident,(Val,AExp)) AExp
-   | AApp  AExp AExp Val
-   | AAbs  Ident Val AExp
-   | AProd Ident AExp AExp
--- -- | AEqs  [([Exp],AExp)] --- not used
-   | ARecType [ALabelling]
-   | AR    [AAssign]
-   | AP    AExp Label Val
-   | AGlue AExp AExp
-   | AData Val
-  deriving (Eq,Show)
-
-type ALabelling = (Label, AExp)
-type AAssign = (Label, (Val, AExp))
-
-type Theory = QIdent -> Err Val
-
-lookupConst :: Theory -> QIdent -> Err Val
-lookupConst th f = th f
-
-lookupVar :: Env -> Ident -> Err Val
-lookupVar g x = maybe (Bad (render ("unknown variable" <+> x))) return $ lookup x ((identW,VClos [] (Meta 0)):g)
--- wild card IW: no error produced, ?0 instead.
-
-type TCEnv = (Int,Env,Env)
-
---emptyTCEnv :: TCEnv
---emptyTCEnv = (0,[],[])
-
-whnf :: Val -> Err Val
-whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug
-         case v of
-  VApp u w -> do
-    u' <- whnf u
-    w' <- whnf w
-    app u' w'
-  VClos env e -> eval env e
-  _ -> return v
-
-app :: Val -> Val -> Err Val
-app u v = case u of
-  VClos env (Abs _ x e) -> eval ((x,v):env) e
-  _ -> return $ VApp u v
-
-eval :: Env -> Term -> Err Val
-eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
-             case e of
-  Vr x    -> lookupVar env x
-  Q c   -> return $ VCn c
-  QC c  -> return $ VCn c ---- == Q ?
-  Sort c  -> return $ VType --- the only sort is Type
-  App f a -> join $ liftM2 app (eval env f) (eval env a)
-  RecType xs -> do xs <- mapM (\(l,e) -> eval env e >>= \e -> return (l,e)) xs
-                   return (VRecType xs)
-  _ -> return $ VClos env e
-
-eqVal :: Int -> Val -> Val -> Err [(Val,Val)]
-eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
-                do
-  w1 <- whnf u1
-  w2 <- whnf u2
-  let v = VGen k
-  case (w1,w2) of
-    (VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2)
-    (VClos env1 (Abs _ x1 e1), VClos env2 (Abs _ x2 e2)) ->
-      eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)
-    (VClos env1 (Prod _ x1 a1 e1), VClos env2 (Prod _ x2 a2 e2)) ->
-      liftM2 (++)
-        (eqVal k     (VClos            env1  a1) (VClos            env2  a2))
-        (eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2))
-    (VGen i _, VGen j _) -> return [(w1,w2) | i /= j]
-    (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
-    --- thus ignore qualifications; valid because inheritance cannot
-    --- be qualified. Simplifies annotation. AR 17/3/2005
-    _ -> return [(w1,w2) | w1 /= w2]
--- invariant: constraints are in whnf
-
-checkType :: Theory -> TCEnv -> Term -> Err (AExp,[(Val,Val)])
-checkType th tenv e = checkExp th tenv e vType
-
-checkExp :: Theory -> TCEnv -> Term -> Val -> Err (AExp, [(Val,Val)])
-checkExp th tenv@(k,rho,gamma) e ty = do
-  typ <- whnf ty
-  let v = VGen k
-  case e of
-    Meta m -> return $ (AMeta m typ,[])
-
-    Abs _ x t -> case typ of
-      VClos env (Prod _ y a b) -> do
-                           a' <- whnf $ VClos env a ---
-                           (t',cs) <- checkExp th
-                                          (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
-                           return (AAbs x a' t', cs)
-      _ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
-
-    Let (x, (mb_typ, e1)) e2 -> do
-      (val,e1,cs1) <- case mb_typ of
-                        Just typ -> do (_,cs1) <- checkType th tenv typ
-                                       val <- eval rho typ
-                                       (e1,cs2) <- checkExp th tenv e1 val
-                                       return (val,e1,cs1++cs2)
-                        Nothing  -> do (e1,val,cs) <- inferExp th tenv e1
-                                       return (val,e1,cs)
-      (e2,cs2) <- checkExp th (k,rho,(x,val):gamma) e2 typ
-      return (ALet (x,(val,e1)) e2, cs1++cs2)
-
-    Prod _ x a b -> do
-      testErr (typ == vType) "expected Type"
-      (a',csa) <- checkType th tenv a
-      (b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b
-      return (AProd x a' b', csa ++ csb)
-
-    R xs ->
-      case typ of
-        VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of
-                            [] -> return ()
-                            ls -> fail (render ("no value given for label:" <+> fsep (punctuate ',' ls)))
-                          r <- mapM (checkAssign th tenv ys) xs
-                          let (xs,css) = unzip r
-                          return (AR xs, concat css)
-        _           -> Bad (render ("record type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
-
-    P r l -> do (r',cs) <- checkExp th tenv r (VRecType [(l,typ)])
-                return (AP r' l typ,cs)
-
-    Glue x y -> do cs1 <- eqVal k valAbsFloat typ
-                   (x,cs2) <- checkExp th tenv x typ
-                   (y,cs3) <- checkExp th tenv y typ
-                   return (AGlue x y,cs1++cs2++cs3)
-    _ -> checkInferExp th tenv e typ
-
-checkInferExp :: Theory -> TCEnv -> Term -> Val -> Err (AExp, [(Val,Val)])
-checkInferExp th tenv@(k,_,_) e typ = do
-  (e',w,cs1) <- inferExp th tenv e
-  cs2 <- eqVal k w typ
-  return (e',cs1 ++ cs2)
-
-inferExp :: Theory -> TCEnv -> Term -> Err (AExp, Val, [(Val,Val)])
-inferExp th tenv@(k,rho,gamma) e = case e of
-   Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
-   Q (m,c) | m == cPredefAbs && isPredefCat c
-                     -> return (ACn (m,c) vType, vType, [])
-           | otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c)
-   QC c -> mkAnnot (ACn c) $ noConstr $ lookupConst th c ----
-   EInt i -> return (AInt i, valAbsInt, [])
-   EFloat i -> return (AFloat i, valAbsFloat, [])
-   K i -> return (AStr i, valAbsString, [])
-   Sort _ -> return (AType, vType, [])
-   RecType xs -> do r <- mapM (checkLabelling th tenv) xs
-                    let (xs,css) = unzip r
-                    return (ARecType xs, vType, concat css)
-   Let (x, (mb_typ, e1)) e2 -> do
-    (val1,e1,cs1) <- case mb_typ of
-                       Just typ -> do (_,cs1) <- checkType th tenv typ
-                                      val <- eval rho typ
-                                      (e1,cs2) <- checkExp th tenv e1 val
-                                      return (val,e1,cs1++cs2)
-                       Nothing  -> do (e1,val,cs) <- inferExp th tenv e1
-                                      return (val,e1,cs)
-    (e2,val2,cs2) <- inferExp th (k,rho,(x,val1):gamma) e2
-    return (ALet (x,(val1,e1)) e2, val2, cs1++cs2)
-   App f t -> do
-    (f',w,csf) <- inferExp th tenv f
-    typ <- whnf w
-    case typ of
-      VClos env (Prod _ x a b) -> do
-        (a',csa) <- checkExp th tenv t (VClos env a)
-        b' <- whnf $ VClos ((x,VClos rho t):env) b
-        return $ (AApp f' a' b', b', csf ++ csa)
-      _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
-   _ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e))
-
-checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)])
-checkLabelling th tenv (lbl,typ) = do
-  (atyp,cs) <- checkType th tenv typ
-  return ((lbl,atyp),cs)
-
-checkAssign :: Theory -> TCEnv -> [(Label,Val)] -> Assign -> Err (AAssign, [(Val,Val)])
-checkAssign th tenv@(k,rho,gamma) typs (lbl,(Just typ,exp)) = do
-  (atyp,cs1) <- checkType th tenv typ
-  val <- eval rho typ
-  cs2 <- case lookup lbl typs of
-           Nothing   -> return []
-           Just val0 -> eqVal k val val0
-  (aexp,cs3) <- checkExp th tenv exp val
-  return ((lbl,(val,aexp)),cs1++cs2++cs3)
-checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do
-  case lookup lbl typs of
-    Nothing  -> do (aexp,val,cs) <- inferExp th tenv exp
-                   return ((lbl,(val,aexp)),cs)
-    Just val -> do (aexp,cs) <- checkExp th tenv exp val
-                   return ((lbl,(val,aexp)),cs)
-
-checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Term],AExp),[(Val,Val)])
-checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
-                                  chB tenv' ps' ty
- where
-
-  (ps',_,rho2,k') = ps2ts k ps
-  tenv' = (k, rho2++rho, gamma) ---- k' ?
-  (k,rho,gamma) = tenv
-
-  chB tenv@(k,rho,gamma) ps ty = case ps of
-    p:ps2 -> do
-      typ <- whnf ty
-      case typ of
-        VClos env (Prod _ y a b) -> do
-          a' <- whnf $ VClos env a
-          (p', sigma, binds, cs1) <- checkP tenv p y a'
-          let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
-          ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
-          return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
-        _ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ))
-    [] -> do
-      (e,cs) <- checkExp th tenv t ty
-      return (([],e),cs)
-  checkP env@(k,rho,gamma) t x a = do
-     (delta,cs) <- checkPatt th env t a
-     let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]]
-     return (VClos sigma t, sigma, delta, cs)
-
-  ps2ts k = foldr p2t ([],0,[],k)
-  p2t p (ps,i,g,k) = case p of
-     PW      -> (Meta i : ps, i+1,g,k)
-     PV x    -> (Vr x   : ps, i, upd x k g,k+1)
-     PAs x p -> p2t p (ps,i,g,k)
-     PString s -> (K s : ps, i, g, k)
-     PInt n -> (EInt n : ps, i, g, k)
-     PFloat n -> (EFloat n : ps, i, g, k)
-     PP c xs -> (mkApp (Q c) xss : ps, j, g',k')
-                    where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
-     PImplArg p -> p2t p (ps,i,g,k)
-     PTilde t -> (t : ps, i, g, k)
-     _ -> error $ render ("undefined p2t case" <+> ppPatt Unqualified 0 p <+> "in checkBranch")
-
-  upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables
-
-
-checkPatt :: Theory -> TCEnv -> Term -> Val -> Err (Binds,[(Val,Val)])
-checkPatt th tenv exp val = do
-  (aexp,_,cs) <- checkExpP tenv exp val
-  let binds = extrBinds aexp
-  return (binds,cs)
- where
-   extrBinds aexp = case aexp of
-     AVr i v    -> [(i,v)]
-     AApp f a _ -> extrBinds f ++ extrBinds a
-     _ -> [] -- no other cases are possible
-
---- ad hoc, to find types of variables
-   checkExpP tenv@(k,rho,gamma) exp val = case exp of
-     Meta m -> return $ (AMeta m val, val, [])
-     Vr x   -> return $ (AVr   x val, val, [])
-     EInt i -> return (AInt i, valAbsInt, [])
-     EFloat i -> return (AFloat i, valAbsFloat, [])
-     K s    -> return (AStr s, valAbsString, [])
-
-     Q c  -> do
-       typ <- lookupConst th c
-       return $ (ACn c typ, typ, [])
-     QC c  -> do
-       typ <- lookupConst th c
-       return $ (ACn c typ, typ, []) ----
-     App f t -> do
-       (f',w,csf) <- checkExpP tenv f val
-       typ <- whnf w
-       case typ of
-         VClos env (Prod _ x a b) -> do
-           (a',_,csa) <- checkExpP tenv t (VClos env a)
-           b' <- whnf $ VClos ((x,VClos rho t):env) b
-           return $ (AApp f' a' b', b', csf ++ csa)
-         _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
-     _ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))
-
--- auxiliaries
-
-noConstr :: Err Val -> Err (Val,[(Val,Val)])
-noConstr er = er >>= (\v -> return (v,[]))
-
-mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)])
-mkAnnot a ti = do
-  (v,cs) <- ti
-  return (a v, v, cs)

src/compiler/api/GF/Compile/Update.hs

@@ -82,7 +82,7 @@ extendModule cwd gr (name,m)
 -- | rebuilding instance + interface, and "with" modules, prior to renaming.
 -- AR 24/10/2003
 rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
-rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs js_)) =
+rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ js_)) =
   checkInModule cwd mi NoLoc empty $ do
 
 ----  deps <- moduleDeps ms
@@ -119,7 +119,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs j
                     else MSIncomplete
       unless (stat' == MSComplete || stat == MSIncomplete)
              (checkError ("module" <+> i <+> "remains incomplete"))
-      ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
+      ModInfo mt0 _ fs me' _ ops0 _ fpath js <- lookupModule gr ext
       let ops1 = nub $
                    ops_ ++ -- N.B. js has been name-resolved already
                    [OQualif i j | (i,j) <- ops] ++
@@ -135,7 +135,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs j
                                     js
       let js1 = Map.union js0 js_
       let med1= nub (ext : infs ++ insts ++ med_)
-      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ mseqs js1
+      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ js1
 
   return (i,mi')
 
@@ -174,14 +174,14 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
       (b,n') = case info of
         ResValue _ _ -> (True,n)
         ResParam _ _ -> (True,n)
-        AbsFun _ _ Nothing _ -> (True,n)
+        AbsFun _ Nothing -> (True,n)
         AnyInd b k -> (b,k)
         _ -> (False,n) ---- canonical in Abs
 
 globalizeLoc fpath i =
   case i of
     AbsCat mc             -> AbsCat (fmap gl mc)
-    AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper
+    AbsFun mt md          -> AbsFun (fmap gl mt) (fmap (\(a,eqs) -> (a,fmap gl eqs)) md)
     ResParam mt mv        -> ResParam (fmap gl mt) mv
     ResValue t i          -> ResValue (gl t) i
     ResOper mt m          -> ResOper (fmap gl mt) (fmap gl m)
@@ -200,8 +200,8 @@ unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info
 unifyAnyInfo m i j = case (i,j) of
   (AbsCat mc1, AbsCat mc2) ->
     liftM AbsCat (unifyMaybeL mc1 mc2)
-  (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) ->
+  (AbsFun mt1 md1, AbsFun mt2 md2) ->
-    liftM4 AbsFun (unifyMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifyMaybe moper1 moper2) -- adding defs
+    liftM2 AbsFun (unifyMaybeL mt1 mt2) (unifAbsDefs md1 md2) -- adding defs
 
   (ResParam mt1 mv1, ResParam mt2 mv2) ->
     liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
@@ -214,7 +214,7 @@ unifyAnyInfo m i j = case (i,j) of
     liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2)
 
   (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
-    liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2)  (unifyMaybe mpmcfg1 mpmcfg2)
+    liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2) (unifyMaybe mpmcfg1 mpmcfg2)
   (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
     liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2)
 
@@ -229,10 +229,7 @@ unifyAnyInfo m i j = case (i,j) of
 unifyMaybeL :: Eq a => Maybe (L a) -> Maybe (L a) -> Err (Maybe (L a))
 unifyMaybeL = unifyMaybeBy unLoc
 
-unifAbsArrity :: Maybe Int -> Maybe Int -> Err (Maybe Int)
+unifAbsDefs :: Maybe (Int,[L Equation]) -> Maybe (Int,[L Equation]) -> Err (Maybe (Int,[L Equation]))
-unifAbsArrity = unifyMaybe
+unifAbsDefs (Just (_,xs)) (Just (_,ys)) = return (Just (0,xs ++ ys))
-
+unifAbsDefs Nothing       Nothing       = return Nothing
-unifAbsDefs :: Maybe [L Equation] -> Maybe [L Equation] -> Err (Maybe [L Equation])
+unifAbsDefs _             _             = fail ""
-unifAbsDefs (Just xs) (Just ys) = return (Just (xs ++ ys))
-unifAbsDefs Nothing   Nothing   = return Nothing
-unifAbsDefs _         _         = fail ""

src/compiler/api/GF/Compiler.hs

@@ -1,7 +1,7 @@
 module GF.Compiler (mainGFC, writeGrammar, writeOutputs) where
 
 import PGF2
-import PGF2.Transactions
+import PGF2.Transactions hiding (Rule(..))
 import GF.Compile as S(batchCompile,link,srcAbsName)
 import GF.CompileInParallel as P(parallelBatchCompile)
 import GF.Compile.Export
@@ -11,11 +11,10 @@ import GF.Compile.CFGtoPGF
 import GF.Compile.GetGrammar
 import GF.Grammar.BNFC
 import GF.Grammar.CFG
-import GF.Grammar.Grammar
+import GF.Grammar.Grammar hiding (Rule(..))
 import GF.Grammar.JSON(grammar2json)
 import GF.Grammar.Printer(TermPrintQual(..),ppModule)
 
---import GF.Infra.Ident(showIdent)
 import GF.Infra.UseIO
 import GF.Infra.Option
 import GF.Infra.CheckM

src/compiler/api/GF/Data/Operations.hs

@@ -35,9 +35,6 @@ module GF.Data.Operations (
      prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
      numberedParagraphs, prConjList, prIfEmpty, wrapLines,
 
-     -- ** Topological sorting
-     topoTest, topoTest2,
-
      -- ** Misc
      readIntArg,
      iterFix,  chunks,
@@ -53,7 +50,6 @@ import Control.Monad (liftM,liftM2) --,ap
 import Control.Monad.Fix
 
 import GF.Data.ErrM
-import GF.Data.Relation
 import qualified Control.Monad.Fail as Fail
 
 infixr 5 +++
@@ -188,26 +184,6 @@ wrapLines n s@(c:cs) =
                      l = length w
             _ -> s -- give up!!
 
--- | Topological sorting with test of cyclicity
-topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]]
-topoTest = topologicalSort . mkRel'
-
--- | Topological sorting with test of cyclicity, new version /TH 2012-06-26
-topoTest2 :: Ord a => [(a,[a])] -> Either [[a]] [[a]]
-topoTest2 g0 = maybe (Right cycles) Left (tsort g)
-  where
-    g = g0++[(n,[])|n<-nub (concatMap snd g0)\\map fst g0]
-
-    cycles = findCycles (mkRel' g)
-
-    tsort nes =
-      case partition (null.snd) nes of
-        ([],[]) -> Just []
-        ([],_) -> Nothing
-        (ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest]
-            where leaves = map fst ns
-
-
 -- | Fix point iterator (for computing e.g. transitive closures or reachability)
 iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
 iterFix more start = iter start start

src/compiler/api/GF/Data/XML.hs

@@ -4,7 +4,7 @@
 --
 -- Utilities for creating XML documents.
 ----------------------------------------------------------------------
-module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML, parseXML) where
+module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, showsNospaceXML, bottomUpXML, parseXML) where
 
 import Data.Char(isSpace)
 import Numeric (readHex)
@@ -38,6 +38,17 @@ showsXML = showsX 0 where
     (Empty) -> id
   ind i = showString ("\n" ++ replicate (2*i) ' ')
 
+showsNospaceXML :: XML -> ShowS
+showsNospaceXML x = case x of
+    (Data s) -> showString (escape s)
+    (ETag t as) -> showChar '<' . showString t . showsAttrs as . showString "/>"
+    (Tag t as cs) ->
+      showChar '<' . showString t . showsAttrs as . showChar '>' .
+      concatS (map showsNospaceXML cs) .
+      showString "</" . showString t . showChar '>'
+    (Comment c) -> showString "<!-- " . showString c . showString " -->"
+    (Empty) -> id
+
 showsAttrs :: [Attr] -> ShowS
 showsAttrs = concatS . map (showChar ' ' .) . map showsAttr
 

src/compiler/api/GF/Grammar.hs

@@ -14,7 +14,6 @@
 
 module GF.Grammar
            ( module GF.Grammar.Grammar,
-             module GF.Grammar.Values,
              module GF.Grammar.Macros,
              module GF.Grammar.Parser,
              module GF.Grammar.Printer,
@@ -23,7 +22,6 @@ module GF.Grammar
            ) where
 
 import GF.Grammar.Grammar
-import GF.Grammar.Values
 import GF.Grammar.Macros
 import GF.Grammar.Parser
 import GF.Grammar.Printer

src/compiler/api/GF/Grammar/Analyse.hs

@@ -27,7 +27,7 @@ stripSourceGrammar sgr = mGrammar [(i, m{jments = Map.map stripInfo (jments m)})
 stripInfo :: Info -> Info
 stripInfo i = case i of
   AbsCat _ -> i
-  AbsFun mt mi me mb -> AbsFun mt mi Nothing mb
+  AbsFun mt me -> AbsFun mt Nothing
   ResParam mp mt -> ResParam mp Nothing
   ResValue lt _ -> i ----
   ResOper mt md -> ResOper mt Nothing
@@ -87,9 +87,9 @@ sizeTerm t = case t of
   Table a c    -> 1 + sizeTerm a + sizeTerm c
   ExtR a c     -> 1 + sizeTerm a + sizeTerm c
   R r          -> 1 + sum [1 + sizeTerm a | (_,(_,a)) <- r]  -- label counts as 1, type ignored
-  RecType r    -> 1 + sum [1 + sizeTerm a | (_,a)     <- r]  -- label counts as 1
+  RecType r    -> 1 + sum [1 + sizeTerm a | (_,_,a)   <- r]  -- label counts as 1
   P t i        -> 2 + sizeTerm t
-  T _ cc       -> 1 + sum [1 + sizeTerm (patt2term p) + sizeTerm v | (p,v) <- cc]
+  T _ cc       -> 1 + sum [1 + sizePatt p + sizeTerm v | (p,v) <- cc]
   V ty cc      -> 1 + sizeTerm ty + sum [1 + sizeTerm v | v <- cc]
   Let (x,(mt,a)) b -> 2 + maybe 0 sizeTerm mt + sizeTerm a + sizeTerm b
   C s1 s2      -> 1 + sizeTerm s1 + sizeTerm s2 
@@ -99,13 +99,25 @@ sizeTerm t = case t of
   Strs tt      -> 1 + sum (map sizeTerm tt)
   _            -> 1
 
+sizePatt :: Patt -> Int
+sizePatt p = case p of
+  PC c pp   -> 1 + sum (map sizePatt pp)
+  PP c pp   -> 1 + sum (map sizePatt pp)
+  PR r      -> 1 + sum [sizePatt p | (l,p) <- r]
+  PT _ p    -> sizePatt p
+  PAs _ p   -> sizePatt p
+  PSeq _ _ a _ _ b  -> 1 + sizePatt a + sizePatt b
+  PAlt a b  -> 1 + sizePatt a + sizePatt b
+  PRep _ _ a-> 1 + sizePatt a
+  PNeg a    -> 1 + sizePatt a
+  _         -> 1
 
 -- the size of a judgement
 sizeInfo :: Info -> Int
 sizeInfo i = case i of
   AbsCat (Just (L _ co)) -> 1 + sum [1 + sizeTerm ty | (_,_,ty) <- co]
-  AbsFun mt mi me mb -> 1 + msize mt + 
+  AbsFun mt me -> 1 + msize mt + 
-    sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es]
+    sum [sum (map sizePatt ps) + sizeTerm t | Just (_,es) <- [me], L _ (ps,t) <- es]
   ResParam mp mt -> 
     1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co) <- ps]
   ResValue _ _ -> 0

src/compiler/api/GF/Grammar/Binary.hs

@@ -23,7 +23,6 @@ import GF.Infra.UseIO(MonadIO(..))
 import GF.Grammar.Grammar
 
 import PGF2(Literal(..))
-import PGF2.Transactions(Symbol(..))
 
 -- Please change this every time when the GFO format is changed
 gfoVersion = "GF05"
@@ -33,9 +32,9 @@ instance Binary Grammar where
   get = fmap mGrammar get
 
 instance Binary ModuleInfo where
-  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,mseqs mi,jments mi)
+  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,jments mi)
-  get    = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get
+  get    = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,jments) <- get
-              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments)
+              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc jments)
 
 instance Binary ModuleType where
   put MTAbstract       = putWord8 0
@@ -100,13 +99,13 @@ instance Binary PArg where
   put (PArg x y) = put (x,y)
   get = get >>= \(x,y) -> return (PArg x y)
 
-instance Binary Production where
+instance Binary Rule where
-  put (Production ps args res rules) = put (ps,args,res,rules)
+  put (Rule v w x y z) = put (v,w,x,y,z)
-  get = get >>= \(ps,args,res,rules) -> return (Production ps args res rules)
+  get = get >>= \(v,w,x,y,z) -> return (Rule v w x y z)
 
 instance Binary Info where
   put (AbsCat x)       = putWord8 0 >> put x
-  put (AbsFun w x y z) = putWord8 1 >> put (w,x,y,z)
+  put (AbsFun x y)     = putWord8 1 >> put (x,y)
   put (ResParam x y)   = putWord8 2 >> put (x,y)
   put (ResValue x y)   = putWord8 3 >> put (x,y)
   put (ResOper x y)    = putWord8 4 >> put (x,y)
@@ -117,7 +116,7 @@ instance Binary Info where
   get = do tag <- getWord8
            case tag of
              0 -> get >>= \x         -> return (AbsCat x)
-             1 -> get >>= \(w,x,y,z) -> return (AbsFun w x y z)
+             1 -> get >>= \(x,y)     -> return (AbsFun x y)
              2 -> get >>= \(x,y)     -> return (ResParam x y)
              3 -> get >>= \(x,y)     -> return (ResValue x y)
              4 -> get >>= \(x,y)     -> return (ResOper x y)
@@ -225,7 +224,6 @@ instance Binary Patt where
   put (PC x y)     = putWord8  0 >> put (x,y)
   put (PP x y)     = putWord8  1 >> put (x,y)
   put (PV x)       = putWord8  2 >> put x
-  put (PW)         = putWord8  3
   put (PR x)       = putWord8  4 >> put x
   put (PString x)  = putWord8  5 >> put x
   put (PInt    x)  = putWord8  6 >> put x
@@ -247,7 +245,6 @@ instance Binary Patt where
              0  -> get >>= \(x,y)   -> return (PC x y)
              1  -> get >>= \(x,y)   -> return (PP x y)
              2  -> get >>= \x       -> return (PV x)
-             3  ->                     return (PW)
              4  -> get >>= \x       -> return (PR x)
              5  -> get >>= \x       -> return (PString x)
              6  -> get >>= \x       -> return (PInt    x)
@@ -369,7 +366,7 @@ decodeModuleHeader :: MonadIO io => FilePath -> io (VersionTagged Module)
 decodeModuleHeader = liftIO . fmap (fmap conv) . decodeFile'
   where
     conv (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) =
-        (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty)
+        (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Map.empty)
 
 encodeModule :: MonadIO io => FilePath -> SourceModule -> io ()
 encodeModule fpath mo = liftIO $ encodeFile fpath (Tagged mo)

src/compiler/api/GF/Grammar/Grammar.hs

@@ -65,7 +65,7 @@ module GF.Grammar.Grammar (
         Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
 
         -- ** PMCFG        
-        LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..)
+        LIndex,LVar,LParam(..),PArg(..),Symbol(..),Rule(..)
         ) where
 
 import GF.Infra.Ident
@@ -75,8 +75,9 @@ import GF.Infra.Location
 import GF.Data.Operations
 
 import PGF2(BindType(..),PGF)
-import PGF2.Transactions(SeqId,LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..))
+import PGF2.Transactions(LIndex,LVar,LParam(..),PArg(..),Symbol(..),Rule(..))
 
+import Data.Graph
 import Data.Array.IArray(Array)
 import Data.Array.Unboxed(UArray)
 import qualified Data.Map as Map
@@ -103,7 +104,6 @@ data ModuleInfo
     mopens  :: [OpenSpec],
     mexdeps :: [ModuleName],
     msrc    :: FilePath,
-    mseqs   :: Maybe (Seq.Seq [Symbol]),
     jments  :: Map.Map Ident Info
    }
  | ModPGF {
@@ -278,9 +278,10 @@ isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
 -- | all abstract modules sorted from least to most dependent
 allAbstracts :: Grammar -> [ModuleName]
 allAbstracts gr =
- case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of
+ let scc = stronglyConnComp [(mn,mn,extends mo) | (mn,mo) <- modules gr, mtype mo == MTAbstract]
-   Left  is     -> is
+ in case [mns | CyclicSCC mns <- scc] of
-   Right cycles -> error $ render ("Cyclic abstract modules:" <+> vcat (map hsep cycles))
+      []     -> [mn | AcyclicSCC mn <- scc]
+      cycles -> error $ render ("Cyclic abstract modules:" <+> vcat (map hsep cycles))
 
 -- | the last abstract in dependency order (head of list)
 greatestAbstract :: Grammar -> Maybe ModuleName
@@ -322,8 +323,8 @@ allConcreteModules gr =
 -- and indirection to module (/INDIR/)
 data Info =
 -- judgements in abstract syntax
-   AbsCat   (Maybe (L Context))                                            -- ^ (/ABS/) context of a category
+   AbsCat   (Maybe (L Context))                         -- ^ (/ABS/) context of a category
- | AbsFun   (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) (Maybe Bool) -- ^ (/ABS/) type, arrity and definition of a function
+ | AbsFun   (Maybe (L Type)) (Maybe (Int,[L Equation])) -- ^ (/ABS/) type, arrity and definition of a function
 
 -- judgements in resource
  | ResParam (Maybe (L [Param])) (Maybe ([Term],Int)) -- ^ (/RES/) The second argument is list of all possible values
@@ -336,12 +337,12 @@ data Info =
  | ResOverload [ModuleName] [(L Type,L Term)]        -- ^ (/RES/) idents: modules inherited
 
 -- judgements in concrete syntax
- | CncCat  (Maybe (L Type))                     (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe ([Production],[Production])) -- ^ (/CNC/) lindef ini'zed, 
+ | CncCat  (Maybe (L Type))                     (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe ([Rule],[Rule])) -- ^ (/CNC/) lindef ini'zed, 
- | CncFun  (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term))                  (Maybe (L Term)) (Maybe [Production]) -- ^ (/CNC/) type info added at 'TC'
+ | CncFun  (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term))                  (Maybe (L Term)) (Maybe [Rule]) -- ^ (/CNC/) type info added at 'TC'
 
 -- indirection to module Ident
  | AnyInd Bool ModuleName                        -- ^ (/INDIR/) the 'Bool' says if canonical
-  deriving Show
+  deriving (Eq,Show)
 
 type Type    = Term
 type Cat     = QIdent
@@ -396,7 +397,7 @@ data Term =
 
  | FV [Term]                     -- ^ alternatives in free variation: @variants { s ; ... }@
 
- | Markup Ident [(Ident,Term)] [Term]
+ | Markup Ident [(Ident,Term)] [L Term]
  | Reset Ident (Maybe Term) Term (Maybe QIdent)
 
  | Alts Term [(Term, Term)]      -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
@@ -409,8 +410,7 @@ data Term =
 data Patt =
    PC Ident [Patt]        -- ^ constructor pattern: @C p1 ... pn@    @C@ 
  | PP QIdent [Patt]       -- ^ package constructor pattern: @P.C p1 ... pn@    @P.C@ 
- | PV Ident               -- ^ variable pattern: @x@
+ | PV Ident               -- ^ variable pattern: @x@ or wild card @_@
- | PW                     -- ^ wild card pattern: @_@
  | PR [(Label,Patt)]      -- ^ record pattern: @{r = p ; ...}@  -- only concrete
  | PString String         -- ^ string literal pattern: @\"foo\"@  -- only abstract
  | PInt    Integer        -- ^ integer literal pattern: @12@    -- only abstract
@@ -462,7 +462,7 @@ type Hypo     = (BindType,Ident,Type)   -- (x:A)  (_:A)  A  ({x}:A)
 type Context  = [Hypo]                  -- (x:A)(y:B)   (x,y:A)   (_,_:A)
 type Equation = ([Patt],Term) 
 
-type Labelling = (Label, Type) 
+type Labelling = (Label, [Ident], Type)
 type Assign = (Label, (Maybe Type, Term))
 type Option = (Maybe Term, Term)
 type Case = (Patt, Term) 

src/compiler/api/GF/Grammar/JSON.hs

@@ -34,11 +34,11 @@ info2json (AbsCat mb_ctxt) =
   case mb_ctxt of
     Nothing         -> makeObj []
     Just (L _ ctxt) -> makeObj [("context", showJSON (map hypo2json ctxt))]
-info2json (AbsFun mb_ty mb_arity mb_eqs _) =
+info2json (AbsFun mb_ty mb_eqs) =
   (makeObj . catMaybes)
      [ fmap (\(L _ ty) -> ("abstype",term2json ty)) mb_ty
-     , fmap (\a -> ("arity",showJSON a)) mb_arity
+     , fmap (\(a,_)   -> ("arity",showJSON a)) mb_eqs
-     , fmap (\eqs -> ("equations",showJSON (map (\(L _ eq) -> equation2json eq) eqs))) mb_eqs
+     , fmap (\(_,eqs) -> ("equations",showJSON (map (\(L _ eq) -> equation2json eq) eqs))) mb_eqs
      ]
 info2json (ResParam mb_params _) =
   makeObj [("params", case mb_params of
@@ -102,7 +102,7 @@ term2json (Prod bt v t1 t2) = makeObj [("implicit", showJSON (bt==Implicit)), ("
 term2json (Typed t ty) = makeObj [("term", term2json t), ("type", term2json ty)]
 term2json (Example t s) = makeObj [("term", term2json t), ("example", showJSON s)]
 term2json (RecType lbls) = makeObj [("rectype", makeObj (map toRow lbls))]
-                              where toRow (l,t) = (showLabel l, term2json t)
+                              where toRow (l,_,t) = (showLabel l, term2json t)
 term2json (R lbls) = makeObj [("record", makeObj (map toRow lbls))]
                               where toRow (l,(_,t)) = (showLabel l, term2json t)
 term2json (P t proj) = makeObj [("project", term2json t), ("label", showJSON (showLabel proj))]
@@ -126,7 +126,7 @@ term2json (ELin id t) = makeObj [("lin",showJSON id), ("term",term2json t)]
 term2json (FV ts) = makeObj [("variants",showJSON (map term2json ts))]
 term2json (Markup tag attrs children) = makeObj [ ("tag",showJSON tag)
                                                 , ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json val)) attrs))
-                                                , ("children",showJSON (map term2json children))
+                                                , ("children",showJSON (map (term2json . unLoc) children))
                                                 ]
 term2json (Reset ctl ct t qid) =
   makeObj ([("ctl",showJSON ctl)]++maybe [] (\t->[("ct",term2json t)]) ct++[("term",term2json t), ("qid",showJSON qid)])
@@ -177,14 +177,14 @@ json2term o  = Vr      <$> o!:"vr"
     <|>        FV      <$> (o!:"variants" >>= mapM json2term)
     <|>        Markup  <$> (o!:"tag") <*>
                            (o!:"attrs" >>= mapM (\(attr,val) -> fmap ((,)attr) (json2term val))) <*>
-                           (o!:"children" >>= mapM json2term)
+                           (o!:"children" >>= mapM (fmap noLoc . json2term))
     <|>        Reset   <$> o!:"ctl" <*> fmap Just (o!<"ct") <*> o!<"term" <*> o!:"qid"
     <|>        Reset   <$> o!:"ctl" <*> pure Nothing <*> o!<"term" <*> o!:"qid"
     <|>        Alts    <$> (o!<"def") <*> (o!:"alts" >>= mapM (\(x,y) -> liftM2 (,) (json2term x) (json2term y)))
     <|>        Strs    <$> (o!:"strs" >>= mapM json2term)
     where
       fromRow  (lbl, jsvalue) = do value <- json2term jsvalue
-                                   return (readLabel lbl,value)
+                                   return (readLabel lbl,[],value)
 
       fromRow' (lbl, jsvalue) = do value <- json2term jsvalue
                                    return (readLabel lbl,(Nothing,value))
@@ -198,7 +198,6 @@ json2term o  = Vr      <$> o!:"vr"
 patt2json (PC id ps)     = makeObj [("pc",showJSON id),("args",showJSON (map patt2json ps))]
 patt2json (PP (mn,id) ps) = makeObj [("mod",showJSON mn),("pc",showJSON id),("args",showJSON (map patt2json ps))]
 patt2json (PV id)        = makeObj [("pv",showJSON id)]
-patt2json PW             = makeObj [("wildcard",showJSON True)]
 patt2json (PR lbls)      = makeObj (("record", showJSON True) : map toRow lbls)
                                where toRow (l,t) = (showLabel l, patt2json t)
 patt2json (PString s)    = showJSON s
@@ -231,7 +230,6 @@ json2patt :: JSValue -> Result Patt
 json2patt o = PP <$> (liftM2 (\mn id -> (mn,id)) (o!:"mod") (o!:"pc")) <*> (o!:"args" >>= mapM json2patt)
     <|>       PC <$> (o!:"pc") <*> (o!:"args" >>= mapM json2patt)
     <|>       PV <$> (o!:"pv")
-    <|>  (o!:"wildcard" >>= guard >> return PW)
     <|> (const PR) <$> (o!:"record" >>= guard) <*> mapM fromRow (assocsJSObject o)
     <|>  PString <$> readJSON o
     <|>  PInt    <$> readJSON o

src/compiler/api/GF/Grammar/Lockfield.hs

@@ -14,37 +14,35 @@
 -- AR 8\/2\/2005 detached from 'compile/MkResource'
 -----------------------------------------------------------------------------
 
-module GF.Grammar.Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where
+module GF.Grammar.Lockfield (lock, lockLabel, isLockLabel) where
 
 import GF.Infra.Ident
+import GF.Grammar.Predef
 import GF.Grammar.Grammar
-import GF.Grammar.Macros
 
 import GF.Data.Operations(ErrorMonad,Err(..))
 
-lockRecType :: ErrorMonad m => Ident -> Type -> m Type
+lock :: Ident -> Term -> Term
-lockRecType c t@(RecType rs) = 
+lock c t@(RecType rs) =
-  let lab = lockLabel c in
+  let lbl = lockLabel c
-  return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"]
+  in if elem lbl [l | (l,_,_)<-rs] || elem c [cString,cInt]
-    then t --- don't add an extra copy of lock field, nor predef cats
+       then t --- don't add an extra copy of lock field, nor predef cats
-    else RecType (rs ++ [(lockLabel c,  RecType [])])
+       else RecType (rs ++ [(lbl, [], RecType [])])
-lockRecType c t = plusRecType t $ RecType [(lockLabel c,  RecType [])]
+lock c t@(R rs) =
-
+  let lbl = lockLabel c
-unlockRecord :: Monad m => Ident -> Term -> m Term
+  in if elem lbl (map fst rs)
-unlockRecord c ft = do
+       then t
-  let (xs,t) = termFormCnc ft
+       else R (rs ++ [(lbl, (Just (RecType []),R []))])
-  let lock = R [(lockLabel c,  (Just (RecType []),R []))]
+lock c (Abs b x t) = Abs b x (lock c t)
-  case plusRecord t lock of
+lock c (FV ts)     = FV (map (lock c) ts)
-    Ok t' -> return $ mkAbs xs t'
+lock c t           = t
-    _ -> return $ mkAbs xs (ExtR t lock)
 
 lockLabel :: Ident -> Label
 lockLabel c = LIdent $! prefixRawIdent lockPrefix (ident2raw c)
 
-isLockLabel :: Label -> Bool
+isLockLabel :: Label -> Maybe RawIdent
 isLockLabel l = case l of
   LIdent c -> isPrefixOf lockPrefix c
-  _        -> False
+  _        -> Nothing
-
 
 lockPrefix = rawIdentS "lock_"

src/compiler/api/GF/Grammar/Lookup.hs

@@ -23,9 +23,10 @@ module GF.Grammar.Lookup (
            lookupResType,
            lookupOverload,
            lookupOverloadTypes,
-           lookupParamValues,
            allParamValues,
+           countParamValues,
            lookupAbsDef,
+           lookupAbsType,
            lookupLincat,
            lookupFunType,
            lookupCatContext,
@@ -45,10 +46,6 @@ import GF.Text.Pretty
 import qualified Data.Map as Map
 import qualified PGF2
 
--- whether lock fields are added in reuse
-lock c = lockRecType c -- return
-unlock c = unlockRecord c -- return
-
 -- to look up a constant etc in a search tree --- why here? AR 29/5/2008
 lookupIdent :: ErrorMonad m => Ident -> Map.Map Ident b -> m b
 lookupIdent c t =
@@ -77,7 +74,8 @@ lookupIdentInfo (m,ModPGF{mpgf=pgf})   i =
     appHypos []                  xs t es =
       foldl (appExpr xs) t es
     appHypos ((bt, v, ty):hypos) xs t es =
-      let x = identS v in Prod bt x (cnvType xs ty) (appHypos hypos (x:xs) t es)
+      let x = if v == "_" then identW else identS v
+      in Prod bt x (cnvType xs ty) (appHypos hypos (x:xs) t es)
 
     appExpr xs t e = App t (cnvExpr xs e)
 
@@ -101,7 +99,7 @@ lookupQIdentInfo gr (m,c) = do
 
 lookupResDef :: ErrorMonad m => Grammar -> QIdent -> m Term
 lookupResDef gr (m,c)
-  | isPredefCat c = lock c defLinType
+  | isPredefCat c = return (lock c defLinType)
   | otherwise     = look m c
   where
     look m c = do
@@ -109,10 +107,10 @@ lookupResDef gr (m,c)
       case info of
         ResOper _ (Just (L _ t)) -> return t
         ResOper _ Nothing  -> return (Q (m,c))
-        CncCat (Just (L _ ty)) _ _ _ _ -> lock c ty
+        CncCat (Just (L _ ty)) _ _ _ _ -> return (lock c ty)
-        CncCat _ _ _ _ _         -> lock c defLinType
+        CncCat _ _ _ _ _        -> return (lock c defLinType)
 
-        CncFun (Just (_,cat,_,_)) (Just (L _ tr)) _ _ -> unlock cat tr
+        CncFun (Just (_,cat,_,_)) (Just (L _ tr)) _ _ -> return (lock cat tr)
         CncFun _                  (Just (L _ tr)) _ _ -> return tr
 
         AnyInd _ n        -> look n c
@@ -128,9 +126,8 @@ lookupResType gr (m,c) = do
 
     -- used in reused concrete
     CncCat _ _ _ _ _ -> return typeType
-    CncFun (Just (_,cat,cont,val)) _ _ _ -> do
+    CncFun (Just (args,cat,cont,val)) _ _ _ ->
-          val' <- lock cat val
+           return $ (mkFunType (zipWith (\cat (_,_,ty) -> lock cat ty) args cont) (lock cat val))
-          return $ mkProd cont val' []
     AnyInd _ n        -> lookupResType gr (n,c)
     ResParam _ _    -> return typePType
     ResValue (L _ t) _ -> return t
@@ -145,8 +142,7 @@ lookupOverloadTypes gr id@(m,c) = do
     -- used in reused concrete
     CncCat _ _ _ _ _ -> ret typeType
     CncFun (Just (_,cat,cont,val)) _ _ _ -> do
-          val' <- lock cat val
+          ret $ mkProd cont (lock cat val) []
-          ret $ mkProd cont val' []
     ResParam _ _    -> ret typePType
     ResValue (L _ t) _ -> ret t
     ResOverload os tysts -> do
@@ -186,39 +182,57 @@ allOrigInfos gr m = fromErr [] $ do
     ModInfo{jments=jments} -> return [((m,c),i) | (c,_) <- Map.toList jments, Ok (m,i) <- [lookupOrigInfo gr (m,c)]]
     _                      -> return []
 
-lookupParamValues :: ErrorMonad m => Grammar -> QIdent -> m [Term]
-lookupParamValues gr c = do
-  (_,info) <- lookupOrigInfo gr c
-  case info of
-    ResParam _ (Just (pvs,_)) -> return pvs
-    _                         -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
-
 allParamValues :: ErrorMonad m => Grammar -> Type -> m [Term]
-allParamValues cnc ptyp =
+allParamValues gr ptyp =
   case ptyp of
     _ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
-    QC c -> lookupParamValues cnc c
+    QC c -> do (_,info) <- lookupOrigInfo gr c
-    Q  c -> lookupResDef cnc c >>= allParamValues cnc
+               case info of
+                 ResParam _ (Just (pvs,_)) -> return pvs
+                 _                         -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
+    Q  c -> lookupResDef gr c >>= allParamValues gr
     RecType r -> do
-       let (ls,tys) = unzip $ sortByFst r
+       let (ls,lls,tys) = unzip3 $ sortByLbl r
-       tss <- mapM (allParamValues cnc) tys
+       tss <- mapM (allParamValues gr) tys
        return [R (zipAssign ls ts) | ts <- sequence tss]
     Table pt vt -> do
-       pvs <- allParamValues cnc pt
+       pvs <- allParamValues gr pt
-       vvs <- allParamValues cnc vt
+       vvs <- allParamValues gr vt
        return [V pt ts | ts <- sequence (replicate (length pvs) vvs)]
     _ -> raise (render ("cannot find parameter values for" <+> ptyp))
   where
     -- to normalize records and record types
-    sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
+    sortByLbl = sortBy (\(l1,_,_) (l2,_,_) -> compare l1 l2)
 
-lookupAbsDef :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m (Maybe Int,Maybe [Equation])
+countParamValues :: ErrorMonad m => Grammar -> Type -> m Int
-lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
+countParamValues gr ptyp =
-  info <- lookupQIdentInfo gr (m,c)
+  case ptyp of
+    _ | Just n <- isTypeInts ptyp -> return (fromIntegral n+1)
+    QC c -> do (_,info) <- lookupOrigInfo gr c
+               case info of
+                 ResParam _ (Just (_,cnt)) -> return cnt
+                 _                         -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
+    Q  c -> lookupResDef gr c >>= countParamValues gr
+    RecType r -> do
+       let (ls,lls,tys) = unzip3 $ sortByLbl r
+       cs <- mapM (countParamValues gr) tys
+       return (product cs)
+    Table pt vt -> do
+       pc <- countParamValues gr pt
+       vc <- countParamValues gr vt
+       return (vc ^ pc)
+    _ -> raise (render ("cannot find parameter values for" <+> ptyp))
+  where
+    -- to normalize records and record types
+    sortByLbl = sortBy (\(l1,_,_) (l2,_,_) -> compare l1 l2)
+
+lookupAbsDef :: ErrorMonad m => Grammar -> QIdent -> m (Maybe (Int,[Equation]))
+lookupAbsDef gr q@(m,c) = errIn (render ("looking up absdef of" <+> c)) $ do
+  info <- lookupQIdentInfo gr q
   case info of
-    AbsFun _ a d _ -> return (a,fmap (map unLoc) d)
+    AbsFun a d -> return (fmap (\(a,eqs) -> (a,map unLoc eqs)) d)
-    AnyInd _ n     -> lookupAbsDef gr n c
+    AnyInd _ n -> lookupAbsDef gr (n,c)
-    _              -> return (Nothing,Nothing)
+    _          -> return Nothing
 
 lookupLincat :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Type
 lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
@@ -230,13 +244,31 @@ lookupLincat gr m c = do
     _                             -> raise (render (c <+> "has no linearization type in" <+> m))
 
 -- | this is needed at compile time
-lookupFunType :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Type
+lookupAbsType :: ErrorMonad m => Grammar -> QIdent -> m (Term,Type)
-lookupFunType gr m c = do
+lookupAbsType gr q@(m,c)
-  info <- lookupQIdentInfo gr (m,c)
+  | m == cPredefAbs =
+      if elem c [cInt,cFloat,cString]
+        then return (QC q,typeType)
+        else no_type
+  | otherwise = do
+      info <- lookupQIdentInfo gr q
+      case info of
+        AbsCat (Just (L _ co))         -> return (QC q,mkProd co typeType [])
+        AbsFun (Just (L _ t)) Nothing  -> return (QC q,t)
+        AbsFun (Just (L _ t)) (Just _) -> return (Q q,t)
+        AnyInd _ n                     -> lookupAbsType gr (n,c)
+        _                              -> no_type
+  where
+    no_type = raise (render ("cannot find type of" <+> c))
+
+-- | this is needed at compile time
+lookupFunType :: ErrorMonad m => Grammar -> QIdent -> m Type
+lookupFunType gr q@(m,c) = do
+  info <- lookupQIdentInfo gr q
   case info of
-    AbsFun (Just (L _ t)) _ _ _ -> return t
+    AbsFun (Just (L _ t)) _ -> return t
-    AnyInd _ n                  -> lookupFunType gr n c
+    AnyInd _ n              -> lookupFunType gr (n,c)
-    _                           -> raise (render ("cannot find type of" <+> c))
+    _                       -> raise (render ("cannot find type of" <+> c))
 
 -- | this is needed at compile time
 lookupCatContext :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Context
@@ -260,18 +292,14 @@ allOpers gr =
   ]
   where
     typesIn info = case info of
-      AbsFun  (Just ltyp) _ _ _ -> [ltyp]
+      AbsFun  (Just ltyp) _     -> [ltyp]
       ResOper (Just ltyp) _     -> [ltyp]
       ResValue ltyp _           -> [ltyp]
       ResOverload _ tytrs       -> [ltyp | (ltyp,_) <- tytrs]
       CncFun  (Just (_,i,ctx,typ)) _ _ _ ->
-                                   [L NoLoc (mkProdSimple ctx (lock' i typ))]
+                                   [L NoLoc (mkProdSimple ctx (lock i typ))]
       _                         -> []
 
-    lock' i typ = case lock i typ of
-                    Ok t -> t
-                    _ -> typ
-
 --- not for dependent types
 allOpersTo :: Grammar -> Type -> [(QIdent,Type,Location)]
 allOpersTo gr ty = [op | op@(_,typ,_) <- allOpers gr, isProdTo ty typ] where

src/compiler/api/GF/Grammar/Macros.hs

@@ -28,10 +28,12 @@ import GF.Grammar.Printer
 import Control.Monad.Identity(Identity(..))
 import qualified Data.Traversable as T(mapM)
 import qualified Data.Map as Map
-import Control.Monad (liftM, liftM2, liftM3)
+import Control.Monad (liftM, liftM2, liftM3, forM)
-import Data.List (sortBy,nub)
+import Data.List (nub)
+import Data.Maybe (fromMaybe)
 import Data.Monoid
-import GF.Text.Pretty(render,(<+>),hsep,fsep)
+import Data.Graph
+import GF.Text.Pretty(render,(<+>),($$),hsep,fsep,vcat,nest)
 import qualified Control.Monad.Fail as Fail
 
 -- ** Functions for constructing and analysing source code terms.
@@ -179,6 +181,9 @@ mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
 mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv))
   where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v)
 
+mapLabellingM :: Monad m => (Term -> m c) -> [Labelling] -> m [(Label,[Ident],c)]
+mapLabellingM f = mapM (\(l,deps,t) -> f t >>= \t -> return (l,deps,t))
+
 mapAttrs :: Monad m => (Term -> m c) -> [(Ident,Term)] -> m [(Ident,c)]
 mapAttrs f []          = return []
 mapAttrs f ((id,t):as) = do t  <- f t
@@ -193,7 +198,7 @@ mkRecord :: (Int -> Label) -> [Term] -> Term
 mkRecord = mkRecordN 0
 
 mkRecTypeN :: Int -> (Int -> Label) -> [Type] -> Type
-mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs]
+mkRecTypeN int lab typs = RecType [(lab i, [], t) | (i,t) <- zip [int..] typs]
 
 mkRecType :: (Int -> Label) -> [Type] -> Type
 mkRecType = mkRecTypeN 0
@@ -260,7 +265,7 @@ tuple2record :: [Term] -> [Assign]
 tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]
 
 tuple2recordType :: [Term] -> [Labelling]
-tuple2recordType ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
+tuple2recordType ts = [(tupleLabel i,[],t) | (i,t) <- zip [1..] ts]
 
 tuple2recordPatt :: [Patt] -> [(Label,Patt)]
 tuple2recordPatt ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
@@ -277,7 +282,7 @@ mkFunType tt t = mkProd [(Explicit,identW, ty) | ty <- tt] t [] -- nondep prod
 --plusRecType :: Type -> Type -> Err Type
 plusRecType t1 t2 = case (t1, t2) of
   (RecType r1, RecType r2) -> case
-    filter (`elem` (map fst r1)) (map fst r2) of
+    filter (`elem` [l | (l,_,_) <- r1]) [l | (l,_,_) <- r2] of
       [] -> return (RecType (r1 ++ r2))
       ls -> raise $ render ("clashing labels" <+> hsep ls)
   _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
@@ -293,7 +298,7 @@ plusRecord t1 t2 =
 
 -- | default linearization type
 defLinType :: Type
-defLinType = RecType [(theLinLabel,  typeStr)]
+defLinType = RecType [(theLinLabel, [], typeStr)]
 
 -- | refreshing variables
 mkFreshVar :: [Ident] -> Ident -> Ident
@@ -308,83 +313,6 @@ mkFreshVar olds x =
 mkFreshVarX :: [Ident] -> Ident -> Ident
 mkFreshVarX olds x = if (elem x olds) then (varX (maximum ((-1) : (map varIndex olds)) + 1)) else x
 
--- *** Term and pattern conversion
-
-term2patt :: Term -> Err Patt
-term2patt trm = case termForm trm of
-  Ok ([], Vr x, []) | x == identW -> return PW
-                    | otherwise   -> return (PV x)
-  Ok ([], Con c, aa) -> do
-    aa' <- mapM term2patt aa
-    return (PC c aa')
-  Ok ([], QC  c, aa) -> do
-    aa' <- mapM term2patt aa
-    return (PP c aa')
-
-  Ok ([], Q c, []) -> do
-    return (PM c)
-
-  Ok ([], R r, []) -> do
-    let (ll,aa) = unzipR r
-    aa' <- mapM term2patt aa
-    return (PR (zip ll aa'))
-  Ok ([],EInt i,[]) -> return $ PInt i
-  Ok ([],EFloat i,[]) -> return $ PFloat i
-  Ok ([],K s,   []) -> return $ PString s
-
---- encodings due to excessive use of term-patt convs. AR 7/1/2005
-  Ok ([], Cn id, [Vr a,b]) | id == cAs -> do
-    b' <- term2patt b
-    return (PAs a b')
-  Ok ([], Cn id, [a]) | id == cNeg  -> do
-    a' <- term2patt a
-    return (PNeg a')
-  Ok ([], Cn id, [a]) | id == cRep -> do
-    a' <- term2patt a
-    return (PRep 0 Nothing a')
-  Ok ([], Cn id, []) | id == cRep -> do
-    return PChar
-  Ok ([], Cn id,[K s]) | id == cChars  -> do
-    return $ PChars s
-  Ok ([], Cn id, [a,b]) | id == cSeq -> do
-    a' <- term2patt a
-    b' <- term2patt b
-    return (PSeq 0 Nothing a' 0 Nothing b')
-  Ok ([], Cn id, [a,b]) | id == cAlt -> do
-    a' <- term2patt a
-    b' <- term2patt b
-    return (PAlt a' b')
-
-  Ok ([], Cn c, []) -> do
-    return (PMacro c)
-
-  _ -> Bad $ render ("no pattern corresponds to term" <+> ppTerm Unqualified 0 trm)
-
-patt2term :: Patt -> Term
-patt2term pt = case pt of
-  PV x      -> Vr x
-  PW        -> Vr identW             --- not parsable, should not occur
-  PMacro c  -> Cn c
-  PM c      -> Q c
-
-  PC c pp   -> mkApp (Con c) (map patt2term pp)
-  PP c pp   -> mkApp (QC  c) (map patt2term pp)
-
-  PR r      -> R [assign l (patt2term p) | (l,p) <- r]
-  PT _ p    -> patt2term p
-  PInt i    -> EInt i
-  PFloat i  -> EFloat i
-  PString s -> K s
-
-  PAs x p   -> appCons cAs    [Vr x, patt2term p]            --- an encoding
-  PChar     -> appCons cChar  []                             --- an encoding
-  PChars s  -> appCons cChars [K s]                          --- an encoding
-  PSeq _ _ a _ _ b  -> appCons cSeq   [(patt2term a), (patt2term b)] --- an encoding
-  PAlt a b  -> appCons cAlt   [(patt2term a), (patt2term b)] --- an encoding
-  PRep _ _ a-> appCons cRep   [(patt2term a)]                --- an encoding
-  PNeg a    -> appCons cNeg   [(patt2term a)]                --- an encoding
-
-
 -- *** Almost compositional
 
 -- | to define compositional term functions
@@ -401,7 +329,7 @@ composOp co trm =
    S c a            -> liftM2 S (co c) (co a)
    Table a c        -> liftM2 Table (co a) (co c)
    R r              -> liftM R (mapAssignM co r)
-   RecType r        -> liftM RecType (mapPairsM co r)
+   RecType r        -> liftM RecType (mapLabellingM co r)
    P t i            -> liftM2 P (co t) (return i)
    ExtR a c         -> liftM2 ExtR (co a) (co c)
    Opts t os        -> liftM2 Opts (co t) (mapM (\(t1,t2) -> liftM2 (,) (maybe (return Nothing) (liftM Just . co) t1) (co t2)) os)
@@ -418,7 +346,7 @@ composOp co trm =
    ELincat c ty     -> liftM (ELincat c) (co ty)
    ELin c ty        -> liftM (ELin c) (co ty)
    ImplArg t        -> liftM ImplArg (co t)
-   Markup t as cs   -> liftM2 (Markup t) (mapAttrs co as) (mapM co cs)
+   Markup t as cs   -> liftM2 (Markup t) (mapAttrs co as) (mapM (mapM co) cs)
    Reset ctl ct t qid->liftM2 (\mb_ct t->Reset ctl ct t qid) (maybe (pure Nothing) (fmap Just . co) ct) (co t)
    Typed t ty       -> liftM2 Typed (co t) (co ty)
    _ -> return trm -- covers K, Vr, Cn, Sort, EPatt
@@ -452,8 +380,8 @@ collectOp co trm = case trm of
   Table a c    -> co a <> co c
   ExtR a c     -> co a <> co c
   Opts t os    -> co t <> mconcatMap (\(a,b) -> maybe mempty co a <> co b) os
-  R r          -> mconcatMap (\ (_,(mt,a)) -> maybe mempty co mt <> co a) r
+  R r          -> mconcatMap (\(_,(mt,a)) -> maybe mempty co mt <> co a) r
-  RecType r    -> mconcatMap (co . snd) r
+  RecType r    -> mconcatMap (\(_,_,t) -> co t) r
   P t i        -> co t
   T _ cc       -> mconcatMap (co . snd) cc -- not from patterns --- nor from type annot
   V _ cc       -> mconcatMap co         cc --- nor from type annot
@@ -466,7 +394,7 @@ collectOp co trm = case trm of
   Strs tt      -> mconcatMap co tt
   ELincat _ t  -> co t
   ELin _ t     -> co t
-  Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap co cs
+  Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap (co . unLoc) cs
   Reset _ ct t _-> maybe mempty co ct <> co t
   _            -> mempty -- covers K, Vr, Cn, Sort
 
@@ -524,58 +452,55 @@ changeTableType co i = case i of
     TWild ty  -> co ty >>= return . TWild
     _ -> return i
 
--- | normalize records and record types; put s first
-
-sortRec :: [(Label,a)] -> [(Label,a)]
-sortRec = sortBy ordLabel where
-  ordLabel (r1,_) (r2,_) =
-    case (showIdent (label2ident r1), showIdent (label2ident r2)) of
-      ("s",_) -> LT
-      (_,"s") -> GT
-      (s1,s2) -> compare s1 s2
-
 -- *** Dependencies
 
 -- | dependency check, detecting circularities and returning topo-sorted list
 
-allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])]
+allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,Info,[Ident])]
 allDependencies ism b =
-  [(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b]
+  [(f, i, nub (deps i)) | (f,i) <- Map.toList b]
   where
     opersIn t = case t of
       Q  (n,c) | ism n -> [c]
       QC (n,c) | ism n -> [c]
+      EPatt _ _ p -> opersInPatt p
+      T _ cs -> mconcatMap (\(p,t) -> opersInPatt p ++ opersIn t) cs
       _ -> collectOp opersIn t
+
+    constrsIn t = case t of
+      QC (n,c) | ism n -> [c]
+      _ -> collectOp constrsIn t
+
+    opersInPatt p = case p of
+      PP (n,c) ps      -> (if ism n then (:)c else id)
+                              (concatMap opersInPatt ps)
+      PTilde t         -> opersIn t
+      PM (n,c) | ism n -> [c]
+      _ -> collectPattOp opersInPatt p
+
     opty (Just (L _ ty)) = opersIn ty
     opty _ = []
-    pts i = case i of
+
-      ResOper pty pt -> [pty,pt]
+    deps i = case i of
-      ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
+      ResOper pty pt -> opty pty ++ opty pt
-      ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
+      ResOverload _ tyts -> concat [opersIn ty ++ opersIn tr | (L _ ty,L _ tr) <- tyts]
-      CncCat pty _ _ _ _ -> [pty]
+      ResParam (Just (L loc ps)) _ -> concat [opersIn  t | (_,cont) <- ps, (_,_,t) <- cont]
-      CncFun _   pt _ _ -> [pt]  ---- (Maybe (Ident,(Context,Type))
+      CncCat pty _ _ _ _ -> opty pty
-      AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual
+      CncFun _   pt _ _ -> opty pt
-      AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co]
+      AbsFun pty peqs -> opty pty ++ concat [concatMap opersInPatt ps++constrsIn t | L _ (ps,t) <- maybe [] snd peqs]
+      AbsCat (Just (L loc co)) -> concat [opersIn ty | (_,_,ty) <- co]
       _              -> []
 
 topoSortJments :: ErrorMonad m => SourceModule -> m [(Ident,Info)]
 topoSortJments (m,mi) = do
-  is <- either
+  let sccs = stronglyConnComp (map toNode (allDependencies (==m) (jments mi)))
-          return
+      cycles = [map fst jmts | CyclicSCC jmts <- sccs]
-          (\cyc -> raise (render ("circular definitions:" <+> fsep (head cyc))))
+  case cycles of
-          (topoTest (allDependencies (==m) (jments mi)))
+    [] -> return [jmt | AcyclicSCC jmt <- sccs]
-  return (reverse [(i,info) | i <- is, Just info <- [Map.lookup i (jments mi)]])
+    _  -> raise (render ("circular definitions:" $$
-
+                             nest 3 (vcat (map fsep cycles))))
-topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]]
+  where
-topoSortJments2 (m,mi) = do
+    toNode (id,info,deps) = ((id,info),id,deps)
-  iss <- either
-           return
-           (\cyc -> raise (render ("circular definitions:"
-                                   <+> fsep (head cyc))))
-           (topoTest2 (allDependencies (==m) (jments mi)))
-  return
-    [[(i,info) | i<-is,Just info<-[Map.lookup i (jments mi)]] | is<-iss]
-
 
 mkStrs p = case p of
  PAlt a b -> do

src/compiler/api/GF/Grammar/Parser.y

@@ -135,14 +135,14 @@ ModDef
                                           (opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) }
                                       jments <- mapM (checkInfoType mtype) jments
                                       defs <- buildAnyTree id jments
-                                      return (id, ModInfo mtype mstat opts extends with opens [] "" Nothing defs)  }
+                                      return (id, ModInfo mtype mstat opts extends with opens [] "" defs)  }
 
 ModHeader :: { SourceModule }
 ModHeader
   : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
                                                (mtype,id) = $2 ;
                                                (extends,with,opens) = $4 }
-                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing Map.empty) }
+                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" Map.empty) }
 
 ComplMod :: { ModuleStatus }
 ComplMod 
@@ -253,19 +253,18 @@ CatDef
 
 FunDef :: { [(Ident,Info)] }
 FunDef
-  : Posn ListIdent ':' Exp Posn { [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing (Just []) (Just True)) | fun <- $2] } 
+  : Posn ListIdent ':' Exp Posn { [(fun, AbsFun (Just (mkL $1 $5 $4)) (Just (0,[]))) | fun <- $2] }
 
 DefDef :: { [(Ident,Info)] }
 DefDef
-  : Posn LhsNames '=' Exp         Posn { [(f, AbsFun Nothing (Just 0)           (Just [mkL $1 $5 ([],$4)]) Nothing) | f <- $2] }
+  : Posn LhsNames '=' Exp            Posn { [(f, AbsFun Nothing (Just (0,[mkL $1 $5 ([],$4)]))) | f <- $2] }
-  | Posn LhsName ListPatt '=' Exp    Posn { [($2,AbsFun Nothing (Just (length $3)) (Just [mkL $1 $6 ($3,$5)]) Nothing)] }
+  | Posn LhsName ListPatt '=' Exp    Posn { [($2,AbsFun Nothing (Just (0,[mkL $1 $6 ($3,$5)])))] }
 
 DataDef :: { [(Ident,Info)] }
 DataDef
   : Posn Ident '=' ListDataConstr Posn { ($2,   AbsCat Nothing) :
-                                         [(fun, AbsFun Nothing Nothing Nothing  (Just True)) | fun <- $4] }
+                                         [(fun, AbsFun Nothing Nothing) | fun <- $4] }
-  | Posn ListIdent ':' Exp Posn        { -- (snd (valCat $4), AbsCat Nothing) :
+  | Posn ListIdent ':' Exp Posn        { [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing) | fun <- $2] }
-                                         [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing Nothing (Just True)) | fun <- $2] }                                         
 
 ParamDef :: { [(Ident,Info)] }
 ParamDef
@@ -294,6 +293,9 @@ FlagDef
   : Posn Ident '=' Ident Posn  {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ showIdent $4] of
                                     Ok  x   -> return x
                                     Bad msg -> failLoc $1 msg                                           } 
+  | Posn Ident '=' String Posn {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ $4] of
+                                    Ok  x   -> return x
+                                    Bad msg -> failLoc $1 msg                                           } 
   | Posn Ident '=' Double Posn {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ show $4] of
                                     Ok  x   -> return x
                                     Bad msg -> failLoc $1 msg                                           } 
@@ -381,18 +383,20 @@ LhsNames
   : LhsName              { [$1]    }
   | LhsName ',' LhsNames { $1 : $3 }
 
-LocDef :: { [(Ident, Maybe Type, Maybe Term)] }
+LocDef :: { [(Ident, Bool, Maybe Type, Maybe Term)] }
 LocDef
-  : ListIdent ':' Exp         { [(lab,Just $3,Nothing) | lab <- $1] } 
+  : '$' Ident ':' Exp         { [($2,True,Just $4,Nothing)] }
-  | ListIdent '=' Exp         { [(lab,Nothing,Just $3) | lab <- $1] }
+  | ListIdent ':' Exp         { [(lab,False,Just $3,Nothing) | lab <- $1] } 
-  | ListIdent ':' Exp '=' Exp { [(lab,Just $3,Just $5) | lab <- $1] }
+  | ListIdent '=' Exp         { [(lab,False,Nothing,Just $3) | lab <- $1] }
+  | ListIdent ':' Exp '=' Exp { [(lab,False,Just $3,Just $5) | lab <- $1] }
 
-LocMarkupDef :: { [(Ident, Maybe Type, Maybe Term)] }
+LocMarkupDef :: { [(Ident, Bool, Maybe Type, Maybe Term)] }
 LocMarkupDef
-  : ListIdent '=' Tag         { [(lab,Nothing,Just $3) | lab <- $1] }
+  : '$' Ident '=' Tag         { [($2,False,Nothing,Just $4)] }
-  | ListIdent ':' Exp '=' Tag { [(lab,Just $3,Just $5) | lab <- $1] }
+  | ListIdent '=' Tag         { [(lab,False,Nothing,Just $3) | lab <- $1] }
+  | ListIdent ':' Exp '=' Tag { [(lab,False,Just $3,Just $5) | lab <- $1] }
 
-ListLocDef :: { [(Ident, Maybe Type, Maybe Term)] }
+ListLocDef :: { [(Ident, Bool, Maybe Type, Maybe Term)] }
 ListLocDef
   : {- empty -}             { []       }
   | LocDef                  { $1       }
@@ -443,8 +447,8 @@ Exp3
   | 'table' Exp6 '{' ListCase '}'    { T (TTyped $2) $4 }
   | 'table' Exp6 '[' ListExp ']'     { V $2 $4       }
   | Exp3 '*'  Exp4                   { case $1 of
-                                         RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),$3)])
+                                         RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),[],$3)])
-                                         t          -> RecType [(tupleLabel 1,$1), (tupleLabel 2,$3)]  }
+                                         t          -> RecType [(tupleLabel 1,[],$1), (tupleLabel 2,[],$3)]  }
   | Exp3 '**' Exp4                   { ExtR $1 $3    }
   | Exp4                             { $1            }
 
@@ -479,9 +483,9 @@ Exp5
 
 Exp6 :: { Term }
 Exp6 
-  : Ident                 { Vr $1 } 
+  : Ident                 { Vr  $1 }
   | Sort                  { Sort $1 }
-  | String                { K $1 }
+  | String                { words2term (words $1) }
   | Integer               { EInt $1 }
   | Double                { EFloat $1 }
   | '?'                   { Meta 0 }
@@ -531,7 +535,7 @@ Patt3
   | '[' String ']'            { PChars $2 }
   | '#' Ident                 { PMacro $2 }
   | '#' ModuleName '.' Ident  { PM ($2,$4) }
-  | '_'                       { PW }
+  | '_'                       { PV identW }
   | Ident                     { PV $1 }
   | ModuleName '.' Ident      { PP ($1,$3) [] }
   | Integer                   { PInt $1 }
@@ -714,9 +718,11 @@ ERHS3 :: { ERHS }
   | '(' ERHS0 ')'         { $2         }
 
 NLG :: { Map.Map Ident Info }
-  : ListNLGDef             { Map.fromList $1 }
+  : ListNLGDef            { Map.fromList $1 }
-  | Posn Exp         Posn  { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $2))) }
+  | Posn Exp Posn         { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $2))) }
-  | Posn ListMarkup2 Posn  { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 (mkMarkup $2)))) }
+  | ListMarkup2           { case (head $1,last $1) of
+                              (L (Local l1 _) _, L (Local _ l2) _) -> Map.singleton (identS "main") (ResOper Nothing (Just (L (Local l1 l2) (mkMarkup $1))))
+                          }
 
 ListNLGDef :: { [(Ident,Info)] }
 ListNLGDef
@@ -730,10 +736,10 @@ NLGDef
   | Posn LhsName ListArg '=' ListMarkup2  Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing   (Just (mkL $1 $6 (mkAbs $3 (mkMarkup $5))))] }
   | Posn LhsNames ':' Exp '=' ListMarkup2 Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $7 $4)) (Just (mkL $1 $7 (mkMarkup $6)))] }
 
-Markup :: { Term }
+Markup :: { L Term }
 Markup
-  : Tag     { $1 }
+  : Posn Tag Posn     { mkL $1 $3 $2 }
-  | Exp ';' { $1 }
+  | Posn Exp Posn ';' { mkL $1 $3 $2 }
 
 Tag :: { Term }
 Tag
@@ -742,12 +748,12 @@ Tag
                                                        else fail ("Unmatched closing tag " ++ showIdent $1) }
   | '<tag' Attributes '/' '>'                     { Markup $1 $2 [] }
 
-ListMarkup :: { [Term] }
+ListMarkup :: { [L Term] }
   :                    { []      }
-  | Exp                { [$1]    }
+  | Posn Exp Posn      { [mkL $1 $3 $2] }
   | Markup ListMarkup  { $1 : $2 }
 
-ListMarkup2 :: { [Term] }
+ListMarkup2 :: { [L Term] }
   : Markup              { [$1]    }
   | Markup ListMarkup2  { $1 : $2 }
 
@@ -790,8 +796,8 @@ listCatDef (L loc (id,cont,size)) = [catd,nilfund,consfund]
     consId = mkConsId id
 
     catd     = (listId, AbsCat (Just (L loc cont')))
-    nilfund  = (baseId, AbsFun (Just (L loc niltyp))  Nothing Nothing (Just True))
+    nilfund  = (baseId, AbsFun (Just (L loc niltyp))  Nothing)
-    consfund = (consId, AbsFun (Just (L loc constyp)) Nothing Nothing (Just True))
+    consfund = (consId, AbsFun (Just (L loc constyp)) Nothing)
 
     cont' = [(b,mkId x i,ty) | (i,(b,x,ty)) <- zip [0..] cont]
     xs = map (\(b,x,t) -> Vr x) cont'
@@ -803,20 +809,23 @@ listCatDef (L loc (id,cont,size)) = [catd,nilfund,consfund]
 
     mkId x i = if x == identW then (varX i) else x
 
-tryLoc (c,mty,Just e) = return (c,(mty,e))
+tryLoc (c,False,mty,Just e) = return (c,(mty,e))
-tryLoc (c,_  ,_     ) = fail ("local definition of" +++ showIdent c +++ "without value")
+tryLoc (c,True ,_  ,_     ) = fail ("Scoped record label " +++ showIdent c +++ "outside of a record")
+tryLoc (c,_    ,_  ,_     ) = fail ("local definition of" +++ showIdent c +++ "without value")
 
 mkR []       = return $ RecType [] --- empty record always interpreted as record type
 mkR fs@(f:_) =
   case f of
-    (lab,Just ty,Nothing) -> mapM tryRT fs >>= return . RecType
+    (lab,_,Just ty,Nothing) ->   tryRT [] fs >>= return . RecType
-    _                     -> mapM tryR  fs >>= return . R
+    _                       -> mapM tryR  fs >>= return . R
   where
-    tryRT (lab,Just ty,Nothing) = return (ident2label lab,ty)
+    tryRT deps []                                = return []
-    tryRT (lab,_      ,_      ) = fail $ "illegal record type field" +++ showIdent lab --- manifest fields ?!
+    tryRT deps ((lab,scoped,Just ty,Nothing):fs) = do fs <- tryRT (if scoped then lab:deps else deps) fs
+                                                      return ((ident2label lab,deps,ty):fs)
+    tryRT deps ((lab,_     ,_      ,_      ):fs) = fail $ "illegal record type field" +++ showIdent lab --- manifest fields ?!
 
-    tryR (lab,mty,Just t) = return (ident2label lab,(mty,t))
+    tryR (lab,False,mty,Just t) = return (ident2label lab,(mty,t))
-    tryR (lab,_  ,_     ) = fail $ "illegal record field" +++ showIdent lab
+    tryR (lab,_    ,_  ,_     ) = fail $ "illegal record field" +++ showIdent lab
 
 mkOverload pdt pdf@(Just (L loc df)) =
   case appForm df of
@@ -844,12 +853,12 @@ isOverloading t =
 checkInfoType mt jment@(id,info) =
   case info of
     AbsCat pcont         -> ifAbstract mt (locPerh pcont)
-    AbsFun pty _ pde _   -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
+    AbsFun pty pde       -> ifAbstract mt (locPerh pty ++ maybe [] (locAll.snd) pde)
     CncCat pty pd pr ppn _->ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh pr ++ locPerh ppn)
     CncFun _   pd ppn _  -> ifConcrete mt (locPerh pd ++ locPerh ppn)
     ResParam pparam _    -> ifResource mt (locPerh pparam)
     ResValue ty _        -> ifResource mt (locL ty)
-    ResOper  pty pt      -> ifOper mt pty pt
+    ResOper  pty pt      -> ifResource mt (locPerh pty ++ locPerh pt)
     ResOverload _ xs     -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
   where
     locPerh = maybe [] locL
@@ -871,9 +880,6 @@ checkInfoType mt jment@(id,info) =
     ifResource MTResource     locs = return jment
     ifResource _              locs = illegal locs
 
-    ifOper MTAbstract pty pt = return (id,AbsFun pty (fmap (const 0) pt) (Just (maybe [] (\(L l t) -> [L l ([],t)]) pt)) (Just False))
-    ifOper _          pty pt = return jment
-
 mkAlts cs = case cs of
   _:_ -> do
     def  <- mkDef (last cs)
@@ -889,7 +895,11 @@ mkAlts cs = case cs of
 mkL :: Posn -> Posn -> x -> L x
 mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) x
 
-mkMarkup [t] = t
+mkMarkup [t] = unLoc t
 mkMarkup ts  = Markup identW [] ts
 
+words2term []     = Empty
+words2term [w]    = K w
+words2term (w:ws) = C (K w) (words2term ws)
+
 }

src/compiler/api/GF/Grammar/Predef.hs

@@ -25,6 +25,7 @@ cFloat = identS "Float"
 cString = identS "String"
 cInts = identS "Ints"
 cPBool = identS "PBool"
+cBool = identS "Bool"
 cErrorType = identS "Error"
 cOverload = identS "overload"
 cNonExist = identS "nonExist"
@@ -40,6 +41,8 @@ isPredefCat c = elem c [cInt,cString,cFloat]
 
 cPTrue  = identS "PTrue"
 cPFalse = identS "PFalse"
+cTrue  = identS "True"
+cFalse = identS "False"
 cLength = identS "length"
 cDrop = identS "drop"
 cTake = identS "take"
@@ -66,23 +69,11 @@ cConcat = identS "concat"
 cConcat' = identS "concat'"
 cOne = identS "one"
 cSelect = identS "select"
+cFilter = identS "filter"
 cDefault = identS "default"
 cList = identS "list"
 cLen = identS "len"
+cConst = identS "const"
 
 cp1 = identS "p1"
 cp2 = identS "p2"
-
--- * Hacks: dummy identifiers used in various places.
--- Not very nice!
-
-cMeta = identS "?"
-cAs = identS "@"
-cChar = identS "?"
-cChars = identS "[]"
-cSeq = identS "+"
-cAlt = identS "|"
-cRep = identS "*"
-cNeg = identS "-"
-cCNC = identS "CNC"
-cConflict = identS "#conflict"

src/compiler/api/GF/Grammar/Printer.hs

@@ -16,26 +16,23 @@ module GF.Grammar.Printer
            , ppParams
            , ppTerm
            , ppPatt
-           , ppValue
            , ppBind
-           , ppConstrs
            , ppQIdent
            , ppMeta
+           , ppLVar
            , getAbs
            ) where
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
 import PGF2(Literal(..),pgfFilePath)
-import PGF2.Transactions(SeqId)
 import GF.Infra.Ident
 import GF.Infra.Option
-import GF.Grammar.Values
 import GF.Grammar.Predef
 import GF.Grammar.Grammar
 
 import GF.Text.Pretty
 import Data.Maybe (isNothing)
-import Data.List  (intersperse)
+import Data.List  (intersperse, nub)
 import Data.Foldable (toList)
 import qualified Data.Map as Map
 import qualified Data.Sequence as Seq
@@ -49,11 +46,10 @@ instance Pretty Grammar where
   pp = vcat . map (ppModule Qualified) . modules
 
 ppModule :: TermPrintQual -> SourceModule -> Doc
-ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
+ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) =
     hdr $$
     nest 2 (ppOptions opts $$
-            vcat (map (ppJudgement q) (Map.toList jments)) $$
+            vcat (map (ppJudgement q) (Map.toList jments))) $$
-            maybe empty (ppSequences q) mseqs) $$
     ftr
     where
       hdr = complModDoc <+> modTypeDoc <+> '=' <+>
@@ -92,22 +88,21 @@ ppOptions opts =
   "flags" $$
   nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
 
-ppJudgement q (id, AbsCat pcont ) =
+ppJudgement q (id, AbsCat pcont) =
   "cat" <+> id <+>
   (case pcont of
      Just (L _ cont) -> hsep (map (ppDecl q) cont)
      Nothing         -> empty) <+> ';'
-ppJudgement q (id, AbsFun ptype _ pexp poper) =
+ppJudgement q (id, AbsFun ptype pexp) =
   let kind | isNothing pexp      = "data"
-           | poper == Just False = "oper"
            | otherwise           = "fun"
   in
   (case ptype of
      Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
      Nothing        -> empty) $$
   (case pexp of
-     Just []  -> empty
+     Just (_,[])  -> empty
-     Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
+     Just (_,eqs) -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
      Nothing  -> empty)
 ppJudgement q (id, ResParam pparams _) =
   "param" <+> id <+>
@@ -142,9 +137,9 @@ ppJudgement q (id, CncCat mtyp pdef pref pprn mpmcfg) =
      Nothing        -> empty) $$
   (case (mtyp,mpmcfg,q) of
      (Just (L _ typ),Just (lindefs,linrefs),Internal)
-                    -> "pmcfg" <+> '{' $$
+                    -> "rules" <+> '{' $$
-                       nest 2 (vcat (map (ppPmcfgRule (identS "lindef") [cString] id) lindefs)  $$
+                       nest 2 (vcat (map (ppPmcfgRule (identS "lindef") [cString] id) lindefs)) $$
-                               vcat (map (ppPmcfgRule (identS "linref") [id] cString) linrefs)) $$
+                       nest 2 (vcat (map (ppPmcfgRule (identS "linref") [id] cString) linrefs)) $$
                        '}'
      _              -> empty)
 ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) =
@@ -157,7 +152,7 @@ ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) =
      Nothing        -> empty) $$
   (case (mtyp,mpmcfg,q) of
      (Just (args,res,_,_),Just rules,Internal)
-                    -> "pmcfg" <+> '{' $$
+                    -> "rules" <+> '{' $$
                        nest 2 (vcat (map (ppPmcfgRule id args res) rules)) $$
                        '}'
      _              -> empty)
@@ -166,20 +161,22 @@ ppJudgement q (id, AnyInd cann mid) =
     Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
     _        -> empty
 
-ppPmcfgRule id arg_cats res_cat (Production vars args res seqids) =
-  pp id <+> (':' <+>
-             (if null vars
-                then empty
-                else "∀{" <> hsep (punctuate ',' [ppLVar v <> '<' <> m | (v,m) <- vars]) <> '}'  <+> '.') <+>
-             ppPmcfgCat res_cat res <+> "->" <+>
-             brackets (hcat (intersperse (pp ',') (zipWith ppPArg arg_cats args))) <+> '=' <+> 
-             brackets (hcat (intersperse (pp ',') (map ppSeqId seqids))))
-
 ppPArg cat (PArg _ p) = ppPmcfgCat cat p
 
 ppPmcfgCat :: Ident -> LParam -> Doc
 ppPmcfgCat cat p = pp cat <> parens (ppLParam p)
 
+ppPmcfgRule id arg_cats res_cat (Rule quantifiers res args lin_idx seq) =
+  ppQuantifiers (zip [0..] quantifiers) <+>
+  ppCat res_cat res <+> "->" <+> pp id <> brackets (hcat (punctuate ',' (zipWith ppCat arg_cats args))) <> ';' <+> ppLParam lin_idx <+> ':' <+> hsep (map ppSymbol seq)
+  where
+    ppCat id value = pp id <> parens (ppLParam value)
+
+    ppQuantifiers [] = empty
+    ppQuantifiers qs = pp '{' <> hsep (punctuate (pp ',') (map ppQuantifier qs)) <> pp '}'
+
+    ppQuantifier (var,range) = ppLVar var <> pp '<' <> pp (range::Int)
+
 instance Pretty Term where pp = ppTerm Unqualified 0
 
 ppTerm q d (Abs b v e)   = let (xs,e') = getAbs (Abs b v e)
@@ -244,12 +241,13 @@ ppTerm q d (R xs)      = braces (fsep (punctuate ';' [l <+>
                                                        fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
                                                              '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
 ppTerm q d (RecType xs)
-  | q == Terse         = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
+  | q == Terse         = case [cat | (l,_,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
                            [cat] -> pp cat
                            _     -> doc
   | otherwise          = doc
   where
-    doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
+    deps = nub [ident2label dep | (_,deps,_) <- xs, dep <- deps]
+    doc  = braces (fsep (punctuate ';' [(if l `elem` deps then pp '$' else empty) <> l <+> ':' <+> ppTerm q 0 t | (l,bound,t) <- xs]))
 ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
 ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
 ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
@@ -294,7 +292,6 @@ ppPatt q d (PChar)      = pp '?'
 ppPatt q d (PChars s)   = brackets (str s)
 ppPatt q d (PMacro id)  = '#' <> id
 ppPatt q d (PM id)      = '#' <> ppQIdent q id
-ppPatt q d PW           = pp '_'
 ppPatt q d (PV id)      = pp id
 ppPatt q d (PInt n)     = pp n
 ppPatt q d (PFloat f)   = pp f
@@ -303,22 +300,6 @@ ppPatt q d (PR xs)      = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0
 ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)
 ppPatt q d (PTilde t)   = prec d 2 ('~' <> ppTerm q 6 t)
 
-ppValue :: TermPrintQual -> Int -> Val -> Doc
-ppValue q d (VGen i x)    = x <> "{-" <> i <> "-}" ---- latter part for debugging
-ppValue q d (VApp u v)    = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
-ppValue q d (VCn (_,c))   = pp c
-ppValue q d (VClos env e) = case e of
-                              Meta _ -> ppTerm q d e <> ppEnv env
-                              _      -> ppTerm q d e ---- ++ prEnv env ---- for debugging
-ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs]))
-ppValue q d VType         = pp "Type"
-
-ppConstrs :: Constraints -> [Doc]
-ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w))
-
-ppEnv :: Env -> Doc
-ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
-
 str s = doubleQuotes (pp (foldr showLitChar "" s))
   where
     showLitChar c
@@ -326,13 +307,9 @@ str s = doubleQuotes (pp (foldr showLitChar "" s))
       | c > '\DEL'  = showChar c
       | otherwise   = GHC.Show.showLitChar c
 
-ppDecl q (_,id,typ)
+ppDecl q (bt,id,typ)
-  | id == identW = ppTerm q 3 typ
+  | id == identW = ppTerm q 5 typ
-  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
+  | otherwise    = parens (ppBind (bt,id) <+> ':' <+> ppTerm q 0 typ)
-
-ppDDecl q (_,id,typ)
-  | id == identW = ppTerm q 6 typ
-  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
 
 ppQIdent :: TermPrintQual -> QIdent -> Doc
 ppQIdent q (m,id) =
@@ -360,30 +337,18 @@ ppBind (Implicit,v) = braces v
 ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
 
 ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
-ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
+ppParam q (id,cxt) = id <+> hsep (map (ppDecl q) cxt)
 
 ppMarkupAttr q (id,e) =
   id <> pp '=' <> ppTerm q 5 e
 
-ppMarkupChildren q [t]    = ppTerm q 0 t
+ppMarkupChildren q [L _ t]    = ppTerm q 0 t
-ppMarkupChildren q (t:ts) =
+ppMarkupChildren q (L _ t:ts) =
   (case t of
      Markup {} -> ppTerm q 0 t
      _         -> ppTerm q 0 t <> ';') $$
   ppMarkupChildren q ts
 
-ppSeqId :: SeqId -> Doc
-ppSeqId seqid = 'S' <> pp seqid
-
-ppSequences q seqs
-  | Seq.null seqs || q /= Internal = empty
-  | otherwise                      = "sequences" <+> '{' $$
-                                     nest 2 (vcat (zipWith ppSeq [0..] (toList seqs))) $$
-                                    '}'
-  where
-    ppSeq seqid seq =
-      ppSeqId seqid <+> ":=" <+> hsep (map ppSymbol seq)
-
 commaPunct f ds = (hcat (punctuate "," (map f ds)))
 
 prec d1 d2 doc
@@ -398,8 +363,6 @@ getAbs e            = ([],e)
 getCTable :: Term -> ([Ident], Term)
 getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e
                                 in (v:vs,e')
-getCTable (T TRaw [(PW,  e)]) = let (vs,e') = getCTable e
-                                in (identW:vs,e')
 getCTable e                   = ([],e)
 
 getLet :: Term -> ([LocalDef], Term)

src/compiler/api/GF/Grammar/Unify.hs

@@ -1,115 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : Unify
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:22:31 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.4 $
---
--- (c) Petri Mäenpää & Aarne Ranta, 1998--2001
---
--- brute-force adaptation of the old-GF program AR 21\/12\/2001 ---
--- the only use is in 'TypeCheck.splitConstraints'
------------------------------------------------------------------------------
-
-module GF.Grammar.Unify (unifyVal) where
-
-import GF.Grammar
-import GF.Data.Operations
-
-import GF.Text.Pretty
-import Data.List (partition)
-
-unifyVal :: Constraints -> Err (Constraints,MetaSubst)
-unifyVal cs0 = do
-  let (cs1,cs2) = partition notSolvable cs0 
-  let (us,vs) = unzip cs2
-  let us' = map val2term us
-  let vs' = map val2term vs
-  let (ms,cs) = unifyAll (zip us' vs') []
-  return (cs1 ++ [(VClos [] t, VClos [] u) | (t,u) <- cs], 
-          [(m,          VClos [] t) | (m,t) <- ms])
- where
-   notSolvable (v,w) = case (v,w) of -- don't consider nonempty closures
-     (VClos (_:_) _,_) -> True
-     (_,VClos (_:_) _) -> True
-     _ -> False
-
-type Unifier = [(MetaId, Term)]
-type Constrs = [(Term, Term)]
-
-unifyAll :: Constrs -> Unifier -> (Unifier,Constrs)
-unifyAll [] g = (g, [])
-unifyAll ((a@(s, t)) : l) g =
-  let (g1, c) = unifyAll l g
-  in case unify s t g1 of
-       Ok g2  -> (g2, c)
-       _      -> (g1, a : c)
-
-unify :: Term -> Term -> Unifier -> Err Unifier
-unify e1 e2 g = 
- case (e1, e2) of 
-  (Meta s, t) -> do
-     tg <- subst_all g t
-     let sg = maybe e1 id (lookup s g)
-     if (sg == Meta s) then extend g s tg else unify sg tg g 
-  (t, Meta s) -> unify e2 e1 g
-  (Q (_,a), Q (_,b)) | (a == b)  -> return g ---- qualif?
-  (QC (_,a), QC (_,b)) | (a == b)-> return g ----
-  (Vr x, Vr y) | (x == y)        -> return g 
-  (Abs _ x b, Abs _ y c)         -> do let c' = substTerm [x] [(y,Vr x)] c 
-                                       unify b c' g
-  (App c a, App d b)            -> case unify c d g of 
-                                     Ok g1 -> unify a b g1 
-                                     _     -> Bad (render ("fail unify" <+> ppTerm Unqualified 0 e1))
-  (RecType xs,RecType ys) | xs == ys -> return g
-  _                             -> Bad (render ("fail unify" <+> ppTerm Unqualified 0 e1))
-
-extend :: Unifier -> MetaId -> Term -> Err Unifier
-extend g s t | (t == Meta s) = return g  
-             | occCheck s t  = Bad (render ("occurs check" <+> ppTerm Unqualified 0 t))
-             | True          = return ((s, t) : g) 
-
-subst_all :: Unifier -> Term -> Err Term
-subst_all s u =
- case (s,u) of
-  ([], t)  -> return t
-  (a : l, t) -> do
-     t' <- (subst_all l t) --- successive substs - why ?
-     return $ substMetas [a] t'
-
-substMetas :: [(MetaId,Term)] -> Term -> Term
-substMetas subst trm = case trm of
-   Meta x -> case lookup x subst of
-     Just t -> t
-     _ -> trm
-   _ -> composSafeOp (substMetas subst) trm
-
-substTerm  :: [Ident] -> Substitution -> Term -> Term
-substTerm ss g c = case c of
-  Vr x        -> maybe c id $ lookup x g
-  App f a     -> App (substTerm ss g f) (substTerm ss g a)
-  Abs b x t   -> let y = mkFreshVarX ss x in 
-                   Abs b y (substTerm (y:ss) ((x, Vr y):g) t)
-  Prod b x a t  -> let y = mkFreshVarX ss x in 
-                   Prod b y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) t)
-  _           -> c
-
-occCheck :: MetaId -> Term -> Bool
-occCheck s u = case u of
-    Meta v  -> s == v
-    App c a -> occCheck s c || occCheck s a
-    Abs _ x b -> occCheck s b
-    _       -> False
-
-val2term :: Val -> Term
-val2term v = case v of
-  VClos g e   -> substTerm [] (map (\(x,v) -> (x,val2term v)) g) e
-  VApp f c    -> App (val2term f) (val2term c)
-  VCn c       -> Q c
-  VGen i x    -> Vr x
-  VRecType xs -> RecType (map (\(l,v) -> (l,val2term v)) xs)
-  VType       -> typeType

src/compiler/api/GF/Grammar/Values.hs

@@ -1,57 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : Values
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:22:32 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.7 $
---
--- (Description of the module)
------------------------------------------------------------------------------
-
-module GF.Grammar.Values (
-               -- ** Values used in TC type checking
-               Val(..), Env,
-               -- ** Annotated tree used in editing
-               Binds, Constraints, MetaSubst,
-               -- ** For TC
-               valAbsInt, valAbsFloat, valAbsString, vType,
-               isPredefCat,
-               eType,
-              ) where
-
-import GF.Infra.Ident
-import GF.Grammar.Grammar
-import GF.Grammar.Predef
-
--- values used in TC type checking
-
-data Val = VGen Int Ident | VApp Val Val | VCn QIdent | VRecType [(Label,Val)] | VType | VClos Env Term
-  deriving (Eq,Show)
-
-type Env = [(Ident,Val)]
-
-type Binds = [(Ident,Val)]
-type Constraints = [(Val,Val)]
-type MetaSubst = [(MetaId,Val)]
-
-
--- for TC
-
-valAbsInt :: Val
-valAbsInt = VCn (cPredefAbs, cInt)
-
-valAbsFloat :: Val
-valAbsFloat = VCn (cPredefAbs, cFloat)
-
-valAbsString :: Val
-valAbsString = VCn (cPredefAbs, cString)
-
-vType :: Val
-vType = VType
-
-eType :: Term
-eType = Sort cType

src/compiler/api/GF/Infra/Ident.hs

@@ -26,10 +26,10 @@ module GF.Infra.Ident (-- ** Identifiers
 ) where
 
 import qualified Data.ByteString.UTF8 as UTF8
-import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
+import qualified Data.ByteString.Char8 as BS(append,isPrefixOf,drop,length)
                  -- Limit use of BS functions to the ones that work correctly on
                  -- UTF-8-encoded bytestrings!
-import Data.Char(isDigit)
+import Data.Char(chr)
 import Data.Binary(Binary(..))
 import Text.JSON hiding (Result(..))
 import GF.Text.Pretty
@@ -75,7 +75,9 @@ rawIdentC = Id
 showRawIdent = unpack . rawId2utf8
 
 prefixRawIdent (Id x) (Id y) = Id (BS.append x y)
-isPrefixOf (Id x) (Id y) = BS.isPrefixOf x y
+isPrefixOf (Id x) (Id y)
+ | BS.isPrefixOf x y = Just (Id (BS.drop (BS.length x) y))
+ | otherwise         = Nothing
 
 instance Binary Ident where
   put id = put (ident2utf8 id)
@@ -102,7 +104,26 @@ ident2raw = Id . ident2utf8
 showIdent :: Ident -> String
 showIdent i = unpack $! ident2utf8 i
 
-instance Pretty Ident where pp = pp . showIdent
+instance Pretty Ident where
+  pp id
+    | valid_ident s = pp s
+    | otherwise     = pp (escape s)
+    where
+      s = showIdent id
+
+      valid_ident s =
+        case s of
+          [] -> False
+          (c:cs) -> elem c ident_first && all (flip elem ident_rest) cs
+        where
+          l = ['a'..'z']++['A'..'Z']++[chr 192..chr 214]++[chr 216..chr 246]++[chr 248..chr 255]
+          ident_first = '_':l
+          ident_rest  = ident_first ++ ['0'..'9'] ++ ['\'']
+
+      escape s = "\'"++concatMap slash s++"\'"
+        where
+          slash '\'' = "\\'"
+          slash c    = [c]
 
 instance Pretty RawIdent where pp = pp . showRawIdent
 

src/compiler/api/GF/Infra/Location.hs

@@ -14,10 +14,14 @@ data Location
   deriving (Show,Eq,Ord)
 
 -- | Attaching location information
-data L a = L Location a deriving Show
+data L a = L Location a deriving (Show, Eq, Ord)
 
 instance Functor L where fmap f (L loc x) = L loc (f x)
 
+instance Foldable L where foldr f b (L loc x) = f x b
+
+instance Traversable L where traverse f (L loc x) = pure (L loc) <*> f x
+
 unLoc :: L a -> a
 unLoc (L _ x) = x
 

src/compiler/api/GF/Infra/Option.hs

@@ -107,7 +107,6 @@ data OutputFormat = FmtPGFPretty
                   | FmtSLF
                   | FmtRegExp
                   | FmtFA
-                  | FmtLR
   deriving (Eq,Ord)
 
 data SISRFormat =
@@ -492,8 +491,7 @@ outputFormatsExpl =
      (("vxml",         FmtVoiceXML),"Voice XML based on abstract syntax"),
      (("slf",          FmtSLF),"SLF speech recognition format"),
      (("regexp",       FmtRegExp),"regular expression"),
-     (("fa",           FmtFA),"finite automaton in graphviz format"),
+     (("fa",           FmtFA),"finite automaton in graphviz format")
-     (("lr",           FmtLR),"LR(0) automaton for PMCFG in graphviz format")
      ]
 
 instance Show OutputFormat where

src/compiler/api/GF/Interactive.hs

@@ -13,9 +13,8 @@ import GF.Command.Help(helpCommand)
 import GF.Command.Abstract
 import GF.Command.Parse(readCommandLine,pCommand,readTransactionCommand)
 import GF.Compile.Rename(renameSourceTerm)
-import GF.Compile.TypeCheck.Concrete(inferLType)
+import GF.Compile.TypeCheck(inferLType)
-import qualified GF.Compile.Compute.Concrete as O(normalForm,stdPredef,Globals(..))
+import GF.Compile.Compute(stdPredef,normalForm,Globals(..))
-import GF.Compile.Compute.Concrete2(stdPredef,Globals(..))
 import GF.Compile.GeneratePMCFG(pmcfgForm,type2fields)
 import GF.Data.Operations (Err(..))
 import GF.Data.Utilities(whenM,repeatM)
@@ -301,9 +300,9 @@ transactionCommand (CreateLin opts f mb_t is_alter) pgf mb_txnid = do
            mb_fields <- getCategoryFields cat
            case mb_fields of
              Just fields -> case runCheck (compileLinTerm sgr mo f mb_t (type2term mo ty)) of
-                              Ok ((prods,seqtbl,fields'),_)
+                              Ok ((rules,fields'),_)
                                    | fields == fields' -> do
-                                       (if is_alter then alterLin else createLin) f prods seqtbl
+                                       (if is_alter then alterLin else createLin) f rules
                                        return ()
                                    | otherwise -> fail "The linearization categories in the resource and the compiled grammar does not match"
                               Bad msg      -> fail msg
@@ -316,21 +315,20 @@ transactionCommand (CreateLin opts f mb_t is_alter) pgf mb_txnid = do
             hypos
 
     compileLinTerm sgr mo f mb_t ty = do
+      let g = Gl sgr (stdPredef g) False
       (t,ty) <- case mb_t of
                   Just t  -> do t <- renameSourceTerm sgr mo (Typed t ty)
-                                let g = Gl sgr (stdPredef g)
+                                
                                 (t,ty) <- inferLType g t
                                 return (t,ty)
                   Nothing -> case lookupResDef sgr (mo,identS f) of
                                Ok t    -> do ty <- renameSourceTerm sgr mo ty
-                                             ty <- O.normalForm (O.Gl sgr O.stdPredef) ty
+                                             ty <- normalForm g ty
                                              return (t,ty)
                                Bad msg -> fail msg
       let (ctxt,res_ty) = typeFormCnc ty
-      (prods,seqs) <- pmcfgForm sgr t ctxt res_ty Map.empty
+      rules <- pmcfgForm g t ctxt res_ty
-      return (prods,mapToSequence seqs,type2fields sgr res_ty)
+      return (rules,type2fields sgr res_ty)
-      where
-        mapToSequence m = Seq.fromList (map (Left . fst) (sortOn snd (Map.toList m)))
 
 transactionCommand (CreateLincat opts c mb_t) pgf mb_txnid = do
   sgr <- getGrammar
@@ -339,14 +337,14 @@ transactionCommand (CreateLincat opts c mb_t) pgf mb_txnid = do
           Just mo -> return mo
   lang <- optLang pgf opts
   case runCheck (compileLincatTerm sgr mo mb_t) of
-    Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] Seq.empty >> return ()))
+    Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] >> return ()))
                        return ()
     Bad msg      -> fail msg
   where
     compileLincatTerm sgr mo mb_t = do
       t <- case mb_t of
              Just t  -> do t <- renameSourceTerm sgr mo t
-                           let g = Gl sgr (stdPredef g)
+                           let g = Gl sgr (stdPredef g) False
                            (t,_) <- inferLType g t
                            return t
              Nothing -> case lookupResDef sgr (mo,identS c) of

src/compiler/api/GF/Server/PGFService.hs

@@ -144,7 +144,7 @@ pgfCommand qsem command q (t,pgf) =
 
     -- Without caching parse results:
     parse' cat start mlimit ((from,concr),input) =
-        case PGF2.parse concr cat (init input) of
+        case PGF2.parse concr cat input of
           ParseOk ts        -> return (Right (maybe id take mlimit (drop start ts)))
           ParseFailed _ tok -> return (Left tok)
           ParseIncomplete   -> return (Left "")

src/compiler/api/GF/Server/SimpleEditor/Convert.hs

@@ -70,7 +70,7 @@ convAbsJment (cats,funs) (name,jment) =
                              fail "category with context"
                       let cat = convId name
                       return (cat:cats,funs)
-    AbsFun (Just lt) _ oeqns _ -> do unless (null (maybe [] id oeqns)) $
+    AbsFun (Just lt) oeqns     -> do unless (null (maybe [] snd oeqns)) $
                                             fail "function with equations"
                                      let f = convId name
                                      typ <- convType (unLoc lt)
@@ -150,7 +150,7 @@ jmentList = sortBy (compare `on` (jmentLocation.snd)) . Map.toList
 jmentLocation jment =
   case jment of
     AbsCat ctxt      -> fmap loc ctxt
-    AbsFun ty _ _ _  -> fmap loc ty
+    AbsFun ty _      -> fmap loc ty
     ResParam ops _   -> fmap loc ops
     CncCat ty _ _ _ _ ->fmap loc ty
     ResOper ty rhs   -> fmap loc rhs `mplus` fmap loc ty

src/compiler/api/GF/Speech/CFGToFA.hs

@@ -20,7 +20,6 @@ import GF.Grammar.CFG
 --import GF.Infra.Ident (Ident)
 
 import GF.Data.Graph
---import GF.Data.Relation
 import GF.Speech.FiniteState
 --import GF.Speech.CFG
 

src/compiler/api/GF/Term.hs

@@ -1,12 +0,0 @@
-module GF.Term (renameSourceTerm,
-                Globals(..), ConstValue(..), EvalM, stdPredef,
-                Value(..), showValue, Thunk, newThunk, newEvaluatedThunk,
-                evalError, evalWarn,
-                inferLType, inferLType', checkLType, checkLType',
-                normalForm, normalFlatForm, normalStringForm,
-                unsafeIOToEvalM, force
-               ) where
-
-import GF.Compile.Rename
-import GF.Compile.Compute.Concrete
-import GF.Compile.TypeCheck.Concrete

src/compiler/gf.cabal

@@ -76,7 +76,6 @@ library
     GF.Interactive
     GF.Compiler
     GF.Grammar
-    GF.Term
     GF.Compile
     GF.CompileInParallel
     GF.Data.ErrM
@@ -105,8 +104,7 @@ library
     GF.Command.TreeOperations
     GF.Compile.CFGtoPGF
     GF.Compile.CheckGrammar
-    GF.Compile.Compute.Concrete
+    GF.Compile.Compute
-    GF.Compile.Compute.Concrete2
     GF.Compile.ExampleBased
     GF.Compile.Export
     GF.Compile.GenerateBC
@@ -124,9 +122,8 @@ library
     GF.Compile.SubExOpt
     GF.Compile.Tags
     GF.Compile.ToAPI
-    GF.Compile.TypeCheck.Abstract
+    GF.Compile.TypeCheck
-    GF.Compile.TypeCheck.Concrete
+    GF.Compile.TerminationCheck
-    GF.Compile.TypeCheck.TC
     GF.Compile.Update
     GF.Data.BacktrackM
     GF.Data.Graph
@@ -149,8 +146,6 @@ library
     GF.Grammar.Predef
     GF.Grammar.Printer
     GF.Grammar.ShowTerm
-    GF.Grammar.Unify
-    GF.Grammar.Values
     GF.Grammar.JSON
     GF.Infra.Concurrency
     GF.Infra.Dependencies

src/compiler/www/gfse/editor.js

@@ -1172,12 +1172,10 @@ function add_open(g,ci) {
 	    var b=common_modules[i];
 	    add_module(b,b)
 	}
-	if (gfwordnet.languages.indexOf("Parse"+conc.langcode) >= 0) {
+    for(var i in wordnet_modules) {
-		for(var i in wordnet_modules) {
+        var b=wordnet_modules[i];
-			var b=wordnet_modules[i];
+        add_module(b,b+conc.langcode)
-			add_module(b,b+conc.langcode)
+    }
-		}
-	}
 	if(list.length>0) {
 	    var file=element("file");
 	    clear(file)
@@ -1477,9 +1475,6 @@ function wordnet_search(g,input) {
 		langs: {},
 		langs_list: []
 	};
-	if (gfwordnet.languages.indexOf(selection.current) < 0) {
-		return;
-	}
 	var start = input.selectionStart;
 	var end   = input.selectionEnd;
 	if (start == end) {
@@ -1517,11 +1512,9 @@ function wordnet_search(g,input) {
 	for (var i=0; i < g.concretes.length; i++) {
 		var code = g.concretes[i].langcode;
 		var name = "Parse"+code;
-		if (gfwordnet.languages.indexOf(name) >= 0) {
+        selection.langs[name] = {name: langname[code], index: index};
-			selection.langs[name] = {name: langname[code], index: index};
+        selection.langs_list.push(name);
-			selection.langs_list.push(name);
+        index++;
-			index++;
-		}
 	}
 	selection.isEqual = function(other) {
 		if (other.langs_list.length != this.langs_list.length)

src/compiler/www/js/gftranslate.js

@@ -7,8 +7,9 @@ gftranslate.jsonurl="/robust/Parse.ngf"
 gftranslate.grammar="Parse" // the name of the grammar
 
 gftranslate.documented_classes=
-    ["N", "N2", "N3", "A", "A2", "V", "V2", "VV", "VS", "VQ", "VA", "V3", "V2V",
+    ["N", "N2", "N3", "PN", "LN", "GN", "SN", "A", "A2",
-     "V2S", "V2Q", "V2A", "Adv", "Prep"]
+     "V", "V2", "VV", "VS", "VQ", "VA", "V3", "V2V",
+     "V2S", "V2Q", "V2A", "Adv", "AdV", "AdA", "AdN", "Prep"]
 
 gftranslate.call=function(querystring,cont,errcont) {
     http_get_json(gftranslate.jsonurl+querystring,cont,errcont)
@@ -99,7 +100,7 @@ gftranslate.get_languages=function(cont,errcont) {
     else {
 	gftranslate.waiting.push({cont:cont,errcont:errcont})
 	if(gftranslate.waiting.length<2) 
-	    gftranslate.call("?command=grammar",init2,init2error)
+	    gftranslate.call("",init2,init2error)
     }
 }
 

src/compiler/www/js/langcode.js

@@ -16,16 +16,21 @@ var languages =
 	}
 	var ls
 	//  [ISO-639-2 code "/"] language name ":" ISO 639-1 code
-	ls=["Afrikaans:af","Amharic:am","Arabic:ar","Bulgarian:bg","Catalan:ca",
+    ls=["Afrikaans:af","Sqi/Albanian:sq","Amharic:am","Arabic:ar",
-	    "Chinese:zh","Czech:cs","Danish:da","Dutch:nl","English:en",
+        "Hye/Armenian:hy","Eus/Basque/eu","Bel/Belarusian:be","Bulgarian:bg",
-	    "Estonian:et","Finnish:fi","French:fr","German:de","Greek:el",
+        "Catalan:ca","Chinese:zh","Czech:cs","Danish:da",
-	    "Hebrew:he","Hindi:hi","Ina/Interlingua:ia",
+        "Dutch:nl","English:en","Estonian:et","Fao/Faroese:fo",
-	    "Icelandic:is","Gle/Irish:ga","Italian:it","Jpn/Japanese:ja",
+        "Finnish:fi","French:fr","Gla/Gaelic:gd","German:de",
-	    "Latin:la","Lav/Latvian:lv","Mlt/Maltese:mt","Mongolian:mn",
+        "Greek:el","Hebrew:he","Hindi:hi","Hungarian:hu",
-	    "Nepali:ne","Norwegian:nb","Pes/Persian:fa","Polish:pl",
+        "Icelandic:is","Ina/Interlingua:ia","Gle/Irish:ga","Italian:it",
-	    "Portuguese:pt","Pnb/Punjabi:pa",
+        "Jpn/Japanese:ja","Kazakh:kk","Korean:ko","Latin:la",
-	    "Ron/Romanian:ro","Russian:ru","Snd/Sindhi:sd","Spanish:es",
+        "Lav/Latvian:lv","Mkd/Macedonian:mk","Mlt/Maltese:mt","Mongolian:mn",
-	    "Swedish:sv","Thai:th","Turkish:tr","Urdu:ur"]
+        "Nepali:ne","Norwegian Bokmål:nb","Nno/Norwegian Nynorsk:nn","Pes/Persian:fa",
+        "Polish:pl","Portuguese:pt","Pnb/Punjabi:pa","Ron/Romanian:ro",
+        "Russian:ru","Scots:sco","Slv/Slovenian:sl","Somali:so",
+        "Snd/Sindhi:sd","Spanish:es","Swahili:sw","Swedish:sv",
+        "Thai:th","Turkish:tr","Ukrainian:uk","Urdu:ur",
+        "Zulu:zu"]
 	// GF uses nonstd 3-letter codes? Pes/Persian:fa, Pnb/Punjabi:pa
 	return map(lang1,ls)
     }()

src/compiler/www/js/wc.js

@@ -2,8 +2,6 @@
 /* --- Wide Coverage Translation Demo web app ------------------------------- */
 
 var wc={}
-wc.selected_cnls=[] // list of grammar names
-wc.cnls={} // maps grammars names to {pgf_online:...,grammar_info:{...}}
 wc.f=document.forms[0]
 wc.o=element("output")
 wc.e=element("extra")
@@ -44,7 +42,6 @@ wc.save=function() {
 	wc.local.put("to",f.to.value)
 	wc.local.put("input",f.input.value)
 	wc.local.put("colors",f.colors.checked)
-	wc.local.put("cnls",wc.selected_cnls)
     }
 }
 
@@ -55,7 +52,6 @@ wc.load=function() {
 	f.from.value=wc.local.get("from",f.from.value)
 	f.to.value=wc.local.get("to",f.to.value)
 	f.colors.checked=wc.local.get("colors",f.colors.checked)
-	wc.selected_cnls=wc.local.get("cnls",wc.selected_cnls)
 	wc.colors()
 	wc.delayed_translate()
     }
@@ -125,13 +121,19 @@ wc.translate=function(redo) {
 		function show_inflections(lins) {
 		    if(wc.e2) wc.e2.innerHTML=lins[0].text
 		}
-		function get_inflections() {
+		function get_inflections(glosses) {
-		    var tree="MkDocument+%22%22+(Inflection"+wcls+"+"+w+")+%22%22"
+            if (glosses.length == 0) {
+                glosses = [""]
+            }
+		    var tree="MkDocument+(NoDefinition+%22"+glosses[0]+"%22)+(Inflection"+wcls+"+"+w+")+%22%22"
 		    var l=gftranslate.grammar+f.to.value
-		    gftranslate.call("?command=c-linearize&to="+l+"&tree="+tree,show_inflections)
+		    gftranslate.call("?command=linearize&to="+l+"&tree="+tree,show_inflections)
 		}
+        function get_gloss() {
+            ajax_http_post_querystring_json("https://cloud.grammaticalframework.org/wordnet/SenseService.fcgi","gloss_id="+w,get_inflections);
+        }
 		var wn=wrap_class("span","inflect",text(w))
-		if(wc.e2) wn.onclick=get_inflections
+		if(wc.e2) wn.onclick=get_gloss
 		return wn
 	    }
 	    function word(w) {
@@ -239,37 +241,7 @@ wc.translate=function(redo) {
 	    gftranslate.translate(text,f.from.value,wc.languages || f.to.value,i,count,step3)
 	}
 	function step2(text) { trans(text,0,10) }
-	function step2cnl(text,ix) {
+	step2(so.input)
-	    function step3cnl(results) {
-		var trans=results[0].translations
-		if(trans && trans.length>=1) {
-		    for(var i=0;i<trans.length;i++) {
-			var r=trans[i]
-			r.prob=0
-			showit(r,cnl)
-		    }
-		}
-		step2cnl(text,ix+1)
-	    }
-	    if(ix<wc.selected_cnls.length) {
-		var g=wc.cnls[wc.selected_cnls[ix]]
-		var gi=g.grammar_info
-		var langs=gi.languages.map(function(l) { return l.name; })
-		var cnl=gi.name
-		var from=cnl+f.from.value,to=cnl+f.to.value
-		if(elem(from,langs) && elem(to,langs))
-		    g.pgf_online.translate({from:from,
-					    //to:to,
-					    lexer:"text",unlexer:"text",
-					    jsontree:true,input:text},
-					   step3cnl,
-					   function(){step2cnl(text,ix+1)})
-		else step2cnl(text,ix+1)
-	    }
-	    else step2(text)
-	}
-	if(wc.selected_cnls) step2cnl(so.input,0)
-	else step2(so.input)
     }
 
     function change_segment_to(so,to) {
@@ -404,8 +376,13 @@ wc.init_languages=function () {
 	function update_menu(m) {
 	    var l=m.value
 	    clear(m)
-	    for(var i=0;i<langs.length;i++)
+	    for(var i=0;i<langs.length;i++) {
-		m.appendChild(option(concname(langs[i]),langs[i]))
+            const code = langs[i]
+            const name = langname[code]
+            if (name) {
+                m.appendChild(option(concname(langs[i]),langs[i]))
+            }
+        }
 	    if(langset[l]) m.value=l
 	}
 	update_menu(wc.f.from)
@@ -428,86 +405,6 @@ wc.init_speech=function() {
     }
 }
 
-
-wc.show_grammarbox=function() {
-    wc.grammarbox.parentNode.style.display="block";
-}
-
-wc.hide_grammarbox=function() {
-    wc.grammarbox.parentNode.style.display="";
-    clear(wc.grammarbox)
-}
-
-wc.init_cnl=function(grammar) {
-    var g
-    if(wc.cnls[grammar]) g=wc.cnls[grammar]
-    else g=wc.cnls[grammar]={}
-    g.pgf_online=pgf_online({})
-    g.pgf_online.switch_grammar(grammar)
-    g.pgf_online.grammar_info(function(info){g.grammar_info=info})
-}
-
-wc.init_cnls=function() {
-    var gs=wc.selected_cnls
-    for(var i=0;i<gs.length;i++) wc.init_cnl(gs[i])
-}
-
-wc.select_grammars=function() {
-    function done() {
-	wc.hide_grammarbox()
-	var gs=[]
-	var glist=list.children
-	for(var i=0;i<glist.length;i++)
-	    if(glist[i].cb.checked) gs.push(glist[i].grammar)
-	wc.selected_cnls=gs
-	wc.init_cnls()
-	wc.local.put("cnls",wc.selected_cnls)
-	wc.translate(true)
-    }
-    function cancel() {
-	wc.hide_grammarbox()
-    }
-    function remove(x,xs) {
-	function other(y) { return y!=x; }
-	return filter(other,xs)
-    }
-    function checkbox(grammar,checked) {
-	var vb=node("input",{type:"checkbox"})
-	vb.checked=checked
-	return vb
-    }
-    function grammar_pick(grammar,checked) {
-	var cb=checkbox(grammar,checked)
-	var p=[cb,text(" "+grammar.split(".pgf")[0])]
-	var dt=node("dt",{class:"grammar_pick"},p)
-	dt.cb=cb
-	dt.grammar=grammar
-	return dt
-    }
-    function show_list(grammars) {
-	var sg=wc.selected_cnls
-	for(var i=0;i<sg.length;i++) {
-	    if(elem(sg[i],grammars))
-		list.appendChild(grammar_pick(sg[i],true))
-	    else
-		remove(sg[i],wc.selected_cnls)
-	}
-	for(var i=0;i<grammars.length;i++)
-	    if(!elem(grammars[i],wc.selected_cnls))
-		list.appendChild(grammar_pick(grammars[i],false))
-    }
-    
-    clear(wc.grammarbox)
-    wc.grammarbox.appendChild(wrap("h2",[button("X",cancel),text("Select which domain-specific grammars to use")]))
-    wc.grammarbox.appendChild(text("These grammars are tried before the wide-coverage grammar. They can give higher quality translations within their respective domains."))
-    var list=empty("dl")
-    wc.grammarbox.appendChild(list)
-    wc.grammarbox.appendChild(button("OK",done))
-    wc.grammarbox.appendChild(button("Cancel",cancel))
-    wc.show_grammarbox()
-    wc.pgf_online.get_grammarlist(show_list)
-}
-
 wc.initialize=function(grammar_name,grammar_url) {
     if(grammar_name && grammar_url) {
 	gftranslate.grammar=grammar_name
@@ -519,7 +416,6 @@ wc.initialize=function(grammar_name,grammar_url) {
     wc.pgf_online=pgf_online({});
     wc.local=appLocalStorage("gf.wc."+gftranslate.grammar+".")
     wc.load()
-    wc.init_cnls()
     initialize_sorting(["DT"],["grammar_pick"])
     wc.f.input.focus()
 }

src/compiler/www/wc.html

@@ -92,7 +92,6 @@ h2 > input { float: right; }
   </select>
   <input name=colors type=checkbox checked onchange="wc.colors()"> Colors
   <td><button name=translate type=submit><strong>Translate</strong></button>
-      <input type=button name=grammars onclick="wc.select_grammars()" value="Grammars...">
   <tr><td class=input colspan=2>
     <div class=input>
   <textarea name=input rows=5 style="width: 100%" onkeyup="wc.delayed_translate()"></textarea>

src/runtime/c/configure.ac

@@ -2,6 +2,7 @@ AC_INIT(Portable Grammar Format library, 3.0-pre,
 		 http://www.grammaticalframework.org/, 
 		 libpgf)
 AC_PREREQ(2.58)
+LT_INIT([])
 
 AC_CONFIG_AUX_DIR([scripts])
 AC_CONFIG_MACRO_DIR([m4])

src/runtime/c/pgf/compute.cxx

@@ -0,0 +1,142 @@
+#include "data.h"
+#include "compute.h"
+
+PgfExpr PgfEvalExpr::eabs(PgfBindType bind_type, PgfText *name, PgfExpr body)
+{
+    if (stack != NULL) {
+        ExprNode *tmp;
+        tmp = stack->next;
+        stack->next = env;
+        env = stack;
+        stack = tmp;
+        return m->match_expr(this, body);
+    } else {
+        return 0;
+    }
+}
+
+PgfExpr PgfEvalExpr::eapp(PgfExpr fun, PgfExpr arg)
+{
+    ExprNode node;
+    node.e = arg;
+    node.value = 0;
+    node.next = stack;
+    stack = &node;
+    PgfExpr e = m->match_expr(this, fun);
+    if (node.value != 0) {
+        //u->free_ref(node.value);
+    }
+    return e;
+}
+
+PgfExpr PgfEvalExpr::elit(PgfLiteral lit)
+{
+    lit = m->match_lit(this, lit);
+    PgfExpr e = u->elit(lit);
+    u->free_ref(lit);
+    return e;
+}
+
+PgfExpr PgfEvalExpr::emeta(PgfMetaId meta_id)
+{
+    return apply(u->emeta(meta_id));
+}
+
+PgfExpr PgfEvalExpr::efun(PgfText *name)
+{
+    return apply(u->efun(name));
+}
+
+PgfExpr PgfEvalExpr::evar(int index)
+{
+    ExprNode *node = env;
+    while (index > 0) {
+        if (node == NULL) {
+            err->type = PGF_EXN_PGF_ERROR;
+            err->msg  = strdup("Unbounded variable");
+            return 0;
+        }
+        node = node->next;
+    }
+
+    if (node == NULL) {
+        err->type = PGF_EXN_PGF_ERROR;
+        err->msg  = strdup("Unbounded variable");
+        return 0;
+    }
+    return apply(force(node));
+}
+
+PgfExpr PgfEvalExpr::etyped(PgfExpr expr, PgfType ty)
+{
+    return m->match_expr(this, expr);
+}
+
+PgfExpr PgfEvalExpr::eimplarg(PgfExpr expr)
+{
+    return m->match_expr(this, expr);
+}
+
+PgfLiteral PgfEvalExpr::lint(size_t size, uintmax_t *val)
+{
+    return u->lint(size, val);
+}
+
+PgfLiteral PgfEvalExpr::lflt(double val)
+{
+    return u->lflt(val);
+}
+
+PgfLiteral PgfEvalExpr::lstr(PgfText *val)
+{
+    return u->lstr(val);
+}
+
+PgfType PgfEvalExpr::dtyp(size_t n_hypos, PgfTypeHypo *hypos,
+                          PgfText *name,
+                          size_t n_exprs, PgfExpr *exprs)
+{
+    return 0;
+}
+
+void PgfEvalExpr::free_ref(object x)
+{
+    return u->free_ref(x);
+}
+
+PgfExpr PgfEvalExpr::force(ExprNode *node)
+{
+    if (node->value == 0) {
+        PgfEvalExpr eval(pgf,m,u,env,err);
+        node->value = m->match_expr(&eval, node->e);
+    }
+    return node->value;
+}
+
+PgfExpr PgfEvalExpr::apply(PgfExpr e)
+{
+    while (stack != NULL) {
+        PgfExpr arg = force(stack);
+        if (arg == 0) {
+            u->free_ref(e);
+            return 0;
+        }
+
+        PgfExpr app = u->eapp(e,arg);
+        u->free_ref(e);
+        e = app;
+        stack = stack->next;
+    }
+    return e;
+}
+
+PgfEvalExpr::PgfEvalExpr(ref<PgfPGF> pgf,
+                         PgfMarshaller *m, PgfUnmarshaller *u,
+                         ExprNode *env,
+                         PgfExn *err)
+{
+    this->m = m;
+    this->u = u;
+    this->stack = NULL;
+    this->env   = env;
+}

src/runtime/c/pgf/compute.h

@@ -0,0 +1,69 @@
+#ifndef COMPUTE_H
+#define COMPUTE_H
+
+class PGF_INTERNAL_DECL PgfEvalExpr : public PgfUnmarshaller
+{
+    ref<PgfPGF> pgf;
+    PgfMarshaller *m;
+    PgfUnmarshaller *u;
+    PgfExn *err;
+
+    struct Value {
+        Value *next;                // chain for garabage collection
+    };
+
+    struct VThunk : Value {
+        PgfExpr e;
+    };
+
+    struct VApp : Value {
+        ref<PgfConcrLin> lin;
+        Value *args[];
+    };
+
+    struct VMeta : Value {
+        PgfMetaId id;
+        Value *args[];
+    };
+
+    struct VClosure : Value {
+        PgfExpr e;
+    };
+
+    struct ExprNode {
+        PgfExpr e;
+        PgfExpr value;
+        ExprNode *next;
+    };
+
+    ExprNode *stack;
+    ExprNode *env;
+
+    virtual PgfExpr eabs(PgfBindType bind_type, PgfText *name, PgfExpr body);
+    virtual PgfExpr eapp(PgfExpr fun, PgfExpr arg);
+    virtual PgfExpr elit(PgfLiteral lit);
+    virtual PgfExpr emeta(PgfMetaId meta_id);
+    virtual PgfExpr efun(PgfText *name);
+    virtual PgfExpr evar(int index);
+    virtual PgfExpr etyped(PgfExpr expr, PgfType ty);
+    virtual PgfExpr eimplarg(PgfExpr expr);
+    virtual PgfLiteral lint(size_t size, uintmax_t *val);
+    virtual PgfLiteral lflt(double val);
+    virtual PgfLiteral lstr(PgfText *val);
+
+    virtual PgfType dtyp(size_t n_hypos, PgfTypeHypo *hypos,
+                         PgfText *name,
+                         size_t n_exprs, PgfExpr *exprs);
+    virtual void free_ref(object x);
+
+    PgfExpr force(ExprNode *node);
+    PgfExpr apply(PgfExpr e);
+
+public:
+    PgfEvalExpr(ref<PgfPGF> pgf,
+                PgfMarshaller *m, PgfUnmarshaller *u,
+                ExprNode *env,
+                PgfExn *err);
+};
+
+#endif // COMPUTE_H

src/runtime/c/pgf/data.cxx

@@ -40,8 +40,12 @@ void PgfConcr::release(ref<PgfConcr> concr)
     namespace_release(concr->cflags);
     namespace_release(concr->lins);
     namespace_release(concr->lincats);
-    phrasetable_release(concr->phrasetable);
     namespace_release(concr->printnames);
+    phrasetable_release(concr->phrasetable1);
+    phrasetable_release(concr->phrasetable2);
+    phrasetable_release(concr->phrasetable3);
+    phrasetable_release(concr->phrasetable4);
+    epsilontable_release(concr->epsilontable);
     PgfDB::free(concr, concr->name.size+1);
 }
 
@@ -52,17 +56,10 @@ void PgfConcrLincat::release(ref<PgfConcrLincat> lincat)
     }
     vector<ref<PgfText>>::release(lincat->fields);
 
-	for (size_t i = 0; i < lincat->args.size(); i++) {
+    for (ref<PgfConcrRule> rule : lincat->rules) {
-        PgfLParam::release(lincat->args[i].param);
+        PgfConcrRule::release(rule);
     }
-    vector<PgfPArg>::release(lincat->args);
+    vector<ref<PgfConcrRule>>::release(lincat->rules);
-
-    for (ref<PgfPResult> res : lincat->res) {
-        PgfPResult::release(res);
-    }
-    vector<ref<PgfPResult>>::release(lincat->res);
-
-    vector<ref<PgfSequence>>::release(lincat->seqs);
 
     PgfDB::free(lincat, lincat->name.size+1);
 }
@@ -72,16 +69,9 @@ void PgfLParam::release(ref<PgfLParam> param)
     PgfDB::free(param, param->n_terms*sizeof(param->terms[0]));
 }
 
-void PgfPResult::release(ref<PgfPResult> res)
+static void symbols_release(vector<PgfSymbol> syms)
 {
-    if (res->vars != 0)
+	for (PgfSymbol sym : syms) {
-        vector<PgfVariableRange>::release(res->vars);
-    PgfDB::free(res, res->param.n_terms*sizeof(res->param.terms[0]));
-}
-
-void PgfSequence::release(ref<PgfSequence> seq)
-{
-	for (PgfSymbol sym : seq->syms) {
         switch (ref<PgfSymbol>::get_tag(sym)) {
         case PgfSymbolCat::tag: {
             auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
@@ -103,9 +93,11 @@ void PgfSequence::release(ref<PgfSequence> seq)
         }
         case PgfSymbolKP::tag: {
             auto sym_kp = ref<PgfSymbolKP>::untagged(sym);
-            PgfSequence::release(sym_kp->default_form);
+            symbols_release(sym_kp->default_form);
+            vector<PgfSymbol>::release(sym_kp->default_form);
             for (size_t i = 0; i < sym_kp->alts.size(); i++) {
-                PgfSequence::release(sym_kp->alts[i].form);
+                symbols_release(sym_kp->alts[i].form);
+                vector<PgfSymbol>::release(sym_kp->alts[i].form);
                 for (size_t j = 0; j < sym_kp->alts[i].prefixes.size(); j++) {
                     text_db_release(sym_kp->alts[i].prefixes[j]);
                 }
@@ -124,22 +116,31 @@ void PgfSequence::release(ref<PgfSequence> seq)
             throw pgf_error("Unknown symbol tag");
         }
     }
-    inline_vector<PgfSymbol>::release(&PgfSequence::syms, seq);
+}
+
+void PgfConcrRule::release(ref<PgfConcrRule> rule)
+{
+    vector<size_t>::release(rule->ranges);
+
+    PgfLParam::release(rule->res);
+
+    for (ref<PgfLParam> arg : rule->args) {
+        PgfLParam::release(arg);
+    }
+    vector<ref<PgfLParam>>::release(rule->args);
+
+    PgfLParam::release(rule->lin_idx);
+
+    symbols_release(rule->syms.as_vector());
+    inline_vector<PgfSymbol>::release(&PgfConcrRule::syms, rule);
 }
 
 void PgfConcrLin::release(ref<PgfConcrLin> lin)
 {
-    for (size_t i = 0; i < lin->args.size(); i++) {
+    for (ref<PgfConcrRule> rule : lin->rules) {
-        PgfLParam::release(lin->args[i].param);
+        PgfConcrRule::release(rule);
     }
-    vector<PgfPArg>::release(lin->args);
+    vector<ref<PgfConcrRule>>::release(lin->rules);
-
-    for (ref<PgfPResult> res : lin->res) {
-        PgfPResult::release(res);
-    }
-    vector<ref<PgfPResult>>::release(lin->res);
-
-    vector<ref<PgfSequence>>::release(lin->seqs);
 
     PgfDB::free(lin, lin->name.size+1);
 }

src/runtime/c/pgf/data.h

@@ -87,9 +87,9 @@ struct PgfConcr;
 #include "text.h"
 #include "vector.h"
 #include "namespace.h"
-#include "phrasetable.h"
 #include "probspace.h"
 #include "expr.h"
+#include "intervalmap.h"
 
 struct PGF_INTERNAL_DECL PgfFlag {
     PgfLiteral value;
@@ -146,21 +146,8 @@ struct PGF_INTERNAL_DECL PgfPArg {
     ref<PgfLParam> param;
 };
 
-struct PGF_INTERNAL_DECL PgfPResult {
-    vector<PgfVariableRange> vars; 
-    PgfLParam param;
-
-    static void release(ref<PgfPResult> res);
-};
-
 typedef object PgfSymbol;
 
-struct PGF_INTERNAL_DECL PgfSequence {
-	inline_vector<PgfSymbol> syms;
-
-    static void release(ref<PgfSequence> seq);
-};
-
 struct PGF_INTERNAL_DECL PgfSequenceBackref {
     object container;
     size_t seq_index;
@@ -189,7 +176,7 @@ struct PGF_INTERNAL_DECL PgfSymbolKS {
 };
 
 struct PGF_INTERNAL_DECL PgfAlternative {
-	ref<PgfSequence> form;
+	vector<PgfSymbol> form;
 	/**< The form of this variant as a list of tokens. */
 
 	vector<ref<PgfText>> prefixes;
@@ -199,7 +186,7 @@ struct PGF_INTERNAL_DECL PgfAlternative {
 
 struct PGF_INTERNAL_DECL PgfSymbolKP {
     static const uint8_t tag = 4;
-    ref<PgfSequence> default_form;
+    vector<PgfSymbol> default_form;
     inline_vector<PgfAlternative> alts;
 };
 
@@ -227,15 +214,24 @@ struct PGF_INTERNAL_DECL PgfSymbolALLCAPIT {
     static const uint8_t tag = 10;
 };
 
+struct PGF_INTERNAL_DECL PgfConcrRule {
+    vector<size_t> ranges;
+    ref<PgfLParam> res;
+    object container;
+    vector<ref<PgfLParam>> args;
+    ref<PgfLParam> lin_idx;
+    inline_vector<PgfSymbol> syms;
+
+    static void release(ref<PgfConcrRule> seq);
+};
+
 struct PGF_INTERNAL_DECL PgfConcrLincat {
     static const uint8_t tag = 0;
 
     ref<PgfAbsCat> abscat;
 
     size_t n_lindefs;
-    vector<PgfPArg> args;
+    vector<ref<PgfConcrRule>> rules;
-    vector<ref<PgfPResult>> res;
-    vector<ref<PgfSequence>> seqs;
     vector<ref<PgfText>> fields;
 
     PgfText name;
@@ -249,9 +245,7 @@ struct PGF_INTERNAL_DECL PgfConcrLin {
     ref<PgfAbsFun> absfun;
     ref<PgfConcrLincat> lincat;
 
-    vector<PgfPArg> args;
+    vector<ref<PgfConcrRule>> rules;
-    vector<ref<PgfPResult>> res;
-    vector<ref<PgfSequence>> seqs;
 
     PgfText name;
 
@@ -267,143 +261,19 @@ struct PGF_INTERNAL_DECL PgfConcrPrintname {
 
 #define containerof(T,field,p) (T*) (((char*) p)-offsetof(T,field))
 
-struct PGF_INTERNAL_DECL PgfLCEdge {
+#include "phrasetable.h"
-    struct {
-        ref<PgfConcrLincat> lincat;
-        struct {
-            size_t i0;
-            term& operator[](int i) {
-                PgfLCEdge *edge = containerof(PgfLCEdge,from.value,this);
-                return edge->terms[i];
-            }
-            size_t size() {
-                PgfLCEdge *edge = containerof(PgfLCEdge,from.value,this);
-                return edge->from.lin_idx.n_offset;
-            }
-        } value;
-        struct {
-            size_t i0;
-            size_t n_offset;
-            term& operator[](int i) {
-                PgfLCEdge *edge = containerof(PgfLCEdge,from.lin_idx,this);
-                return edge->terms[n_offset+i];
-            }
-            size_t size() {
-                PgfLCEdge *edge = containerof(PgfLCEdge,from.lin_idx,this);
-                return edge->to.value.n_offset-n_offset;
-            }
-        } lin_idx;
-    } from;
-
-    struct {
-        ref<PgfConcrLincat> lincat;
-        struct {
-            size_t i0;
-            size_t n_offset;
-            term& operator[](int i) {
-                PgfLCEdge *edge = containerof(PgfLCEdge,to.value,this);
-                return edge->terms[n_offset+i];
-            }
-            size_t size() {
-                PgfLCEdge *edge = containerof(PgfLCEdge,to.value,this);
-                return edge->to.lin_idx.n_offset-n_offset;
-            }
-        } value;
-        struct {
-            size_t i0;
-            size_t n_offset;
-            term& operator[](int i) {
-                PgfLCEdge *edge = containerof(PgfLCEdge,to.lin_idx,this);
-                return edge->terms[n_offset+i];
-            }
-            size_t size() {
-                PgfLCEdge *edge = containerof(PgfLCEdge,to.lin_idx,this);
-                return edge->n_terms-n_offset;
-            }
-        } lin_idx;
-    } to;
-
-    struct {
-        size_t n_vars;
-        PgfVariableRange& operator[](int i) {
-            PgfLCEdge *edge = containerof(PgfLCEdge,vars,this);
-            return ((PgfVariableRange*)(((term*) (edge+1))+edge->n_terms))[i];
-        }
-        size_t size() {
-            return n_vars;
-        }
-    } vars;
-
-    size_t n_terms;
-    term terms[];
-
-    static ref<PgfLCEdge> alloc(size_t n_terms1, size_t n_terms2, size_t n_terms3, size_t n_terms4, size_t n_vars) {
-        auto edge = PgfDB::malloc<PgfLCEdge>((n_terms1+n_terms2+n_terms3+n_terms4)*sizeof(term)+n_vars*sizeof(PgfVariableRange));
-        edge->from.lin_idx.n_offset = n_terms1;
-        edge->to.value.n_offset = n_terms1+n_terms2;
-        edge->to.lin_idx.n_offset = n_terms1+n_terms2+n_terms3;
-        edge->n_terms = n_terms1+n_terms2+n_terms3+n_terms4;
-        edge->vars.n_vars = n_vars;
-        return edge;
-    }
-};
-
-struct PGF_INTERNAL_DECL PgfLRShift {
-    size_t next_state;
-    ref<PgfConcrLincat> lincat;
-    size_t r;
-};
-
-struct PGF_INTERNAL_DECL PgfLRShiftKS {
-    size_t next_state;
-    ref<PgfSequence> seq;
-    size_t sym_idx;
-};
-
-struct PgfLRReduceArg;
-
-struct PGF_INTERNAL_DECL PgfLRProduction {
-    ref<PgfConcrLin> lin;
-    size_t index;
-    vector<ref<PgfLRReduceArg>> args;
-};
-
-struct PGF_INTERNAL_DECL PgfLRReduceArg {
-    static const uint8_t tag = 2;
-
-    size_t id;
-    size_t n_prods;
-    PgfLRProduction prods[];
-};
-
-struct PGF_INTERNAL_DECL PgfLRReduce {
-    object lin_obj;
-    size_t seq_idx;
-    size_t depth;
-
-    struct Arg {
-        ref<PgfLRReduceArg> arg;
-        size_t stk_idx;
-    };
-
-    vector<Arg> args;
-};
-
-struct PGF_INTERNAL_DECL PgfLRState {
-    vector<PgfLRShift> shifts;
-    vector<PgfLRShiftKS> tokens;
-    size_t next_bind_state;
-    vector<PgfLRReduce> reductions;
-};
 
 struct PGF_INTERNAL_DECL PgfConcr {
     Namespace<PgfFlag> cflags;
     Namespace<PgfConcrLin> lins;
     Namespace<PgfConcrLincat> lincats;
-    PgfPhrasetable phrasetable;
+    PgfPhrasetable<PgfSymbolKS>    phrasetable1;  // suspended on token
+    PgfPhrasetable<PgfConcrLincat> phrasetable2;  // suspended on lincat
+    PgfPhrasetable<PgfCCat>        phrasetable3;  // suspended on ccat
+    PgfPhrasetable<PgfSymbolBIND>  phrasetable4;  // suspended on bind
+    PgfEpsilontable epsilontable;
     Namespace<PgfConcrPrintname> printnames;
-
+    PgfMetaId last_fid;
-    vector<PgfLRState> lrtable;
 
     PgfText name;
 

src/runtime/c/pgf/expr.cxx

@@ -111,26 +111,30 @@ PgfType PgfDBMarshaller::match_type(PgfUnmarshaller *u, PgfType ty)
 
 PgfExpr PgfDBUnmarshaller::eabs(PgfBindType bind_type, PgfText *name, PgfExpr body)
 {
+    body = m->match_expr(this, body);
     ref<PgfExprAbs> eabs =
         PgfDB::malloc<PgfExprAbs>(name->size+1);
     eabs->bind_type = bind_type;
-    eabs->body = m->match_expr(this, body);
+    eabs->body = body;
     memcpy(&eabs->name, name, sizeof(PgfText)+name->size+1);
     return eabs.tagged();
 }
 
 PgfExpr PgfDBUnmarshaller::eapp(PgfExpr fun, PgfExpr arg)
 {
+    fun = m->match_expr(this, fun);
+    arg = m->match_expr(this, arg);
     ref<PgfExprApp> eapp = PgfDB::malloc<PgfExprApp>();
-    eapp->fun = m->match_expr(this, fun);
+    eapp->fun = fun;
-	eapp->arg = m->match_expr(this, arg);
+	eapp->arg = arg;
     return eapp.tagged();
 }
 
 PgfExpr PgfDBUnmarshaller::elit(PgfLiteral lit)
 {
+    lit = m->match_lit(this, lit);
     ref<PgfExprLit> elit = PgfDB::malloc<PgfExprLit>();
-    elit->lit = m->match_lit(this, lit);
+    elit->lit = lit;
     return elit.tagged();
 }
 
@@ -158,16 +162,19 @@ PgfExpr PgfDBUnmarshaller::evar(int index)
 
 PgfExpr PgfDBUnmarshaller::etyped(PgfExpr expr, PgfType ty)
 {
+    expr = m->match_expr(this, expr);
+    ty   = m->match_type(this, ty);
     ref<PgfExprTyped> etyped = PgfDB::malloc<PgfExprTyped>();
-    etyped->expr = m->match_expr(this, expr);
+    etyped->expr = expr;
-    etyped->type = m->match_type(this, ty);
+    etyped->type = ty;
     return etyped.tagged();
 }
 
 PgfExpr PgfDBUnmarshaller::eimplarg(PgfExpr expr)
 {
+    expr = m->match_expr(this, expr);
     ref<PgfExprImplArg> eimpl = current_db->malloc<PgfExprImplArg>();
-	eimpl->expr = m->match_expr(this, expr);
+	eimpl->expr = expr;
     return eimpl.tagged();
 }
 

src/runtime/c/pgf/intervalmap.h

@@ -0,0 +1,467 @@
+#ifndef INTERVAL_MAP_H
+#define INTERVAL_MAP_H
+
+typedef std::pair<size_t,size_t> interval_t;
+
+template<class V>
+class PGF_INTERNAL_DECL interval_map {
+    const static size_t DELTA = 3;
+    const static size_t RATIO = 2;
+
+    struct Node {
+        size_t sz;
+        size_t start, end, max;
+
+        Node *left;
+        Node *right;
+
+        V value;
+
+        Node(size_t start, size_t end)
+        {
+            this->sz = 1;
+            this->start = start;
+            this->end = end;
+            this->max = end;
+            this->left = NULL;
+            this->right = NULL;
+            memset(&value, 0, sizeof(value));
+        }
+    };
+
+    Node *root;
+
+    static
+    Node *insert(Node *node, size_t start, size_t end, Node **target)
+    {
+        if (node == NULL) {
+            node = new Node(start, end);
+            *target = node;
+            return node;
+        }
+
+        int cmp;
+        if (start < node->start)
+            cmp = -1;
+        else if (start > node->start)
+            cmp = 1;
+        else if (end < node->end)
+            cmp = -1;
+        else if (end > node->end)
+            cmp = 1;
+        else
+            cmp = 0;
+
+        if (cmp < 0) {
+            Node *left = insert(node->left, start, end, target);
+            node = upd_node(node,left,node->right);
+            return balanceL(node);
+        } else if (cmp > 0) {
+            Node *right = insert(node->right, start, end, target);
+            node = upd_node(node,node->left,right);
+            return balanceR(node);
+        } else {
+            *target = node;
+            return node;
+        }
+    }
+
+    static size_t size(Node *node)
+    {
+        if (node == 0)
+            return 0;
+        return node->sz;
+    }
+
+    static
+    Node *upd_node(Node *node, Node *left, Node *right)
+    {
+        node->sz        = 1+size(left)+size(right);
+        node->max       = std::max((left  == NULL) ? node->end : left->max,
+                                   (right == NULL) ? node->end : right->max);
+        node->left      = left;
+        node->right     = right;
+        return node;
+    }
+
+    static
+    Node *balanceL(Node *node)
+    {
+        if (node->right == NULL) {
+            if (node->left == NULL) {
+                return node;
+            } else {
+                if (node->left->left == NULL) {
+                    if (node->left->right == NULL) {
+                        return node;
+                    } else {
+                        Node *left_right = node->left->right;
+                        Node *left  = upd_node(node->left,NULL,NULL);
+                        Node *right = upd_node(node,NULL,NULL);
+                        return upd_node(left_right,
+                                        left,
+                                        right);
+                    }
+                } else {
+                    if (node->left->right == 0) {
+                        Node *left  = node->left;
+                        Node *right = upd_node(node,NULL,NULL);
+                        return upd_node(left,
+                                        left->left,
+                                        right);
+                    } else {
+                        if (node->left->right->sz < RATIO * node->left->left->sz) {
+                            Node *left  = node->left;
+                            Node *right =
+                                upd_node(node,
+                                         left->right,
+                                         NULL);
+                            return upd_node(left,
+                                            left->left,
+                                            right);
+                        } else {
+                            Node *left_right = node->left->right;
+                            Node *left =
+                                upd_node(node->left,
+                                         node->left->left,
+                                         left_right->left);
+                            Node *right =
+                                upd_node(node,
+                                         left_right->right,
+                                         NULL);
+                            return upd_node(left_right,
+                                            left,
+                                            right);
+                        }
+                    }
+                }
+            }
+        } else {
+            if (node->left == NULL) {
+                return node;
+            } else {
+                if (node->left->sz > DELTA*node->right->sz) {
+                    if (node->left->right->sz < RATIO*node->left->left->sz) {
+                        Node *left  = node->left;
+                        Node *right =
+                            upd_node(node,
+                                     left->right,
+                                     node->right);
+                        return upd_node(left,
+                                        left->left,
+                                        right);
+                    } else {
+                        Node *left_right = node->left->right;
+                        Node *left  =
+                            upd_node(node->left,
+                                     node->left->left,
+                                     left_right->left);
+                        Node *right =
+                            upd_node(node,
+                                     left_right->right,
+                                     node->right);
+                        return upd_node(left_right,
+                                        left,
+                                        right);
+                    }
+                } else {
+                    return node;
+                }
+            }
+        }
+    }
+
+    static
+    Node *balanceR(Node *node)
+    {
+        if (node->left == NULL) {
+            if (node->right == NULL) {
+                return node;
+            } else {
+                if (node->right->left == NULL) {
+                    if (node->right->right == NULL) {
+                        return node;
+                    } else {
+                        Node *right = node->right;
+                        Node *left  =
+                            upd_node(node,
+                                     NULL,
+                                     NULL);
+                        return upd_node(right,
+                                        left,
+                                        right->right);
+                    }
+                } else {
+                    if (node->right->right == NULL) {
+                        Node *right_left = node->right->left;
+                        Node *right =
+                            upd_node(node->right,NULL,NULL);
+                        Node *left =
+                            upd_node(node,NULL,NULL);
+                        return upd_node(right_left,
+                                        left,
+                                        right);
+                    } else {
+                        if (node->right->left->sz < RATIO * node->right->right->sz) {
+                            Node *right = node->right;
+                            Node *left  =
+                                upd_node(node,
+                                         NULL,
+                                         right->left);
+                            return upd_node(right,
+                                            left,
+                                            right->right);
+                        } else {
+                            Node *right_left = node->right->left;
+                            Node *right =
+                                upd_node(node->right,
+                                         right_left->right,
+                                         node->right->right);
+                            Node *left =
+                                upd_node(node,
+                                         NULL,
+                                         right_left->left);
+                            return upd_node(right_left,
+                                            left,
+                                            right);
+                        }
+                    }
+                }
+            }
+        } else {
+            if (node->right == NULL) {
+                return node;
+            } else {
+                if (node->right->sz > DELTA*node->left->sz) {
+                    if (node->right->left->sz < RATIO*node->right->right->sz) {
+                        Node *right = node->right;
+                        Node *left =
+                            upd_node(node,
+                                     node->left,
+                                     right->left);
+                        return upd_node(right,
+                                        left,
+                                        right->right);
+                    } else {
+                        Node *right_left = node->right->left;
+                        Node *right =
+                            upd_node(node->right,
+                                     right_left->right,
+                                     node->right->right);
+                        Node *left =
+                            upd_node(node,
+                                     node->left,
+                                     right_left->left);
+                        return upd_node(right_left,
+                                        left,
+                                        right);
+                    }
+                } else {
+                    return node;
+                }
+            }
+        }
+    }
+
+public:
+    interval_map() {
+        root = NULL;
+    }
+
+    V &operator[](interval_t interval)
+    {
+        Node *node;
+        this->root = insert(this->root, interval.first, interval.second, &node);
+        return node->value;
+    }
+
+    V *lookup(interval_t interval)
+    {
+        return lookup(this->root, interval.first, interval.second);
+    }
+
+    size_t size()
+    {
+        return size(root);
+    }
+
+    class iterator {
+        struct Parent {
+            Node *node;
+            Parent *next;
+        };
+
+        Parent *spine;
+
+    public:
+        iterator() {
+            spine = NULL;
+        }
+
+        iterator(Node *node) {
+            spine = NULL;
+            while (node != NULL) {
+                Parent *parent = new Parent;
+                parent->node = node;
+                parent->next = spine;
+                spine = parent;
+                node = node->left;
+            }
+        }
+
+        bool operator ==(const iterator other) const {
+            return this->spine == other.spine;
+        }
+
+        bool operator !=(const iterator other) const {
+            return this->spine != other.spine;
+        }
+
+        std::pair<interval_t,V&> operator *() const {
+            return std::pair<interval_t,V&>
+                              (interval_t(spine->node->start,spine->node->end)
+                              ,spine->node->value
+                              );
+        }
+
+        void operator ++() {
+            Parent *parent = spine->next;
+            Node *node = spine->node->right;
+            delete spine;
+            spine = parent;
+
+            while (node != NULL) {
+                parent = new Parent;
+                parent->node = node;
+                parent->next = spine;
+                spine = parent;
+                node = node->left;
+            }
+        }
+
+        ~iterator() {
+            while (spine != NULL) {
+                Parent *parent = spine->next;
+                delete spine;
+                spine = parent;
+            }
+        }
+    };
+
+    iterator begin() const {
+        return iterator(root);
+    }
+
+    iterator end() const {
+        return iterator();
+    }
+
+    class Overlaps {
+        Node *root;
+        interval_t i;
+
+    public:
+        class iterator {
+            struct Parent {
+                Node *node;
+                Parent *next;
+            };
+
+            Parent *spine;
+            size_t start, end;
+
+        public:
+            iterator() {
+                spine = NULL;
+            }
+
+            iterator(Node *node, size_t start, size_t end) {
+                this->start = start;
+                this->end = end;
+
+                spine = NULL;
+                for (;;) {
+                    Parent *parent;
+                    while (node != NULL && start <= node->max) {
+                        parent = new Parent;
+                        parent->node = node;
+                        parent->next = spine;
+                        spine = parent;
+                        node = node->left;
+                    }
+
+                    if (spine == NULL || (start <= spine->node->end && end >= spine->node->start))
+                        return;
+
+                    parent = spine->next;
+                    node   = spine->node->right;
+                    delete spine;
+                    spine  = parent;
+                }
+            }
+
+            bool operator ==(const iterator other) const {
+                return this->spine == other.spine;
+            }
+
+            bool operator !=(const iterator other) const {
+                return this->spine != other.spine;
+            }
+
+            std::pair<interval_t,V&> operator *() const {
+                return std::pair<interval_t,V&>
+                                  (interval_t(spine->node->start,spine->node->end)
+                                  ,spine->node->value
+                                  );
+            }
+
+            void operator ++() {
+                for (;;) {
+                    Parent *parent = spine->next;
+                    Node *node = spine->node->right;
+                    delete spine;
+                    spine = parent;
+
+                    while (node != NULL && start <= node->max) {
+                        parent = new Parent;
+                        parent->node = node;
+                        parent->next = spine;
+                        spine = parent;
+                        node = node->left;
+                    }
+
+                    if (spine == NULL || (start <= spine->node->end && end >= spine->node->start))
+                        return;
+                }
+            }
+
+            ~iterator() {
+                while (spine != NULL) {
+                    Parent *parent = spine->next;
+                    delete spine;
+                    spine = parent;
+                }
+            }
+        };
+
+        Overlaps(Node *root, interval_t i) {
+            this->root = root;
+            this->i    = i;
+        }
+
+        iterator begin() const {
+            return iterator(root,i.first,i.second);
+        }
+
+        iterator end() const {
+            return iterator();
+        }
+    };
+
+    Overlaps overlaps(interval_t interval)
+    {
+        return Overlaps(this->root, interval);
+    }
+};
+
+#endif

src/runtime/c/pgf/linearizer.cxx

@@ -2,6 +2,44 @@
 #include "printer.h"
 #include "linearizer.h"
 
+bool PgfLinearizer::Item::instantiate(ref<PgfLParam> lparam,size_t value)
+{
+    if (value < lparam->i0)
+        return false;
+    value -= lparam->i0;
+
+    for (size_t j = 0; j < lparam->n_terms; j++) {
+        term t = lparam->terms[j];
+        if (vars[t.var] > 0) {
+            if (value < vars[t.var]-1)
+                return false;
+            value -= vars[t.var]-1;
+        }
+    }
+
+    for (size_t j = 0; j < lparam->n_terms; j++) {
+        term t = lparam->terms[j];
+        if (vars[t.var] == 0) {
+            size_t v_val = value / t.factor;
+            if (v_val >= rule->ranges[t.var])
+                return false;
+            vars[t.var] = v_val + 1;
+            value %= t.factor;
+        }
+    }
+
+    return (value == 0);
+}
+
+size_t PgfLinearizer::Item::eval(ref<PgfLParam> lparam)
+{
+    size_t value = lparam->i0;
+    for (size_t i = 0; i < lparam->n_terms; i++) {
+        value += lparam->terms[i].factor * (vars[lparam->terms[i].var]-1);
+    }
+    return value;
+}
+
 PgfLinearizer::TreeNode::TreeNode(PgfLinearizer *linearizer)
 {
     this->next     = linearizer->prev;
@@ -11,8 +49,6 @@ PgfLinearizer::TreeNode::TreeNode(PgfLinearizer *linearizer)
     this->fid       = 0;
 
     this->value     = 0;
-    this->var_count = 0;
-    this->var_values= NULL;
 
     this->n_hoas_vars = 0;
     this->hoas_vars   = NULL;
@@ -20,19 +56,18 @@ PgfLinearizer::TreeNode::TreeNode(PgfLinearizer *linearizer)
     linearizer->prev = this;
 }
 
-void PgfLinearizer::TreeNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r)
+bool PgfLinearizer::TreeNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r)
 {
     TreeNode *arg = args;
     while (d > 0) {
         arg = arg->next_arg;
-        if (arg == 0)
+        if (arg == NULL)
             break;
         d--;
     }
-    if (arg == 0)
+    if (arg == NULL)
         throw pgf_error("Missing argument");
-    size_t lindex = eval_param(r);
+    return arg->linearize(out, linearizer, r);
-    arg->linearize(out, linearizer, lindex);
 }
 
 void PgfLinearizer::TreeNode::linearize_var(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r)
@@ -52,20 +87,24 @@ void PgfLinearizer::TreeNode::linearize_var(PgfLinearizationOutputIface *out, Pg
     out->symbol_token(linearizer->printer.get_text());
 }
 
-void PgfLinearizer::TreeNode::linearize_seq(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, ref<PgfSequence> seq)
+bool PgfLinearizer::TreeNode::linearize_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item, vector<PgfSymbol> syms)
 {
-    for (size_t i = 0; i < seq->syms.size(); i++) {
+    for (size_t i = 0; i < syms.size(); i++) {
-        PgfSymbol sym = seq->syms[i];
+        PgfSymbol sym = syms[i];
 
         switch (ref<PgfSymbol>::get_tag(sym)) {
         case PgfSymbolCat::tag: {
             auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
-            linearize_arg(out, linearizer, sym_cat->d, &sym_cat->r);
+            size_t r = item->eval(ref<PgfLParam>::from_ptr(&sym_cat->r));
+            if (!linearize_arg(out, linearizer, sym_cat->d, r))
+                return false;
             break;
         }
         case PgfSymbolLit::tag: {
             auto sym_lit = ref<PgfSymbolLit>::untagged(sym);
-            linearize_arg(out, linearizer, sym_lit->d, &sym_lit->r);
+            size_t r = item->eval(ref<PgfLParam>::from_ptr(&sym_lit->r));
+            if (!linearize_arg(out, linearizer, sym_lit->d, r))
+                return false;
             break;
         }
         case PgfSymbolVar::tag: {
@@ -133,6 +172,7 @@ void PgfLinearizer::TreeNode::linearize_seq(PgfLinearizationOutputIface *out, Pg
             PreStack *pre = new PreStack();
             pre->next   = linearizer->pre_stack;
             pre->node   = this;
+            pre->item   = item;
             pre->sym_kp = sym_kp;
             pre->bind   = false;
             pre->capit  = CAPIT_NONE;
@@ -167,125 +207,77 @@ void PgfLinearizer::TreeNode::linearize_seq(PgfLinearizationOutputIface *out, Pg
             break;
         }
     }
-}
 
-size_t PgfLinearizer::TreeNode::eval_param(PgfLParam *param)
+    return true;
-{
-    size_t value = param->i0;
-    for (size_t j = 0; j < param->n_terms; j++) {
-        size_t factor = param->terms[j].factor;
-        size_t var    = param->terms[j].var;
-
-        if (var < var_count && var_values[var] != (size_t) -1) {
-            value += factor * var_values[var];
-        } else {
-            throw pgf_error("Unbound variable in resolving a linearization");
-        }
-    }
-    return value;
 }
 
 PgfLinearizer::TreeLinNode::TreeLinNode(PgfLinearizer *linearizer, ref<PgfConcrLin> lin)
   : TreeNode(linearizer)
 {
-    this->lin       = lin;
+    this->lin        = lin;
-    this->lin_index = 0;
+    this->rule_index = 0;
+    this->items = new Item*[lin->lincat->fields.size()]();
 }
 
 bool PgfLinearizer::TreeLinNode::resolve(PgfLinearizer *linearizer)
 {
-    vector<PgfHypo> hypos = lin->absfun->type->hypos;
+    while (rule_index < lin->rules.size()) {
-    size_t n_args = lin->args.size() / lin->res.size();
+        Item *item = new (lin->rules[rule_index]) Item();
-
+        item->rule = lin->rules[rule_index];
-    while (lin_index < lin->res.size()) {
-        size_t offset = lin_index*n_args;
-
-        ref<PgfPResult> pres = lin->res[lin_index];
-
-        // Unbind all variables
-        for (size_t j = 0; j < var_count; j++) {
-            var_values[j] = (size_t) -1;
-        }
 
         int i = 0;
         TreeNode *arg = args;
         while (arg != NULL) {
-            ref<PgfPArg> parg = lin->args.elem(offset+i);
+            if (!item->instantiate(item->rule->args[i], arg->value))
-            arg->check_category(linearizer, &hypos[i].type->name);
+                goto next;
 
-            if (arg->value < parg->param->i0)
+            arg = arg->next_arg;  i++;
-                break;
+        }
 
-            size_t value = arg->value - parg->param->i0;
+        {
-            for (size_t j = 0; j < parg->param->n_terms; j++) {
+            size_t max_value = 1;
-                size_t factor    = parg->param->terms[j].factor;
+            for (size_t i = 0; i < item->vars.size(); i++) {
-                size_t var       = parg->param->terms[j].var;
+                if (item->vars[i] == 0)
-                size_t var_value;
+                    max_value *= item->rule->ranges[i];
-
-                if (var < var_count && var_values[var] != (size_t) -1) {
-                    // The variable already has a value
-                    var_value = var_values[var];
-                } else {
-                    // The variable is not assigned yet
-                    var_value = value / factor;
-
-                    // find the range for the variable
-                    size_t range = 0;
-                    for (size_t k = 0; k < pres->vars.size(); k++) {
-                        ref<PgfVariableRange> var_range = pres->vars.elem(k);
-                        if (var_range->var == var) {
-                            range = var_range->range;
-                            break;
-                        }
-                    }
-                    if (range == 0)
-                        throw pgf_error("Unknown variable in resolving a linearization");
-
-                    if (var_value >= range)
-                        break;
-
-                    // Assign the variable;
-                    if (var >= var_count) {
-                        var_values = (size_t*)
-                            realloc(var_values, (var+1)*sizeof(size_t));
-                        while (var_count < var) {
-                            var_values[var_count++] = (size_t) -1;
-                        }
-                        var_count++;
-                    }
-                    var_values[var] = var_value;
-                }
-
-                value -= var_value * factor;
             }
 
-            if (value != 0)
+            for (size_t value = 0; value < max_value; value++) {
-                break;
+                Item *new_item = new (item) Item;
 
-            arg = arg->next_arg;
+                size_t v = value;
-            i++;
+                for (size_t i = 0; i < new_item->vars.size(); i++) {
+                    if (new_item->vars[i] == 0) {
+                        size_t range = new_item->rule->ranges[i];
+                        new_item->vars[i] = (v % range)+1;
+                        v = v / range;
+                    }
+                }
+
+                size_t lin_idx = new_item->eval(new_item->rule->lin_idx);
+                items[lin_idx] = new_item;
+
+                this->value = new_item->eval(new_item->rule->res);
+            }
         }
+    next:
+        delete item;
 
-        lin_index++;
+        rule_index++;
-
-        if (arg == NULL) {
-            value = eval_param(&pres->param);
-            return true;
-        }
     }
 
-    lin_index = 0;
+    return true;
-    return false;
 }
 
-void PgfLinearizer::TreeLinNode::check_category(PgfLinearizer *linearizer, PgfText *cat)
+bool PgfLinearizer::TreeLinNode::check_category(PgfLinearizer *linearizer, PgfText *cat)
 {
-    if (textcmp(&lin->absfun->type->name, cat) != 0)
+    return (textcmp(&lin->absfun->type->name, cat) == 0);
-        throw pgf_error("An attempt to linearize an expression which is not type correct");
 }
 
-void PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
+bool PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
 {
+    if (items[lindex] == NULL)
+        return false;
+
     PgfText *cat = &lin->absfun->type->name;
     PgfText *field = &*lin->lincat->fields[lindex];
 
@@ -302,9 +294,9 @@ void PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, Pgf
         linearizer->pre_stack->bracket_stack = bracket;
     }
 
-    size_t n_seqs = lin->seqs.size() / lin->res.size();
+    if (!linearize_item(out, linearizer,
-    ref<PgfSequence> seq = lin->seqs[(lin_index-1)*n_seqs + lindex];
+                        items[lindex],items[lindex]->rule->syms.as_vector()))
-    linearize_seq(out, linearizer, seq);
+        return false;
 
     if (linearizer->pre_stack == NULL)
         out->end_phrase(cat, fid, field, &lin->name);
@@ -318,6 +310,8 @@ void PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, Pgf
         bracket->fun   = &lin->name;
         linearizer->pre_stack->bracket_stack = bracket;
     }
+
+    return true;
 }
 
 ref<PgfConcrLincat> PgfLinearizer::TreeLinNode::get_lincat(PgfLinearizer *linearizer)
@@ -325,11 +319,22 @@ ref<PgfConcrLincat> PgfLinearizer::TreeLinNode::get_lincat(PgfLinearizer *linear
     return namespace_lookup(linearizer->concr->lincats, &lin->absfun->type->name);
 }
 
+PgfLinearizer::TreeLinNode::~TreeLinNode()
+{
+    size_t n_fields = lin->lincat->fields.size();
+    for (size_t i = 0; i < n_fields; i++) {
+        if (items[i] != NULL)
+            delete items[i];
+    }
+    delete[] items;
+};
+
 PgfLinearizer::TreeLindefNode::TreeLindefNode(PgfLinearizer *linearizer, PgfText *fun, PgfText *literal)
   : TreeNode(linearizer)
 {
     this->lincat    = 0;
-    this->lin_index = 0;
+    this->rule_index= 0;
+    this->items     = NULL;
     this->fun       = fun;
     this->literal   = literal;
 
@@ -355,73 +360,106 @@ PgfLinearizer::TreeLindefNode::TreeLindefNode(PgfLinearizer *linearizer, PgfText
 
 bool PgfLinearizer::TreeLindefNode::resolve(PgfLinearizer *linearizer)
 {
-    if (lincat == 0) {
+    if (lincat == 0)
-        return (lin_index = !lin_index);
+        return true;
-    } else {
+
-        ref<PgfPResult> pres = lincat->res[lin_index];
+    while (rule_index < lincat->n_lindefs) {
-        value = eval_param(&pres->param);
+        ref<PgfConcrRule> rule = lincat->rules[rule_index];
-        lin_index++;
+        Item *item = new (rule) Item();
-        if (lin_index <= lincat->n_lindefs)
+        item->rule = rule;
-            return true;
+
-        lin_index = 0;
+        size_t max_value = 1;
-        return false;
+        for (size_t i = 0; i < item->vars.size(); i++) {
+            if (item->vars[i] == 0)
+                max_value *= item->rule->ranges[i];
+        }
+
+        for (size_t value = 0; value < max_value; value++) {
+            Item *new_item = new (item) Item;
+
+            size_t v = value;
+            for (size_t i = 0; i < new_item->vars.size(); i++) {
+                if (new_item->vars[i] == 0) {
+                    size_t range = new_item->rule->ranges[i];
+                    new_item->vars[i] = (v % range)+1;
+                    v = v / range;
+                }
+            }
+
+            size_t lin_idx = new_item->eval(new_item->rule->lin_idx);
+            items[lin_idx] = new_item;
+
+            this->value = new_item->eval(new_item->rule->res);
+        }
+        delete item;
+
+        rule_index++;
     }
+
+    return true;
 }
 
-void PgfLinearizer::TreeLindefNode::check_category(PgfLinearizer *linearizer, PgfText *cat)
+bool PgfLinearizer::TreeLindefNode::check_category(PgfLinearizer *linearizer, PgfText *cat)
 {
     lincat = namespace_lookup(linearizer->concr->lincats, cat);
-    if (lincat == 0)
+    if (lincat != 0)
-        throw pgf_error("Cannot find a lincat for a category");
+        this->items = new Item*[lincat->fields.size()]();
+    return true;
 }
 
-void PgfLinearizer::TreeLindefNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r)
+bool PgfLinearizer::TreeLindefNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r)
 {
     linearizer->flush_pre_stack(out, literal);
     out->symbol_token(literal);
 
     TreeNode *arg = args;
     while (arg != NULL) {
-        arg->linearize(out,linearizer,0);
+        if (!arg->linearize(out,linearizer,0))
+            return false;
         arg = arg->next_arg;
     }
+    return true;
 }
 
-void PgfLinearizer::TreeLindefNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
+bool PgfLinearizer::TreeLindefNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
 {
-    if (lincat != 0) {
+    if (lincat==0) {
-        PgfText *field = &*lincat->fields[lindex];
+        return linearize_arg(out, linearizer, 0, 0);
-        if (linearizer->pre_stack == NULL)
-            out->begin_phrase(&lincat->name, fid, field, fun);
-        else {
-            BracketStack *bracket = new BracketStack();
-            bracket->next  = linearizer->pre_stack->bracket_stack;
-            bracket->begin = true;
-            bracket->fid   = fid;
-            bracket->cat   = &lincat->name;
-            bracket->field = field;
-            bracket->fun   = fun;
-            linearizer->pre_stack->bracket_stack = bracket;
-        }
-
-        ref<PgfSequence> seq = lincat->seqs[(lin_index-1)*lincat->fields.size() + lindex];
-        linearize_seq(out, linearizer, seq);
-
-        if (linearizer->pre_stack == NULL)
-            out->end_phrase(&lincat->name, fid, field, fun);
-        else {
-            BracketStack *bracket = new BracketStack();
-            bracket->next  = linearizer->pre_stack->bracket_stack;
-            bracket->begin = false;
-            bracket->fid   = fid;
-            bracket->cat   = &lincat->name;
-            bracket->field = field;
-            bracket->fun   = fun;
-            linearizer->pre_stack->bracket_stack = bracket;
-        }
-    } else {
-        linearize_arg(out, linearizer, 0, NULL);
     }
+
+    PgfText *cat = &lincat->name;
+    PgfText *field = &*lincat->fields[lindex];
+
+    if (linearizer->pre_stack == NULL)
+        out->begin_phrase(cat, fid, field, linearizer->wild);
+    else {
+        BracketStack *bracket = new BracketStack();
+        bracket->next  = linearizer->pre_stack->bracket_stack;
+        bracket->begin = true;
+        bracket->fid   = fid;
+        bracket->cat   = cat;
+        bracket->field = field;
+        bracket->fun   = linearizer->wild;
+        linearizer->pre_stack->bracket_stack = bracket;
+    }
+
+    if (!linearize_item(out, linearizer,
+                        items[lindex],items[lindex]->rule->syms.as_vector()))
+        return false;
+
+    if (linearizer->pre_stack == NULL)
+        out->end_phrase(cat, fid, field, linearizer->wild);
+    else {
+        BracketStack *bracket = new BracketStack();
+        bracket->next  = linearizer->pre_stack->bracket_stack;
+        bracket->begin = false;
+        bracket->fid   = fid;
+        bracket->cat   = cat;
+        bracket->field = field;
+        bracket->fun   = linearizer->wild;
+        linearizer->pre_stack->bracket_stack = bracket;
+    }
+    return true;
 }
 
 ref<PgfConcrLincat> PgfLinearizer::TreeLindefNode::get_lincat(PgfLinearizer *linearizer)
@@ -429,11 +467,27 @@ ref<PgfConcrLincat> PgfLinearizer::TreeLindefNode::get_lincat(PgfLinearizer *lin
     return lincat;
 }
 
+PgfLinearizer::TreeLindefNode::~TreeLindefNode()
+{
+    if (lincat && items != NULL) {
+        size_t n_fields = lincat->fields.size();
+        for (size_t i = 0; i < n_fields; i++) {
+            if (items[i] != NULL)
+                delete items[i];
+        }
+        delete[] items;
+    }
+
+    free(fun);
+    free(literal);
+};
+
 PgfLinearizer::TreeLinrefNode::TreeLinrefNode(PgfLinearizer *linearizer, TreeNode *root)
   : TreeNode(linearizer)
 {
     args = root;
-    lin_index=0;
+    rule_index=0;
+    item = NULL;
 }
 
 bool PgfLinearizer::TreeLinrefNode::resolve(PgfLinearizer *linearizer)
@@ -441,83 +495,56 @@ bool PgfLinearizer::TreeLinrefNode::resolve(PgfLinearizer *linearizer)
     TreeNode *root = args;
     ref<PgfConcrLincat> lincat = root->get_lincat(linearizer);
     if (lincat == 0)
-        return (lin_index = !lin_index);
+        return (rule_index = !rule_index);
 
-    while (lincat->n_lindefs+lin_index < lincat->res.size()) {
+    while (rule_index < lincat->rules.size()) {
-        // Unbind all variables
+        Item *item = new (lincat->rules[lincat->n_lindefs+rule_index]) Item();
-        for (size_t j = 0; j < var_count; j++) {
+        item->rule = lincat->rules[lincat->n_lindefs+rule_index];
-            var_values[j] = (size_t) -1;
+
+        if (!item->instantiate(item->rule->args[0], root->value)) {
+            rule_index++;
+            continue;
         }
 
-        ref<PgfPResult> pres = lincat->res[lincat->n_lindefs+lin_index];
+        size_t max_value = 1;
-        ref<PgfPArg> parg = lincat->args.elem(lincat->n_lindefs+lin_index);
+        for (size_t i = 0; i < item->vars.size(); i++) {
+            if (item->vars[i] == 0)
+                max_value *= item->rule->ranges[i];
+        }
 
-        if (root->value < parg->param->i0)
+        for (size_t value = 0; value < max_value; value++) {
-            break;
+            size_t v = value;
-
+            for (size_t i = 0; i < item->vars.size(); i++) {
-        size_t value = root->value - parg->param->i0;
+                if (item->vars[i] == 0) {
-        for (size_t j = 0; j < parg->param->n_terms; j++) {
+                    size_t range = item->rule->ranges[i];
-            size_t factor    = parg->param->terms[j].factor;
+                    item->vars[i] = v % range;
-            size_t var       = parg->param->terms[j].var;
+                    v = v / range;
-            size_t var_value;
-
-            if (var < var_count && var_values[var] != (size_t) -1) {
-                // The variable already has a value
-                var_value = var_values[var];
-            } else {
-                // The variable is not assigned yet
-                var_value = value / factor;
-
-                // find the range for the variable
-                size_t range = 0;
-                for (size_t k = 0; k < pres->vars.size(); k++) {
-                    ref<PgfVariableRange> var_range = pres->vars.elem(k);
-                    if (var_range->var == var) {
-                        range = var_range->range;
-                        break;
-                    }
                 }
-                if (range == 0)
-                    throw pgf_error("Unknown variable in resolving a linearization");
-
-                if (var_value >= range)
-                    break;
-
-                // Assign the variable;
-                if (var >= var_count) {
-                    var_values = (size_t*)
-                        realloc(var_values, (var+1)*sizeof(size_t));
-                    while (var_count < var) {
-                        var_values[var_count++] = (size_t) -1;
-                    }
-                    var_count++;
-                }
-                var_values[var] = var_value;
             }
 
-            value -= var_value * factor;
+            this->item = new (item) Item;
+            this->value = item->eval(this->item->rule->res);
         }
+        delete item;
 
-        lin_index++;
+        break;
-        if (value == 0) {
-            value = eval_param(&pres->param);
-            return true;
-        }
     }
 
-    lin_index = 0;
+    if (item == NULL) {
-    return false;
+        rule_index = 0;
+        return false;
+    }
+
+    return true;
 }
 
-void PgfLinearizer::TreeLinrefNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
+bool PgfLinearizer::TreeLinrefNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
 {
     ref<PgfConcrLincat> lincat = args->get_lincat(linearizer);
     if (lincat != 0) {
-        size_t i = lincat->n_lindefs*lincat->fields.size() + (lin_index-1);
+        return linearize_item(out, linearizer, item, item->rule->syms.as_vector());
-        ref<PgfSequence> seq = lincat->seqs[i];
-        linearize_seq(out, linearizer, seq);
     } else {
-        args->linearize(out, linearizer, lindex);
+        return args->linearize(out, linearizer, lindex);
     }
 }
 
@@ -526,6 +553,11 @@ ref<PgfConcrLincat> PgfLinearizer::TreeLinrefNode::get_lincat(PgfLinearizer *lin
     return 0;
 }
 
+PgfLinearizer::TreeLinrefNode::~TreeLinrefNode()
+{
+    delete item;
+}
+
 PgfLinearizer::TreeLitNode::TreeLitNode(PgfLinearizer *linearizer, ref<PgfConcrLincat> lincat, PgfText *lit)
   : TreeNode(linearizer)
 {
@@ -533,13 +565,12 @@ PgfLinearizer::TreeLitNode::TreeLitNode(PgfLinearizer *linearizer, ref<PgfConcrL
     this->literal = lit;
 }
 
-void PgfLinearizer::TreeLitNode::check_category(PgfLinearizer *linearizer, PgfText *cat)
+bool PgfLinearizer::TreeLitNode::check_category(PgfLinearizer *linearizer, PgfText *cat)
 {
-    if (textcmp(&lincat->name, cat) != 0)
+    return (textcmp(&lincat->name, cat) == 0);
-        throw pgf_error("An attempt to linearize an expression which is not type correct");
 }
 
-void PgfLinearizer::TreeLitNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
+bool PgfLinearizer::TreeLitNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
 {
     PgfText *field = NULL;
     if (lincat != 0) {
@@ -553,6 +584,8 @@ void PgfLinearizer::TreeLitNode::linearize(PgfLinearizationOutputIface *out, Pgf
     out->symbol_token(literal);
     if (lincat != 0)
         out->end_phrase(&lincat->name, fid, field, linearizer->wild);
+
+    return true;
 }
 
 ref<PgfConcrLincat> PgfLinearizer::TreeLitNode::get_lincat(PgfLinearizer *linearizer)
@@ -570,6 +603,7 @@ PgfLinearizer::PgfLinearizer(PgfPrintContext *ctxt, ref<PgfConcr> concr, PgfMars
     this->args  = NULL;
     this->capit = CAPIT_NONE;
     this->pre_stack = NULL;
+    this->type_error = false;
     this->wild = (PgfText*) malloc(sizeof(PgfText)+2);
     this->wild->size = 1;
     this->wild->text[0] = '_';
@@ -609,6 +643,10 @@ PgfLinearizer::~PgfLinearizer()
 
 bool PgfLinearizer::resolve()
 {
+    if (type_error) {
+        throw pgf_error("An attempt to linearize an expression which is not type correct");
+    }
+
     for (;;) {
         if (!prev || prev->resolve(this)) {
             if (next == NULL)
@@ -663,14 +701,14 @@ void PgfLinearizer::flush_pre_stack(PgfLinearizationOutputIface *out, PgfText *t
                 ref<PgfAlternative> alt = pre->sym_kp->alts.elem(i);
                 for (ref<PgfText> prefix : alt->prefixes) {
                     if (cmp(token, &(*prefix))) {
-                        pre->node->linearize_seq(out, this, alt->form);
+                        pre->node->linearize_item(out, this, pre->item, alt->form);
                         goto done;
                     }
                 }
             }
         }
 
-        pre->node->linearize_seq(out, this, pre->sym_kp->default_form);
+        pre->node->linearize_item(out, this, pre->item, pre->sym_kp->default_form);
 
     done:
         if (pre->bracket_stack != NULL)
@@ -739,9 +777,19 @@ PgfExpr PgfLinearizer::emeta(PgfMetaId meta)
 PgfExpr PgfLinearizer::efun(PgfText *name)
 {
     ref<PgfConcrLin> lin = namespace_lookup(concr->lins, name);
-    if (lin != 0)
+    if (lin != 0) {
+        TreeNode *node = args;
+        size_t i = 0;
+        vector<PgfHypo> hypos = lin->absfun->type->hypos;
+        while (node != NULL) {
+            if (!node->check_category(this, &hypos[i].type->name)) {
+                type_error = true;
+            }
+            node = node->next_arg; i++;
+        }
+
         return (PgfExpr) new TreeLinNode(this, lin);
-    else {
+    } else {
         printer.puts("[");
         printer.efun(name);
         printer.puts("]");

src/runtime/c/pgf/linearizer.h

@@ -26,6 +26,48 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
     ref<PgfConcr> concr;
     PgfMarshaller *m;
 
+    struct Item {
+        ref<PgfConcrRule> rule;
+
+        struct {
+            size_t &operator[](int i) {
+                Item *item = containerof(Item,vars,this);
+                return ((size_t*) (item+1))[i];
+            }
+            size_t size() {
+                Item *item = containerof(Item,vars,this);
+                return item->rule->ranges.size();
+            }
+        } vars;
+
+        void *operator new(size_t sz, ref<PgfConcrRule> rule)
+        {
+            size_t sz2 = rule->ranges.size()*sizeof(size_t);
+            Item *new_item = (Item *) malloc(sz+sz2);
+            memset(new_item, 0, sz+sz2);
+            return new_item;
+        }
+
+        void *operator new(size_t sz, Item *item)
+        {
+            size_t sz2 = item->vars.size()*sizeof(size_t);
+            Item *new_item = (Item *) malloc(sz+sz2);
+            memcpy(new_item, item, sz+sz2);
+            return new_item;
+        }
+
+        void operator delete(void *p)
+        {
+            free(p);
+        }
+        
+        Item() {
+        }
+
+        bool instantiate(ref<PgfLParam> lparam,size_t value);
+        size_t eval(ref<PgfLParam> lparam);
+    };
+
     struct TreeNode {
         TreeNode *next;
         TreeNode *next_arg;
@@ -34,58 +76,60 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
         int fid;
 
         size_t value;
-        size_t var_count;
-        size_t *var_values;
 
         size_t n_hoas_vars;
         PgfText **hoas_vars;
 
         TreeNode(PgfLinearizer *linearizer);
         virtual bool resolve(PgfLinearizer *linearizer) { return true; };
-        virtual void check_category(PgfLinearizer *linearizer, PgfText *cat)=0;
+        virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat)=0;
-        virtual void linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r);
+        virtual bool linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r);
         virtual void linearize_var(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r);
-        virtual void linearize_seq(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, ref<PgfSequence> seq);
+        virtual bool linearize_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item, vector<PgfSymbol> syms);
-        virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)=0;
+        virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)=0;
-        size_t eval_param(PgfLParam *param);
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer)=0;
-        virtual ~TreeNode() { free(var_values); free(hoas_vars); };
+        virtual ~TreeNode() { free(hoas_vars); };
     };
 
     struct TreeLinNode : public TreeNode {
         ref<PgfConcrLin> lin;
-        size_t lin_index;
+        size_t rule_index;
+        Item **items;
 
         TreeLinNode(PgfLinearizer *linearizer, ref<PgfConcrLin> lin);
         virtual bool resolve(PgfLinearizer *linearizer);
-        virtual void check_category(PgfLinearizer *linearizer, PgfText *cat);
+        virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat);
-        virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
+        virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
+        virtual ~TreeLinNode();
     };
 
     struct TreeLindefNode : public TreeNode {
         ref<PgfConcrLincat> lincat;
-        size_t lin_index;
+        size_t rule_index;
+        Item **items;
         PgfText *fun;
         PgfText *literal;
 
         TreeLindefNode(PgfLinearizer *linearizer, PgfText *fun, PgfText *lit);
         virtual bool resolve(PgfLinearizer *linearizer);
-        virtual void check_category(PgfLinearizer *linearizer, PgfText *cat);
+        virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat);
-        virtual void linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r);
+        virtual bool linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r);
-        virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
+        virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
-        ~TreeLindefNode() { free(fun); free(literal); };
+        ~TreeLindefNode();
     };
 
     struct TreeLinrefNode : public TreeNode {
-        size_t lin_index;
+        size_t rule_index;
+        Item *item;
 
         TreeLinrefNode(PgfLinearizer *linearizer, TreeNode *root);
         virtual bool resolve(PgfLinearizer *linearizer);
-        virtual void check_category(PgfLinearizer *linearizer, PgfText *cat) {};
+        virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat) { return true; };
-        virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
+        virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
+        ~TreeLinrefNode();
     };
 
     struct TreeLitNode : public TreeNode {
@@ -93,8 +137,8 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
         PgfText *literal;
 
         TreeLitNode(PgfLinearizer *linearizer, ref<PgfConcrLincat> lincat, PgfText *lit);
-        virtual void check_category(PgfLinearizer *linearizer, PgfText *cat);
+        virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat);
-        virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
+        virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
         ~TreeLitNode() { free(literal); };
     };
@@ -102,8 +146,8 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
     struct TreeChunksNode : public TreeNode {
         TreeChunksNode(PgfLinearizer *linearizer);
         virtual bool resolve(PgfLinearizer *linearizer);
-        virtual void check_category(PgfLinearizer *linearizer, PgfText *cat);
+        virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat);
-        virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
+        virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
     };
 
@@ -129,6 +173,7 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
     struct PreStack {
         PreStack *next;
         TreeNode *node;
+        Item *item;
         ref<PgfSymbolKP> sym_kp;
         bool bind;
         CapitState capit;
@@ -138,6 +183,7 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
     PreStack *pre_stack;
     void flush_pre_stack(PgfLinearizationOutputIface *out, PgfText *token);
 
+    bool type_error;
     PgfText *wild;
 
 public:
@@ -145,9 +191,11 @@ public:
 
     bool resolve();
     void reverse_and_label(bool add_linref);
-    void linearize(PgfLinearizationOutputIface *out, size_t lindex) {
+    bool linearize(PgfLinearizationOutputIface *out, size_t lindex) {
-        prev->linearize(out, this, lindex);
+        if (!prev->linearize(out, this, lindex))
+            return false;
         flush_pre_stack(out, NULL);
+        return true;
     }
     ref<PgfConcrLincat> get_lincat() {
         return prev->get_lincat(this);

src/runtime/c/pgf/parser.h

@@ -1,191 +1,340 @@
 #ifndef LR_TABLE_H
 #define LR_TABLE_H
 
-#include "md5.h"
-
-class PGF_INTERNAL_DECL PgfLRTableMaker
-{
-    struct CCat;
-    struct Production;
-    struct Item;
-    struct State;
-
-    struct CompareItem;
-    static const CompareItem compare_item;
-
-    typedef std::pair<ref<PgfText>,size_t> Key0;
-
-    struct PGF_INTERNAL_DECL CompareKey0 : std::less<Key0> {
-        bool operator() (const Key0& k1, const Key0& k2) const {
-            int cmp = textcmp(k1.first,k2.first);
-            if (cmp < 0)
-                return true;
-            else if (cmp > 0)
-                return false;
-
-            return (k1.second < k2.second);
-        }
-    };
-
-    typedef std::pair<ref<PgfConcrLincat>,size_t> Key1;
-
-    struct PGF_INTERNAL_DECL CompareKey1 : std::less<Key1> {
-        bool operator() (const Key1& k1, const Key1& k2) const {
-            if (k1.first < k2.first)
-                return true;
-            else if (k1.first > k2.first)
-                return false;
-
-            return (k1.second < k2.second);
-        }
-    };
-
-    typedef std::pair<CCat*,size_t> Key2;
-
-    struct PGF_INTERNAL_DECL CompareKey2 : std::less<Key2> {
-        bool operator() (const Key2& k1, const Key2& k2) const {
-            if (k1.first < k2.first)
-                return true;
-            else if (k1.first > k2.first)
-                return false;
-
-            return (k1.second < k2.second);
-        }
-    };
-
-    typedef std::pair<ref<PgfSequence>,size_t> Key3;
-
-    struct PGF_INTERNAL_DECL CompareKey3 : std::less<Key3> {
-        bool operator() (const Key3& k1, const Key3& k2) const;
-    };
-
-    ref<PgfAbstr> abstr;
-    ref<PgfConcr> concr;
-
-    size_t ccat_id;
-    size_t state_id;
-
-    std::queue<State*> todo;
-    std::map<MD5Digest,State*> states;
-    std::map<Key0,CCat*,CompareKey0> ccats1;
-    std::map<Key2,CCat*,CompareKey2> ccats2;
-
-    // The Threefold Way of building an automaton
-    typedef enum { INIT, PROBE, REPEAT } Fold;
-
-    void process(State *state, Fold fold, Item *item);
-    void symbol(State *state, Fold fold, Item *item, PgfSymbol sym);
-
-    template<class T>
-    void predict(State *state, Fold fold, Item *item, T cat,
-                 vector<PgfVariableRange> vars, PgfLParam *r);
-    void predict(State *state, Fold fold, Item *item, ref<PgfText> cat, size_t lin_idx);
-    void predict(State *state, Fold fold, Item *item, CCat *ccat, size_t lin_idx);
-    void predict(ref<PgfAbsFun> absfun, CCat *ccat);
-    void complete(State *state, Fold fold, Item *item);
-
-    void print_production(CCat *ccat, Production *prod);
-    void print_item(Item *item);
-
-    void internalize_state(State *&state);
-
-public:
-    PgfLRTableMaker(ref<PgfAbstr> abstr, ref<PgfConcr> concr);
-    vector<PgfLRState> make();
-    ~PgfLRTableMaker();
-};
-
-class PGF_INTERNAL_DECL PgfLCTableMaker
-{
-    ref<PgfAbstr> abstr;
-    ref<PgfConcr> concr;
-
-
-    std::map<ref<PgfConcrLincat>,std::vector<ref<PgfLCEdge>>> forwards;
-    std::map<ref<PgfConcrLincat>,std::vector<ref<PgfLCEdge>>> backwards;
-
-    ref<PgfLCEdge> compute_unifier(ref<PgfLCEdge> edge1, ref<PgfLCEdge> edge2);
-    void update_closure(ref<PgfLCEdge> edge);
-    void rename(ref<PgfLCEdge> edge);
-    void add_edge(ref<PgfLCEdge> edge);
-    void print_edge(ref<PgfLCEdge> edge);
-
-public:
-    PgfLCTableMaker(ref<PgfAbstr> abstr, ref<PgfConcr> concr);
-    vector<PgfLRState> make();
-    ~PgfLCTableMaker();
-};
-
 class PgfPrinter;
 
-class PGF_INTERNAL_DECL PgfParser : public PgfPhraseScanner, public PgfExprEnum
+class PGF_INTERNAL_DECL PgfAbstractParser
 {
-    ref<PgfConcr> concr;
+    typedef size_t hash_t;
-    PgfText *sentence;
-    bool case_sensitive;
-    PgfMarshaller *m;
-    PgfUnmarshaller *u;
 
-    struct Choice;
+protected:
-    struct Production;
+    ref<PgfConcr> concr;
-    struct StackNode;
+
-    struct Stage;
+    struct CCat;
+    struct Cont;
+    struct Item;
+    struct State;
     struct ExprState;
-    struct ExprInstance;
+
-    struct CompareExprState : std::less<ExprState*> {
+    struct Production {
-        bool operator() (const ExprState *state1, const ExprState *state2) const;
+        ref<PgfConcrRule> rule;
+
+        struct {
+            size_t &operator[](int i) const {
+                Production *prod = containerof(Production,vars,this);
+                return ((size_t*) (((CCat**) (prod+1))+prod->args.size()))[i];
+            }
+            size_t size() const {
+                Production *prod = containerof(Production,vars,this);
+                return prod->rule->ranges.size();
+            }
+        } vars;
+
+        struct {
+            CCat *&operator[](int i) const {
+                Production *prod = containerof(Production,args,this);
+                return ((CCat**) (prod+1))[i];
+            }
+            size_t size() const {
+                Production *prod = containerof(Production,args,this);
+                return (prod->rule->args != 0) ? prod->rule->args.size() : 0;
+            }
+        } args;
+
+        void *operator new(size_t sz, Item *item)
+        {
+            size_t sz2 = item->args.size()*sizeof(CCat*)
+                       + item->vars.size()*sizeof(size_t);
+            Production *prod = (Production *) malloc(sz+sz2);
+            memcpy(prod+1, item+1, sz2);
+            return prod;
+        }
+
+        void *operator new(size_t sz, ref<PgfItem> pitem)
+        {
+            size_t sz2 = pitem->args.size()*sizeof(CCat*)
+                       + pitem->vars.size()*sizeof(size_t);
+            Production *prod = (Production *) malloc(sz+sz2);
+            memset(prod+1,0,sz2);
+            return prod;
+        }
+
+        void operator delete(void *p)
+        {
+            free(p);
+        }
+
+        Production() {
+        }
     };
 
-    Stage *before, *after, *ahead;
+    struct ExprProb {
-    std::priority_queue<ExprState*, std::vector<ExprState*>, CompareExprState> queue;
+        PgfExpr expr;
-    int last_fid;
+        prob_t prob;
+        hash_t hash;
         
-    std::vector<Choice*> dynamic;
+        ExprProb(PgfExpr expr, prob_t prob, hash_t hash) {
-    std::map<object,Choice*> persistant;
+            this->expr = expr;
+            this->prob = prob;
+            this->hash = hash;
+        }
+    };
 
-    std::vector<PgfExpr> exprs;
+    struct CCat {
+        PgfMetaId fid;
+        ref<PgfCCat> epsilon;
+        Cont *cont;
+        State *state;
+        interval_t value;
+        interval_t lin_idx;
+        prob_t viterbi_prob;
+        bool covered;
+        std::vector<Production*> prods;
+        std::vector<ExprState*> pending;
+        std::vector<ExprProb> exprs;
 
-    Choice *top_choice;
+        ~CCat();
-    size_t top_choice_index;
+    };
 
-    bool shift(StackNode *parent, ref<PgfConcrLincat> lincat, size_t r, Production *prod,
+    struct State {
-               Stage *before, Stage *after);
+        PgfTextSpot start, end;
-    void shift(StackNode *parent, Stage *before);
+        bool needs_bind;
-    void shift(StackNode *parent, Stage *before, Stage *after);
+        std::map<ref<PgfConcrLincat>,Cont*> conts1;
-    void reduce(StackNode *parent, ref<PgfConcrLin> lin, ref<PgfLRReduce> red,
+        std::map<CCat*,Cont*> conts2;
-                size_t n, std::vector<Choice*> &args,
+        std::map<Cont*,interval_map<interval_map<CCat*>>> completed;
-                Stage *before, Stage *after);
+        std::vector<Item*> queue;
-    Choice *retrieve_choice(ref<PgfLRReduceArg> arg);
+        prob_t viterbi_prob;
-    void complete(StackNode *parent, ref<PgfConcrLincat> lincat, size_t r,
-                  size_t n, std::vector<Choice*> &args);
-    void reduce_all(StackNode *state);
-    void print_prod(Choice *choice, Production *prod);
-    void print_transition(StackNode *source, StackNode *target, Stage *stage, ref<PgfLRShiftKS> shift);
 
-    typedef std::map<std::pair<Choice*,Choice*>,Choice*> intersection_map;
+        State *next;
 
-    Choice *intersect_choice(Choice *choice1, Choice *choice2, intersection_map &im);
+        bool has_items() {
+            return queue.size() > 0;
+        }
 
-    void print_expr_state_before(PgfPrinter *printer, ExprState *state);
+        void push_item(Item *item) {
-    void print_expr_state_after(PgfPrinter *printer, ExprState *state);
+            queue.push_back(item);
-    void print_expr_state(ExprState *state);
+            std::push_heap(queue.begin(), queue.end(), item_prob_comp);
+        }
 
-    void predict_expr_states(Choice *choice, prob_t outside_prob);
+        Item *pop_item() {
-    bool process_expr_state(ExprState *state);
+            Item *item = queue.front();
-    void complete_expr_state(ExprState *state);
+            std::pop_heap(queue.begin(), queue.end(), item_prob_comp);
-    void combine_expr_state(ExprState *state, ExprInstance &inst);
+            queue.pop_back();
+            return item;
+        }
+    };
+
+    static struct ItemProbComparator : std::less<Item*> {
+        bool operator()(Item *item1, Item *item2) {
+            return item1->inside_prob+item1->outside_prob > item2->inside_prob+item2->outside_prob;
+        }
+    } item_prob_comp;
+
+    struct ItemComparator : std::less<Item*> {
+        bool operator()(Item *item1, Item *item2);
+    };
+
+    struct Cont {
+        CCat *ccat;
+        ref<PgfConcrLincat> lincat;
+        State *state;
+        interval_map<interval_map<std::vector<Item*>>> suspended;
+        std::set<Item*,ItemComparator> predicted;
+
+        ~Cont();
+    };
+
+    struct Item {
+        Cont *cont;
+        uint16_t pre_alt;
+        uint16_t pre_dot;
+        uint16_t dot;
+        vector<PgfSymbol> syms;
+        ref<PgfConcrRule> rule;
+        prob_t inside_prob;
+        prob_t outside_prob;
+
+        struct {
+            size_t &operator[](int i) const {
+                Item *item = containerof(Item,vars,this);
+                return ((size_t*) (((CCat**) (item+1))+item->args.size()))[i];
+            }
+            size_t size() const {
+                Item *item = containerof(Item,vars,this);
+                return item->rule->ranges.size();
+            }
+        } vars;
+
+        struct {
+            CCat *&operator[](int i) const {
+                Item *item = containerof(Item,args,this);
+                return ((CCat**) (item+1))[i];
+            }
+            size_t size() const {
+                Item *item = containerof(Item,args,this);
+                return (item->rule->args != 0) ? item->rule->args.size() : 0;
+            }
+        } args;
+
+        void *operator new(size_t sz, ref<PgfConcrRule> rule)
+        {
+            size_t sz2 = rule->args.size()*sizeof(CCat*)
+                       + rule->ranges.size()*sizeof(size_t);
+            Item *new_item = (Item *) malloc(sz+sz2);
+            memset(new_item+1, 0, sz2);
+            return new_item;
+        }
+
+        void *operator new(size_t sz, Item *item)
+        {
+            size_t sz2 = item->args.size()*sizeof(CCat*)
+                       + item->vars.size()*sizeof(size_t);
+            Item *new_item = (Item *) malloc(sz+sz2);
+            memcpy(new_item, item, sz+sz2);
+            return new_item;
+        }
+
+        void operator delete(void *p)
+        {
+            free(p);
+        }
+        
+        Item() {
+        }
+    };
+
+    struct ExprState {
+        PgfExpr expr;
+        prob_t prob;
+        hash_t hash;
+
+        CCat *res;
+
+        size_t index;
+        size_t n_args;
+        CCat *args[];
+
+        void *operator new(size_t sz, size_t n_args)
+        {
+            ExprState *estate = (ExprState *)
+                malloc(sz+n_args*sizeof(CCat*));
+            return estate;
+        }
+        
+        void operator delete(void *p)
+        {
+            free(p);
+        }
+
+        ExprState() {
+        }
+    };
+
+    State *current_state;
+    std::map<PgfMetaId,CCat*> epsilons;
+    PgfMetaId initial_fid, last_fid;
+
+    void process(Item *item, State *state);
+    void symbol(Item *item, State *state, PgfSymbol sym);
+    void complete(Item *item, State *state);
+
+    virtual State *new_state(const PgfTextSpot &start, prob_t viterbi_prob)=0;
+    virtual void symbol_token(Item *item, State *state, ref<PgfSymbolKS> symks)=0;
+    virtual void symbol_bind(Item *item, State *state, PgfSymbol sym)=0;
+    virtual void suspend(Cont *cont, Item *item, bool do_predict, ref<PgfSymbolCat> symcat,interval_t value_i,interval_t lin_idx_i)=0;
+    virtual void final_item(State *state,CCat *ccat,Item *item,interval_t value,interval_t lin_idx)=0;
+    virtual void bu_predict(State *state, prob_t outside_prob, CCat *ccat)=0;
+
+    void td_epsilon(State *state, Cont *cont, ref<PgfItem> pitem, Item *xitem, ref<PgfSymbolCat> symcat);
+    void td_predict(State *state, Cont *cont, Production *prod, Item *xitem, ref<PgfSymbolCat> symcat);
+    void combine(State *state, Item *item, CCat *ccat);
+
+    static
+    bool instantiate(ref<PgfConcrRule> rule1, size_t *values1, ref<PgfLParam> lparam1,
+                     ref<PgfConcrRule> rule2, size_t *values2, ref<PgfLParam> lparam2);
+
+    static
+    interval_t interval(ref<PgfConcrRule> rule, size_t *values, ref<PgfLParam> lparam);
+
+    void get_info(CCat *ccat, ref<PgfConcrRule> *rule, size_t **pvalues);
+    CCat *get_epsilon_ccat(PgfText *name, PgfMetaId fid);
+
+    static
+    void print_item(Item *item, State *state);
+
+    static
+    void print_prod(CCat *ccat, Production *prod);
 
 public:
-    PgfParser(ref<PgfConcr> concr, ref<PgfConcrLincat> start, PgfText *sentence, bool case_sensitive, PgfMarshaller *m, PgfUnmarshaller *u);
+    PgfAbstractParser(ref<PgfConcr> concr);
+    virtual ~PgfAbstractParser();
+};
+
+class PGF_INTERNAL_DECL PgfParser : private PgfAbstractParser, public PgfExprEnum
+{
+    PgfMarshaller *m;
+    PgfUnmarshaller *u;
+    PgfText *sentence;
+    uint8_t *end;
+    bool case_sensitive;
+
+    virtual State *new_state(const PgfTextSpot &start, prob_t viterbi_prob);
+    virtual void symbol_token(Item *item, State *state, ref<PgfSymbolKS> symks);
+    virtual void symbol_bind(Item *item, State *state, PgfSymbol sym);
+    virtual void suspend(Cont *cont,Item *item,bool do_predict,ref<PgfSymbolCat> symcat,interval_t value_i,interval_t lin_idx_i);
+    virtual void final_item(State *state,CCat *ccat,Item *item,interval_t value,interval_t lin_idx);
+    virtual void bu_predict(State *state, prob_t outside_prob, CCat *ccat);
+
+    void bu_predict(PgfPhrasetable<PgfSymbolBIND> phrasetable, State *state, prob_t outside_prob);
+    void bu_predict(PgfPhrasetable<PgfSymbolKS> phrasetable, State *state, prob_t outside_prob, ptrdiff_t min, ptrdiff_t max);
+    void make_chunks(State *state, std::vector<CCat*> &chunks, prob_t prob);
+    PgfExpr process_expr(ExprState *estate, prob_t *prob);
+
+    bool td_reachable(State *state, ref<PgfItem> pitem, std::map<ref<PgfConcrLincat>, bool> &visited);
+    Item *bu_item(State *state, prob_t outside_prob, ref<PgfItem> pitem);
+
+    static
+    void print_expr_state_left(PgfPrinter *printer, PgfMarshaller *m, ExprState *estate);
+    static
+    void print_expr_state_right(PgfPrinter *printer, ExprState *estate);
+    static
+    void print_expr_state(PgfMarshaller *m, ExprState *estate);
+
+    static struct ExprStateComparator : std::less<ExprState*> {
+        bool operator()(ExprState *estate1, ExprState *estate2) {
+            return estate1->prob > estate2->prob;
+        }
+    } estate_comp;
+
+    std::vector<ExprState*> queue;
+
+public:
+    PgfParser(ref<PgfConcr> concr, PgfText *sentence, bool case_sensitive, PgfMarshaller *m, PgfUnmarshaller *u);
     virtual ~PgfParser();
 
-	virtual void space(PgfTextSpot *start, PgfTextSpot *end, PgfExn* err);
+    void prepare(ref<PgfConcrLincat> start);
-    virtual void start_matches(PgfTextSpot *end, PgfExn* err);
-    virtual void match(ref<PgfConcrLin> lin, size_t seq_index, PgfExn* err);
-	virtual void end_matches(PgfTextSpot *end, PgfExn* err);
-
-    void prepare();
 
     PgfExpr fetch(PgfDB *db, prob_t *prob);
 };
+
+class PGF_INTERNAL_DECL PgfParseTableMaker : private PgfAbstractParser
+{
+private:
+    virtual State *new_state(const PgfTextSpot &start, prob_t viterbi_prob);
+    virtual void symbol_token(Item *item, State *state, ref<PgfSymbolKS> symks);
+    virtual void symbol_bind(Item *item, State *state, PgfSymbol sym);
+    virtual void suspend(Cont *cont, Item *item, bool do_predict, ref<PgfSymbolCat> symcat,interval_t value_i,interval_t lin_idx_i);
+    virtual void final_item(State *state, CCat *ccat,Item *item,interval_t value,interval_t lin_idx);
+    virtual void bu_predict(State *state, prob_t outside_prob, CCat *ccat);
+
+    static
+    ref<PgfItem> clone_item(Item *item);
+
+public:
+    PgfParseTableMaker(ref<PgfConcr> concr);
+    void insert_rule(ref<PgfConcrRule> rule);
+    void prepare();
+    PgfMetaId get_last_fid() { return last_fid; };
+};
+
 #endif

src/runtime/c/pgf/pgf.h

@@ -461,8 +461,6 @@ PGF_API_DECL
 void pgf_iter_lins(PgfDB *db, PgfConcrRevision cnc_revision,
                    PgfItor *itor, PgfExn *err);
 
-typedef struct PgfPhrasetableIds PgfPhrasetableIds;
-
 typedef struct PgfSequenceItor PgfSequenceItor;
 struct PgfSequenceItor {
 	int (*fn)(PgfSequenceItor* self, size_t seq_id, object value,
@@ -493,10 +491,10 @@ void pgf_lookup_cohorts(PgfDB *db, PgfConcrRevision cnc_revision,
                         PgfCohortsCallback* callback, PgfExn* err);
 
 PGF_API_DECL
-PgfPhrasetableIds *pgf_iter_sequences(PgfDB *db, PgfConcrRevision cnc_revision,
+void pgf_iter_sequences(PgfDB *db, PgfConcrRevision cnc_revision,
-                                      PgfSequenceItor *itor,
+                        PgfSequenceItor *itor,
-                                      PgfMorphoCallback *callback,
+                        PgfMorphoCallback *callback,
-                                      PgfExn *err);
+                        PgfExn *err);
 
 PGF_API_DECL
 void pgf_get_lincat_counts_internal(object o, size_t *counts);
@@ -505,26 +503,20 @@ PGF_API_DECL
 PgfText *pgf_get_lincat_field_internal(object o, size_t i);
 
 PGF_API_DECL
-size_t pgf_get_lin_get_prod_count(object o);
+size_t pgf_get_lin_rules_count(object o);
 
 PGF_API_DECL
-PgfText *pgf_print_lindef_internal(PgfPhrasetableIds *seq_ids, object o, size_t i);
+PgfText *pgf_print_lindef_internal(object o, size_t i);
 
 PGF_API_DECL
-PgfText *pgf_print_linref_internal(PgfPhrasetableIds *seq_ids, object o, size_t i);
+PgfText *pgf_print_linref_internal(object o, size_t i);
 
 PGF_API_DECL
-PgfText *pgf_print_lin_internal(PgfPhrasetableIds *seq_ids, object o, size_t i);
+PgfText *pgf_print_lin_internal(object o, size_t i);
-
-PGF_API_DECL
-PgfText *pgf_print_sequence_internal(size_t seq_id, object o);
 
 PGF_API_DECL
 PgfText *pgf_sequence_get_text_internal(object o);
 
-PGF_API_DECL
-void pgf_release_phrasetable_ids(PgfPhrasetableIds *seq_ids);
-
 PGF_API_DECL
 PgfExpr pgf_check_expr(PgfDB *db, PgfRevision revision,
                        PgfExpr e, PgfType ty,
@@ -620,14 +612,19 @@ void pgf_drop_category(PgfDB *db, PgfRevision revision,
 
 PGF_API_DECL
 PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision,
-                                     PgfText *name,
+                                     PgfText *name, void **p_tm,
                                      PgfExn *err);
 
 PGF_API_DECL
 PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision,
-                                    PgfText *name,
+                                    PgfText *name, void **p_tm,
                                     PgfExn *err);
 
+PGF_API_DECL
+void pgf_free_parse_table(PgfDB *db,
+                          PgfRevision revision, PgfConcrRevision cnc_revision,
+                          void *table_maker);
+
 PGF_API_DECL
 void pgf_drop_concrete(PgfDB *db, PgfRevision revision,
                        PgfText *name,
@@ -635,11 +632,11 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision,
 
 #ifdef __cplusplus
 struct PgfLinBuilderIface {
-    virtual void start_production(PgfExn *err)=0;
+    virtual void start_rule(size_t n_vars, size_t n_syms, PgfExn *err)=0;
-    virtual void add_argument(size_t n_hypos, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
+    virtual void add_argument(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
-    virtual void set_result(size_t n_vars, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
+    virtual void set_result(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
-    virtual void add_variable(size_t var, size_t range, PgfExn *err)=0;
+    virtual void set_lin_idx(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
-    virtual void start_sequence(size_t n_syms, PgfExn *err)=0;
+    virtual void add_variable(size_t range, PgfExn *err)=0;
     virtual void add_symcat(size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
     virtual void add_symlit(size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
     virtual void add_symvar(size_t d, size_t r, PgfExn *err)=0;
@@ -654,9 +651,7 @@ struct PgfLinBuilderIface {
     virtual void add_symsoftspace(PgfExn *err)=0;
     virtual void add_symcapit(PgfExn *err)=0;
     virtual void add_symallcapit(PgfExn *err)=0;
-    virtual object end_sequence(PgfExn *err)=0;
+    virtual void end_rule(PgfExn *err)=0;
-    virtual void add_sequence_id(object seq_id, PgfExn *err)=0;
-    virtual void end_production(PgfExn *err)=0;
 };
 
 struct PgfBuildLinIface {
@@ -666,11 +661,11 @@ struct PgfBuildLinIface {
 typedef struct PgfLinBuilderIface PgfLinBuilderIface;
 
 typedef struct {
-    void (*start_production)(PgfLinBuilderIface *this, PgfExn *err);
+    void (*start_rule)(PgfLinBuilderIface *this, size_t n_vars, size_t n_syms, PgfExn *err);
-    void (*add_argument)(PgfLinBuilderIface *this, size_t n_hypos, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
+    void (*add_argument)(PgfLinBuilderIface *this, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
-    void (*set_result)(PgfLinBuilderIface *this, size_t n_vars, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
+    void (*set_result)(PgfLinBuilderIface *this, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
-    void (*add_variable)(PgfLinBuilderIface *this, size_t var, size_t range, PgfExn *err);
+    void (*set_lin_idx)(PgfLinBuilderIface *this, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
-    void (*start_sequence)(PgfLinBuilderIface *this, size_t n_syms, PgfExn *err);
+    void (*add_variable)(PgfLinBuilderIface *this, size_t range, PgfExn *err);
     void (*add_symcat)(PgfLinBuilderIface *this, size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
     void (*add_symlit)(PgfLinBuilderIface *this, size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
     void (*add_symvar)(PgfLinBuilderIface *this, size_t d, size_t r, PgfExn *err);
@@ -685,9 +680,7 @@ typedef struct {
     void (*add_symsoftspace)(PgfLinBuilderIface *this, PgfExn *err);
     void (*add_symcapit)(PgfLinBuilderIface *this, PgfExn *err);
     void (*add_symallcapit)(PgfLinBuilderIface *this, PgfExn *err);
-    object (*end_sequence)(PgfLinBuilderIface *this, PgfExn *err);
+    void (*end_rule)(PgfLinBuilderIface *this, PgfExn *err);
-    void (*add_sequence_id)(PgfLinBuilderIface *this, object seq_id, PgfExn *err);
-    void (*end_production)(PgfLinBuilderIface *this, PgfExn *err);
 } PgfLinBuilderIfaceVtbl;
 
 struct PgfLinBuilderIface {
@@ -708,6 +701,7 @@ struct PgfBuildLinIface {
 PGF_API_DECL
 void pgf_create_lincat(PgfDB *db,
                        PgfRevision revision, PgfConcrRevision cnc_revision,
+                       void *table_maker,
                        PgfText *name, size_t n_fields, PgfText **fields,
                        size_t n_lindefs, size_t n_linrefs, PgfBuildLinIface *build,
                        PgfExn *err);
@@ -720,10 +714,19 @@ void pgf_drop_lincat(PgfDB *db,
 PGF_API_DECL
 void pgf_create_lin(PgfDB *db,
                     PgfRevision revision, PgfConcrRevision cnc_revision,
-                    PgfText *name, size_t n_prods,
+                    void *table_maker,
+                    PgfText *name, size_t n_rules,
                     PgfBuildLinIface *build,
                     PgfExn *err);
 
+PGF_API_DECL
+void pgf_alter_lin(PgfDB *db,
+                   PgfRevision revision, PgfConcrRevision cnc_revision,
+                   void *table_maker,
+                   PgfText *name, size_t n_rules,
+                   PgfBuildLinIface *build,
+                   PgfExn *err);
+
 PGF_API_DECL
 void pgf_drop_lin(PgfDB *db,
                   PgfRevision revision, PgfConcrRevision cnc_revision,
@@ -916,8 +919,4 @@ pgf_align_words(PgfDB *db, PgfConcrRevision revision,
                 size_t *n_phrases /* out */,
                 PgfExn* err);
 
-PGF_API PgfText *
-pgf_graphviz_lr_automaton(PgfDB *db, PgfConcrRevision revision,
-                          PgfExn *err);
-
 #endif // PGF_H_

src/runtime/c/pgf/phrasetable.cxx

@@ -1,77 +1,8 @@
 #include "data.h"
+#include "printer.h"
 #include <queue>
 
-PgfPhrasetableIds::PgfPhrasetableIds()
+// #define DEBUG_PARSE_INDEX
-{
-	next_id = 0;
-	n_pairs = 0;
-	pairs   = NULL;
-	chains  = NULL;
-}
-
-void PgfPhrasetableIds::start(ref<PgfConcr> concr)
-{
-	next_id = 0;
-	n_pairs = phrasetable_size(concr->phrasetable);
-	size_t mem_size = sizeof(SeqIdPair)*n_pairs;
-	pairs = (SeqIdPair*) malloc(mem_size);
-	if (pairs == NULL)
-		throw pgf_systemerror(ENOMEM);
-	memset(pairs, 0, mem_size);
-}
-
-size_t PgfPhrasetableIds::add(ref<PgfSequence> seq)
-{
-	size_t index = (seq.as_object() >> 4) % n_pairs;
-	if (pairs[index].seq == 0) {
-		pairs[index].seq = seq;
-		pairs[index].seq_id = next_id++;
-		return pairs[index].seq_id;
-	} else {
-		SeqIdChain *chain =
-			(SeqIdChain*) malloc(sizeof(SeqIdChain));
-		if (chain == NULL)
-			throw pgf_systemerror(ENOMEM);
-		chain->next   = chains;
-		chain->chain  = pairs[index].chain;
-		chain->seq    = seq;
-		chain->seq_id = next_id++;
-		pairs[index].chain = chain;
-		chains        = chain;
-		return chain->seq_id;
-	}
-}
-
-size_t PgfPhrasetableIds::get(ref<PgfSequence> seq)
-{
-	size_t index = (seq.as_object() >> 4) % n_pairs;
-	if (pairs[index].seq == seq) {
-		return pairs[index].seq_id;
-	} else {
-		SeqIdChain *chain = pairs[index].chain;
-		while (chain != NULL) {
-			if (chain->seq == seq)
-				return chain->seq_id;
-			chain = chain->chain;
-		}
-		throw pgf_error("Can't find sequence id");
-	}
-}
-
-void PgfPhrasetableIds::end()
-{
-	next_id = 0;
-	n_pairs = 0;
-	
-	while (chains != NULL) {
-		SeqIdChain *next = chains->next;
-		free(chains);
-		chains = next;
-	}
-
-	free(pairs);
-	pairs = NULL;
-}
 
 static
 int lparam_cmp(PgfLParam *p1, PgfLParam *p2)
@@ -100,196 +31,29 @@ int lparam_cmp(PgfLParam *p1, PgfLParam *p2)
 	return 0;
 }
 
-static
-int sequence_cmp(ref<PgfSequence> seq1, ref<PgfSequence> seq2);
-
-static
-void symbol_cmp(PgfSymbol sym1, PgfSymbol sym2, int res[2])
-{
-    uint8_t t1 = ref<PgfSymbol>::get_tag(sym1);
-    uint8_t t2 = ref<PgfSymbol>::get_tag(sym2);
-
-    if (t1 != t2) {
-		res[0] = (res[1] = ((int) t1) - ((int) t2));
-		return;
-	}
-
-	switch (t1) {
-	case PgfSymbolCat::tag: {
-        auto sym_cat1 = ref<PgfSymbolCat>::untagged(sym1);
-        auto sym_cat2 = ref<PgfSymbolCat>::untagged(sym2);
-        if (sym_cat1->d < sym_cat2->d)
-			res[0] = (res[1] = -1);
-        else if (sym_cat1->d > sym_cat2->d)
-			res[0] = (res[1] = 1);
-		else
-			res[0] = (res[1] = lparam_cmp(&sym_cat1->r, &sym_cat2->r));
-		break;
-    }
-	case PgfSymbolLit::tag: {
-        auto sym_lit1 = ref<PgfSymbolLit>::untagged(sym1);
-        auto sym_lit2 = ref<PgfSymbolLit>::untagged(sym2);
-        if (sym_lit1->d < sym_lit2->d)
-			res[0] = (res[1] = -1);
-        else if (sym_lit1->d > sym_lit2->d)
-			res[0] = (res[1] = 1);
-		else
-			res[0] = (res[1] = lparam_cmp(&sym_lit1->r, &sym_lit2->r));
-		break;
-    }
-	case PgfSymbolVar::tag: {
-        auto sym_var1 = ref<PgfSymbolVar>::untagged(sym1);
-        auto sym_var2 = ref<PgfSymbolVar>::untagged(sym2);
-        if (sym_var1->d < sym_var2->d)
-			res[0] = (res[1] = -1);
-        else if (sym_var1->d > sym_var2->d)
-			res[0] = (res[1] = 1);
-		else if (sym_var1->r < sym_var2->r)
-			res[0] = (res[1] = -1);
-        else if (sym_var1->r > sym_var2->r)
-			res[0] = (res[1] = 1);
-		break;
-    }
-	case PgfSymbolKS::tag: {
-        auto sym_ks1 = ref<PgfSymbolKS>::untagged(sym1);
-        auto sym_ks2 = ref<PgfSymbolKS>::untagged(sym2);
-        texticmp(&sym_ks1->token,&sym_ks2->token,res);
-		break;
-    }
-	case PgfSymbolKP::tag: {
-        auto sym_kp1 = ref<PgfSymbolKP>::untagged(sym1);
-        auto sym_kp2 = ref<PgfSymbolKP>::untagged(sym2);
-        res[0] = (res[1] = sequence_cmp(sym_kp1->default_form, sym_kp2->default_form));
-        if (res[0] != 0)
-			return;
-
-		for (size_t i = 0; ; i++) {
-			if (i >= sym_kp1->alts.size()) {
-				res[0] = (res[1] = -(i < sym_kp2->alts.size()));
-				return;
-			}
-			if (i >= sym_kp2->alts.size()) {
-				res[0] = (res[1] = 1);
-				return;
-			}
-
-			res[0] = (res[1] = sequence_cmp(sym_kp1->alts[i].form, sym_kp2->alts[i].form));
-			if (res[0] != 0)
-				return;
-				
-			vector<ref<PgfText>> prefixes1 = sym_kp1->alts[i].prefixes;
-			vector<ref<PgfText>> prefixes2 = sym_kp2->alts[i].prefixes;
-			for (size_t j = 0; ; j++) {
-				if (j >= prefixes1.size()) {
-					res[0] = (res[1] = -(j < prefixes2.size()));
-					return;
-				}
-				if (j >= prefixes2.size()) {
-					res[0] = (res[1] = 1);
-					return;
-				}
-
-				res[0] = (res[1] = textcmp(&*prefixes1[j], &*prefixes2[j]));
-				if (res[0] != 0)
-					return;
-			}
-		}
-    }
-	case PgfSymbolBIND::tag:
-	case PgfSymbolSOFTBIND::tag:
-	case PgfSymbolNE::tag:
-	case PgfSymbolSOFTSPACE::tag:
-	case PgfSymbolCAPIT::tag:
-	case PgfSymbolALLCAPIT::tag:
-        break;
-	default:
-		throw pgf_error("Unknown symbol tag");
-    }
-}
-
-static
-int sequence_cmp(ref<PgfSequence> seq1, ref<PgfSequence> seq2)
-{
-	int res[2] = {0,0};
-	for (size_t i = 0; ; i++) {
-        if (i >= seq1->syms.size()) {
-			if (i < seq2->syms.size())
-				return -1;
-            return res[1];
-		}
-        if (i >= seq2->syms.size())
-            return 1;
-
-		symbol_cmp(seq1->syms[i], seq2->syms[i], res);
-		if (res[0] != 0)
-			return res[0];
-    }
-
-	return 0;
-}
-
 PGF_INTERNAL
-int text_sequence_cmp(PgfTextSpot *spot, const uint8_t *end,
+int text_symbol_cmp(PgfTextSpot *spot, const uint8_t *end,
-                      ref<PgfSequence> seq, size_t *p_i,
+                    ref<PgfSymbolKS> sym_ks, bool case_sensitive)
-                      bool case_sensitive, SeqMatch sm)
 {
-	int res1 = 0;
+    int res1 = 0;
 
-    const uint8_t *s2 = NULL;
+    const uint8_t *s2 = (uint8_t *) &sym_ks->token.text;
-    const uint8_t *e2 = NULL;
+    const uint8_t *e2 = s2+sym_ks->token.size;
-
-    uint8_t t = 0xff;
-    if (*p_i < seq->syms.size()) {
-        t = ref<PgfSymbol>::get_tag(seq->syms[*p_i]);
-    }
-
-    size_t count = 0;
 
     for (;;) {
         if (spot->ptr >= end) {
-            if (s2 < e2 || t == PgfSymbolKS::tag)
+            if (s2 < e2)
                 return -1;
             return case_sensitive ? res1 : 0;
         }
 
-        if (s2 >= e2 && t != PgfSymbolKS::tag) {
+        if (s2 >= e2) {
-            return (sm == SM_FULL_MATCH) ? 1 : 0;
+            return case_sensitive ? res1 : 0;
         }
 
         uint32_t ucs1  = pgf_utf8_decode(&spot->ptr); spot->pos++;
         uint32_t ucs1i = pgf_utf8_to_upper(ucs1);
 
-        if (s2 >= e2) {
-            if (s2 != NULL) {
-                if (pgf_utf8_is_space(ucs1)) {
-                    count++;
-                    continue;
-                }
-
-                if (count == 0) {
-                    return (((int) ucs1) - ' ');
-                } else {
-                    count = 0;
-                }
-            }
-
-            if (t != PgfSymbolKS::tag) {
-                if (sm == SM_PARTIAL)
-                    return 0;
-                return ((int) PgfSymbolKS::tag) - ((int) t);
-            }
-
-            auto sym_ks = ref<PgfSymbolKS>::untagged(seq->syms[*p_i]);
-            s2 = (uint8_t *) &sym_ks->token.text;
-            e2 = s2+sym_ks->token.size;
-
-            (*p_i)++;
-            t = 0xff;
-            if (*p_i < seq->syms.size()) {
-                t = ref<PgfSymbol>::get_tag(seq->syms[*p_i]);
-            }
-        }
-
         uint32_t ucs2  = pgf_utf8_decode(&s2);
         uint32_t ucs2i = pgf_utf8_to_upper(ucs2);
 
@@ -309,183 +73,126 @@ int text_sequence_cmp(PgfTextSpot *spot, const uint8_t *end,
     }
 }
 
+static
+bool text_symbols_match(PgfTextSpot *spot, const uint8_t *end,
+                        vector<PgfSymbol> syms, size_t dot, bool *bind,
+                        bool case_sensitive)
+{
+    while (dot < syms.size()) {
+        PgfSymbol sym = syms[dot];
+        switch (ref<PgfSymbol>::get_tag(sym)) {
+        case PgfSymbolKS::tag: {
+            const uint8_t *start = spot->ptr;
+            for (;;) {
+                const uint8_t *ptr = spot->ptr;
+                uint32_t ucs = pgf_utf8_decode(&ptr);
+                if (!pgf_utf8_is_space(ucs))
+                    break;
+                spot->ptr = ptr;
+                spot->pos++;
+            }
+
+            if (*bind != (start == spot->ptr))
+                return false;
+
+            if (text_symbol_cmp(spot,end,sym,case_sensitive) != 0)
+                return false;
+
+            break;
+        }
+        case PgfSymbolKP::tag: {
+            auto symkp = ref<PgfSymbolKP>::untagged(syms[dot]);
+
+            PgfTextSpot current = *spot;
+            if (text_symbols_match(&current, end, symkp->default_form, 0, bind, case_sensitive)) {
+                goto matched;
+            }
+
+            for (size_t i = 0; i < symkp->alts.size(); i++) {
+                current = *spot;
+                if (text_symbols_match(&current, end, symkp->alts[i].form, 0, bind, case_sensitive)) {
+                    goto matched;
+                }
+            }
+
+            return false;
+
+        matched:
+            *spot = current;
+            break;
+        }
+        case PgfSymbolBIND::tag: {
+            *bind = true;
+            break;
+        }
+        case PgfSymbolSOFTBIND::tag:
+        case PgfSymbolSOFTSPACE::tag: {
+            *bind = true;
+            break;
+        }
+        case PgfSymbolCAPIT::tag:
+        case PgfSymbolALLCAPIT::tag:
+            // skip
+            break;
+        default:
+            return false;
+        }
+
+        dot++;
+    }
+
+    return true;
+}
+
+static
+bool text_item_match(PgfTextSpot *spot, const uint8_t *end,
+                     ref<PgfItem> item,
+                     bool case_sensitive)
+{
+    bool bind = false;
+    size_t dot = item->dot+1;
+    vector<PgfSymbol> syms = item->rule->syms.as_vector();
+    if (item->pre_alt > 0) {
+        auto symkp = ref<PgfSymbolKP>::untagged(syms[item->pre_dot]);
+        if (item->pre_alt == 1) {
+            if (!text_symbols_match(spot, end, symkp->default_form, item->dot, &bind, case_sensitive))
+                return false;
+        } else {
+            if (!text_symbols_match(spot, end, symkp->alts[item->pre_alt-2].form, item->dot, &bind, case_sensitive))
+                return false;
+        }
+        dot = item->pre_dot+1;
+    }
+    return text_symbols_match(spot, end, syms, dot, &bind, case_sensitive);
+}
+
 PGF_INTERNAL_DECL
 size_t get_next_padovan(size_t min);
 
-PGF_INTERNAL_DECL
+template<class K>
-void phrasetable_add_backref(ref<PgfPhrasetableEntry> entry, txn_t txn_id,
-                             object container,
-                             size_t seq_index)
-{
-    vector<PgfSequenceBackref> backrefs = entry->backrefs;
-
-    size_t len = (backrefs != 0) ? backrefs.size() : 0;
-    if (entry->n_backrefs >= len) {
-        size_t new_len = get_next_padovan(entry->n_backrefs+1);
-        backrefs = backrefs.realloc(new_len, txn_id);
-    }
-    backrefs[entry->n_backrefs].container = container;
-    backrefs[entry->n_backrefs].seq_index = seq_index;
-
-    entry->n_backrefs++;
-    entry->backrefs = backrefs;
-}
-
 PGF_INTERNAL
-PgfPhrasetable phrasetable_internalize(PgfPhrasetable table,
+vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable<K> phrasetable,
-                                       ref<PgfSequence> seq,
+                                        ref<K> key,
-                                       ref<PgfConcrLincat> lincat,
+                                        size_t *n_items)
-                                       object container,
-                                       size_t seq_index,
-                                       ref<PgfPhrasetableEntry> *pentry)
 {
-    if (table == 0) {
+    while (phrasetable != 0) {
-        PgfPhrasetableEntry entry;
+        int cmp = compare_key(key, phrasetable->value.key);
-        entry.seq = seq;
+        if (cmp < 0)
-        entry.n_backrefs = 1;
+            phrasetable = phrasetable->left;
-        entry.backrefs = vector<PgfSequenceBackref>::alloc(1);
+        else if (cmp > 0)
-        entry.backrefs[0].container = container;
+            phrasetable = phrasetable->right;
-        entry.backrefs[0].seq_index = seq_index;
+        else {
-        PgfPhrasetable new_table = Node<PgfPhrasetableEntry>::new_node(entry);
+            *n_items = phrasetable->value.n_items;
-        *pentry = ref<PgfPhrasetableEntry>::from_ptr(&new_table->value);
+            return phrasetable->value.items;
-        return new_table;
-	}
-
-    int cmp = sequence_cmp(seq,table->value.seq);
-    if (cmp < 0) {
-        PgfPhrasetable left = phrasetable_internalize(table->left,
-                                                      seq,
-                                                      lincat,
-                                                      container,
-                                                      seq_index,
-                                                      pentry);
-        table = Node<PgfPhrasetableEntry>::upd_node(table,left,table->right);
-        return Node<PgfPhrasetableEntry>::balanceL(table);
-    } else if (cmp > 0) {
-        PgfPhrasetable right = phrasetable_internalize(table->right,
-                                                       seq,
-                                                       lincat,
-                                                       container,
-                                                       seq_index,
-                                                       pentry);
-        table = Node<PgfPhrasetableEntry>::upd_node(table, table->left, right);
-        return Node<PgfPhrasetableEntry>::balanceR(table);
-    } else {
-        PgfSequence::release(seq);
-
-        PgfPhrasetable new_table =
-            Node<PgfPhrasetableEntry>::upd_node(table, table->left, table->right);
-        *pentry = ref<PgfPhrasetableEntry>::from_ptr(&new_table->value);
-        phrasetable_add_backref(*pentry,table->txn_id,container,seq_index);
-        return new_table;
-     }
-}
-
-PGF_INTERNAL
-ref<PgfSequence> phrasetable_relink(PgfPhrasetable table,
-                                    object container,
-                                    size_t seq_index,
-                                    size_t seq_id)
-{
-	while (table != 0) {
-		size_t left_sz = (table->left==0) ? 0 : table->left->sz;
-		if (seq_id < left_sz)
-			table = table->left;
-		else if (seq_id == left_sz) {
-            auto entry = ref<PgfPhrasetableEntry>::from_ptr(&table->value);
-            phrasetable_add_backref(entry,table->txn_id,container,seq_index);
-			return table->value.seq;
-        } else {
-			table = table->right;
-			seq_id -= left_sz+1;
-		}
-	}
-	return 0;
-}
-
-PGF_INTERNAL
-PgfPhrasetable phrasetable_delete(PgfPhrasetable table,
-                                  object container,
-                                  size_t seq_index,
-                                  ref<PgfSequence> seq)
-{
-    if (table == 0)
-        return 0;
-
-    int cmp = sequence_cmp(seq,table->value.seq);
-    if (cmp < 0) {
-        PgfPhrasetable left = phrasetable_delete(table->left,
-                                                 container, seq_index,
-                                                 seq);
-        table = Node<PgfPhrasetableEntry>::upd_node(table,left,table->right);
-        return Node<PgfPhrasetableEntry>::balanceR(table);
-    } else if (cmp > 0) {
-        PgfPhrasetable right = phrasetable_delete(table->right, 
-                                                  container, seq_index,
-                                                  seq);
-        table = Node<PgfPhrasetableEntry>::upd_node(table,table->left,right);
-        return Node<PgfPhrasetableEntry>::balanceL(table);
-    } else {
-        size_t len = table->value.backrefs.size();
-        size_t n_backrefs = table->value.n_backrefs;
-        if (n_backrefs > 1) {
-            vector<PgfSequenceBackref> backrefs =
-                table->value.backrefs.realloc(n_backrefs,table->txn_id);
-            size_t i = 0;
-            while (i < n_backrefs) {
-                ref<PgfSequenceBackref> backref = backrefs.elem(i);
-                if (backref->container == container &&
-                    backref->seq_index == seq_index) {
-                    break;
-                }
-                i++;
-            }
-            i++;
-            while (i < n_backrefs) {
-                backrefs[i-1] = table->value.backrefs[i];
-                i++;
-            }
-            n_backrefs--;
-
-            PgfPhrasetable new_table =
-                Node<PgfPhrasetableEntry>::upd_node(table, table->left, table->right);
-            new_table->value.n_backrefs = n_backrefs;
-            new_table->value.backrefs   = backrefs;
-            return new_table;
-        } else {
-            PgfSequence::release(table->value.seq);
-            vector<PgfSequenceBackref>::release(table->value.backrefs);
-            if (table->left == 0) {
-                Node<PgfPhrasetableEntry>::release(table);
-                return table->right;
-            } else if (table->right == 0) {
-                Node<PgfPhrasetableEntry>::release(table);
-                return table->left;
-            } else if (table->left->sz > table->right->sz) {
-                PgfPhrasetable node;
-                PgfPhrasetable left = Node<PgfPhrasetableEntry>::pop_last(table->left, &node);
-                node = Node<PgfPhrasetableEntry>::upd_node(node, left, table->right);
-                Node<PgfPhrasetableEntry>::release(table);
-                return Node<PgfPhrasetableEntry>::balanceR(node);
-            } else {
-                PgfPhrasetable node;
-                PgfPhrasetable right = Node<PgfPhrasetableEntry>::pop_first(table->right, &node);
-                node = Node<PgfPhrasetableEntry>::upd_node(node, table->left, right);
-                Node<PgfPhrasetableEntry>::release(table);
-                return Node<PgfPhrasetableEntry>::balanceL(node);
-            }
         }
     }
+
+    *n_items = 0;
+    return 0;
 }
 
 PGF_INTERNAL
-size_t phrasetable_size(PgfPhrasetable table)
+void phrasetable_lookup(PgfPhrasetable<PgfSymbolKS> table,
-{
-    return Node<PgfPhrasetableEntry>::size(table);
-}
-
-PGF_INTERNAL
-void phrasetable_lookup(PgfPhrasetable table,
                         PgfText *sentence,
                         bool case_sensitive,
                         PgfPhraseScanner *scanner, PgfExn* err)
@@ -493,27 +200,34 @@ void phrasetable_lookup(PgfPhrasetable table,
     if (table == 0)
         return;
 
-    PgfTextSpot current;
+    PgfTextSpot spot;
-    current.pos = 0;
+    spot.pos = 0;
-    current.ptr = (uint8_t *) sentence->text;
+    spot.ptr = (uint8_t *) sentence->text;
-    const uint8_t *end = current.ptr+sentence->size;
+    const uint8_t *end = spot.ptr+sentence->size;
-    size_t sym_idx = 0;
+    int cmp = text_symbol_cmp(&spot,end,table->value.key,case_sensitive);
-    int cmp = text_sequence_cmp(&current,end,table->value.seq,&sym_idx,case_sensitive,SM_FULL_MATCH);
     if (cmp < 0) {
         phrasetable_lookup(table->left,sentence,case_sensitive,scanner,err);
     } else if (cmp > 0) {
         phrasetable_lookup(table->right,sentence,case_sensitive,scanner,err);
     } else {
-        auto backrefs = table->value.backrefs;
+        if (!case_sensitive) {
-        for (size_t i = 0; i < table->value.n_backrefs; i++) {
+            phrasetable_lookup(table->left,sentence,case_sensitive,scanner,err);
-            PgfSequenceBackref backref = backrefs[i];
+            if (err->type != PGF_EXN_NONE)
-            switch (ref<PgfConcrLin>::get_tag(backref.container)) {
+                return;
+        }
+
+        for (size_t i = 0; i < table->value.n_items; i++) {
+            ref<PgfItem> item = table->value.items[i];
+            switch (ref<PgfConcrLin>::get_tag(item->rule->container)) {
             case PgfConcrLin::tag: {
-                ref<PgfConcrLin> lin = ref<PgfConcrLin>::untagged(backref.container);
+                ref<PgfConcrLin> lin = ref<PgfConcrLin>::untagged(item->rule->container);
                 if (lin->absfun->type->hypos.size() == 0) {
-                    scanner->match(lin, backref.seq_index, err);
+                    PgfTextSpot current = spot;
-                    if (err->type != PGF_EXN_NONE)
+                    if (text_item_match(&current, end, item, case_sensitive) && current.ptr == end) {
-                        return;
+                        scanner->match(lin, item->rule->lin_idx->i0, err);
+                        if (err->type != PGF_EXN_NONE)
+                            return;
+                    }
                 }
                 break;
             }
@@ -525,10 +239,7 @@ void phrasetable_lookup(PgfPhrasetable table,
         }
 
         if (!case_sensitive) {
-            phrasetable_lookup(table->left,sentence,false,scanner,err);
+            phrasetable_lookup(table->right,sentence,case_sensitive,scanner,err);
-            if (err->type != PGF_EXN_NONE)
-                return;
-            phrasetable_lookup(table->right,sentence,false,scanner,err);
             if (err->type != PGF_EXN_NONE)
                 return;
         }
@@ -599,15 +310,14 @@ void finish_skipping(PgfCohortsState *state) {
 
 static
 void phrasetable_lookup_prefixes(PgfCohortsState *state,
-                                 PgfPhrasetable table,
+                                 PgfPhrasetable<PgfSymbolKS> table,
                                  ptrdiff_t min, ptrdiff_t max)
 {
     if (table == 0)
         return;
 
     PgfTextSpot current = state->spot;
-    size_t sym_idx = 0;
+    int cmp = text_symbol_cmp(&current,state->end,table->value.key,state->case_sensitive);
-    int cmp = text_sequence_cmp(&current,state->end,table->value.seq,&sym_idx,state->case_sensitive,SM_PREFIX);
     if (cmp < 0) {
         phrasetable_lookup_prefixes(state,table->left,min,max);
     } else if (cmp > 0) {
@@ -628,8 +338,7 @@ void phrasetable_lookup_prefixes(PgfCohortsState *state,
         if (min <= len)
             phrasetable_lookup_prefixes(state,table->left,min,len);
 
-        auto backrefs = table->value.backrefs;
+        if (len > 0) {
-        if (len > 0 && backrefs != 0) {
             if (state->last.pos != current.pos) {
                 if (state->last.pos > 0) {
                     state->scanner->end_matches(&state->last,
@@ -647,14 +356,14 @@ void phrasetable_lookup_prefixes(PgfCohortsState *state,
             }
             state->queue.push(current);
 
-            for (size_t i = 0; i < table->value.n_backrefs; i++) {
+            for (size_t i = 0; i < table->value.n_items; i++) {
-                PgfSequenceBackref backref = backrefs[i];
+                auto rule = table->value.items[i]->rule;
-                switch (ref<PgfConcrLin>::get_tag(backref.container)) {
+                switch (ref<PgfConcrLin>::get_tag(rule->container)) {
                 case PgfConcrLin::tag: {
-                    ref<PgfConcrLin> lin = ref<PgfConcrLin>::untagged(backref.container);
+                    ref<PgfConcrLin> lin = ref<PgfConcrLin>::untagged(rule->container);
                     if (lin->absfun->type->hypos.size() == 0) {
                         state->scanner->match(lin,
-                                              backref.seq_index,
+                                              rule->lin_idx->i0,
                                               state->err);
                         if (state->err->type != PGF_EXN_NONE)
                             return;
@@ -675,7 +384,7 @@ void phrasetable_lookup_prefixes(PgfCohortsState *state,
 }
 
 PGF_INTERNAL
-void phrasetable_lookup_cohorts(PgfPhrasetable table,
+void phrasetable_lookup_cohorts(PgfPhrasetable<PgfSymbolKS> table,
                                 PgfText *sentence,
                                 bool case_sensitive,
                                 PgfPhraseScanner *scanner, PgfExn* err)
@@ -762,62 +471,223 @@ void phrasetable_lookup_cohorts(PgfPhrasetable table,
     }
 }
 
+template<class K>
 PGF_INTERNAL
-void phrasetable_iter(PgfConcr *concr,
+PgfPhrasetable<K> phrasetable_insert(PgfPhrasetable<K> table,
-                      PgfPhrasetable table,
+                                     ref<K> key, ref<PgfItem> item)
-                      PgfSequenceItor* itor,
-                      PgfMorphoCallback *callback,
-                      PgfPhrasetableIds *seq_ids, PgfExn *err)
 {
-    if (table == 0)
+    if (table == 0) {
-        return;
+        auto items = vector<ref<PgfItem>>::alloc(1);
+        items[0] = item;
+        return Node<PgfPhrasetableValue<K>>::new_node({.key=key,.n_items=1,.items=items});
+	}
 
-    phrasetable_iter(concr, table->left, itor, callback, seq_ids, err);
+    int cmp = compare_key(key, table->value.key);
-    if (err->type != PGF_EXN_NONE)
+    if (cmp < 0) {
-        return;
+        PgfPhrasetable<K> left = phrasetable_insert(table->left, key, item);
+        table = Node<PgfPhrasetableValue<K>>::upd_node(table,left,table->right);
+        return Node<PgfPhrasetableValue<K>>::balanceL(table);
+    } else if (cmp > 0) {
+        PgfPhrasetable<K> right = phrasetable_insert(table->right, key, item);
+        table = Node<PgfPhrasetableValue<K>>::upd_node(table, table->left, right);
+        return Node<PgfPhrasetableValue<K>>::balanceR(table);
+    } else {
+        PgfPhrasetable<K> new_table =
+            Node<PgfPhrasetableValue<K>>::upd_node(table, table->left, table->right);
 
-	size_t seq_id = seq_ids->add(table->value.seq);
+        auto items = new_table->value.items;
-    int res = itor->fn(itor, seq_id, table->value.seq.as_object(), err);
+        if (new_table->value.n_items >= items.size()) {
-    if (err->type != PGF_EXN_NONE)
+            size_t new_len = get_next_padovan(new_table->value.n_items+1);
-        return;
+            items = items.realloc(new_len, new_table->txn_id);
-
-    if (table->value.backrefs != 0 && res == 0 && callback != 0) {
-        for (size_t i = 0; i < table->value.n_backrefs; i++) {
-            PgfSequenceBackref backref = table->value.backrefs[i];
-            switch (ref<PgfConcrLin>::get_tag(backref.container)) {
-            case PgfConcrLin::tag: {
-                ref<PgfConcrLin> lin = ref<PgfConcrLin>::untagged(backref.container);
-                ref<PgfConcrLincat> lincat =
-                    namespace_lookup(concr->lincats, &lin->absfun->type->name);
-                if (lincat != 0) {
-                    ref<PgfText> field =
-                        lincat->fields[backref.seq_index % lincat->fields.size()];
-
-                    callback->fn(callback, &lin->absfun->name, &*field, lincat->abscat->prob+lin->absfun->prob, err);
-                    if (err->type != PGF_EXN_NONE)
-                        return;
-                }
-                break;
-            }
-            case PgfConcrLincat::tag: {
-                //ignore
-                break;
-            }
-            }
         }
+        items[new_table->value.n_items] = item;
+        new_table->value.n_items++;
+        new_table->value.items = items;
+        return new_table;
+    }
+}
+
+static
+int compare_key(ref<PgfSymbolKS> symks1, ref<PgfSymbolKS> symks2) {
+    int res[2] = {0,0};
+    texticmp(&symks1->token, &symks2->token, res);
+    if (res[0] != 0)
+        return res[0];
+    return res[1];
+}
+
+template
+PgfPhrasetable<PgfSymbolKS> phrasetable_insert<PgfSymbolKS>(PgfPhrasetable<PgfSymbolKS> table,
+                                                            ref<PgfSymbolKS> key,
+                                                            ref<PgfItem> item);
+
+static
+int compare_key(ref<PgfConcrLincat> lincat1, ref<PgfConcrLincat> lincat2) {
+    return textcmp(&lincat1->name, &lincat2->name);
+}
+
+template
+PGF_INTERNAL
+PgfPhrasetable<PgfConcrLincat> phrasetable_insert<PgfConcrLincat>(PgfPhrasetable<PgfConcrLincat> table,
+                                                                  ref<PgfConcrLincat> key,
+                                                                  ref<PgfItem> item);
+
+template
+PGF_INTERNAL
+vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable<PgfConcrLincat> phrasetable,
+                                        ref<PgfConcrLincat> key,
+                                        size_t *n_items);
+
+static
+int compare_key(ref<PgfCCat> ccat1, ref<PgfCCat> ccat2) {
+    return ((int) ccat1->fid) - ((int) ccat2->fid);
+}
+
+template
+PgfPhrasetable<PgfCCat> phrasetable_insert<PgfCCat>(PgfPhrasetable<PgfCCat> table,
+                                                    ref<PgfCCat> key,
+                                                    ref<PgfItem> item);
+
+template
+PGF_INTERNAL
+vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable<PgfCCat> phrasetable,
+                                        ref<PgfCCat> key,
+                                        size_t *n_items);
+
+static
+int compare_key(ref<PgfSymbolBIND> symbind1, ref<PgfSymbolBIND> symbind2) {
+    return 0;
+}
+
+template
+PgfPhrasetable<PgfSymbolBIND> phrasetable_insert<PgfSymbolBIND>(PgfPhrasetable<PgfSymbolBIND> table,
+                                                                ref<PgfSymbolBIND> key,
+                                                                ref<PgfItem> item);
+
+template
+PGF_INTERNAL
+vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable<PgfSymbolBIND> phrasetable,
+                                        ref<PgfSymbolBIND> key,
+                                        size_t *n_items);
+
+PGF_INTERNAL
+PgfEpsilontable epsilontable_insert(PgfEpsilontable table,
+                                    ref<PgfConcrLincat> lincat,
+                                    interval_t value, interval_t lin_idx,
+                                    PgfMetaId fid, prob_t viterbi_prob,
+                                    ref<PgfItem> item,
+                                    ref<PgfCCat> *pepsilon)
+{
+    if (table == 0) {
+        auto items = vector<ref<PgfItem>>::alloc(1);
+        items[0] = item;
+        PgfEpsilontable new_table =
+            Node<PgfCCat>::new_node({.lincat=lincat,
+                                     .fid=fid,
+                                     .value=value,
+                                     .lin_idx=lin_idx,
+                                     .viterbi_prob=viterbi_prob,
+                                     .n_items=1,
+                                     .items=items});
+        *pepsilon = ref<PgfCCat>::from_ptr(&new_table->value);
+        return new_table;
+	}
+
+    int cmp = textcmp(&lincat->name, &table->value.lincat->name);
+    if (cmp == 0) {
+        cmp = ((int)fid) - ((int)table->value.fid);
     }
 
-    phrasetable_iter(concr, table->right, itor, callback, seq_ids, err);
+    if (cmp < 0) {
-    if (err->type != PGF_EXN_NONE)
+        PgfEpsilontable left = epsilontable_insert(table->left,
-        return;
+                                                   lincat, value, lin_idx, fid, viterbi_prob, item, pepsilon);
+        table = Node<PgfCCat>::upd_node(table,left,table->right);
+        return Node<PgfCCat>::balanceL(table);
+    } else if (cmp > 0) {
+        PgfEpsilontable right = epsilontable_insert(table->right,
+                                                    lincat, value, lin_idx, fid, viterbi_prob, item, pepsilon);
+        table = Node<PgfCCat>::upd_node(table, table->left, right);
+        return Node<PgfCCat>::balanceR(table);
+    } else {
+        PgfEpsilontable new_table =
+            Node<PgfCCat>::upd_node(table, table->left, table->right);
+
+        auto items = table->value.items;
+        if (table->value.n_items >= items.size()) {
+            size_t new_len = get_next_padovan(table->value.n_items+1);
+            items = items.realloc(new_len, table->txn_id);
+        }
+        items[table->value.n_items] = item;
+        new_table->value.n_items++;
+        new_table->value.items = items;
+        *pepsilon = ref<PgfCCat>::from_ptr(&new_table->value);
+        return new_table;
+    }
 }
 
 PGF_INTERNAL
-void phrasetable_release(PgfPhrasetable table)
+void epsilontable_add(ref<PgfCCat> epsilon,ref<PgfItem> item)
+{
+    auto items = epsilon->items;
+    if (epsilon->n_items >= items.size()) {
+        size_t new_len = get_next_padovan(epsilon->n_items+1);
+        items = items.realloc(new_len, PgfDB::get_txn_id());
+    }
+    items[epsilon->n_items] = item;
+    epsilon->n_items++;
+    epsilon->items = items;
+}
+
+PGF_INTERNAL
+ref<PgfCCat> epsilontable_get(PgfEpsilontable table,
+                              PgfText *name, PgfMetaId fid)
+{
+    if (table == 0) {
+        return 0;
+	}
+
+    int cmp = textcmp(name, &table->value.lincat->name);
+    if (cmp == 0) {
+        cmp = ((int)fid) - ((int)table->value.fid);
+    }
+
+    if (cmp < 0) {
+        return epsilontable_get(table->left,name,fid);
+    } else if (cmp > 0) {
+        return epsilontable_get(table->right,name,fid);
+    } else {
+        return ref<PgfCCat>::from_ptr(&table->value);
+    }
+}
+
+PGF_INTERNAL
+void epsilontable_iter(PgfEpsilontable table, ref<PgfConcrLincat> lincat, std::function<void(ref<PgfCCat> arg)> &f)
 {
     if (table == 0)
         return;
-    phrasetable_release(table->left);
+
-    phrasetable_release(table->right);
+    int cmp = textcmp(&lincat->name, &table->value.lincat->name);
-    Node<PgfPhrasetableEntry>::release(table);
+    if (cmp < 0)
+        epsilontable_iter(table->left,  lincat, f);
+    else if (cmp > 0)
+        epsilontable_iter(table->right, lincat, f);
+    else {
+        epsilontable_iter(table->left,  lincat, f);
+        f(ref<PgfCCat>::from_ptr(&table->value));
+        epsilontable_iter(table->right, lincat, f);
+    }
+}
+
+PGF_INTERNAL
+void epsilontable_release(PgfEpsilontable table)
+{
+    if (table == 0)
+        return;
+    epsilontable_release(table->left);
+    epsilontable_release(table->right);
+    for (size_t i = 0; i < table->value.n_items; i++) {
+        PgfItem::release(table->value.items[i]);
+    }
+    vector<ref<PgfItem>>::release(table->value.items);
+    Node<PgfCCat>::release(table);
 }

src/runtime/c/pgf/phrasetable.h

@@ -1,138 +1,151 @@
 #ifndef PHRASETABLE_H
 #define PHRASETABLE_H
 
-struct PgfSequence;
-struct PgfSequenceBackref;
-
-struct PGF_INTERNAL_DECL PgfPhrasetableEntry {
-    ref<PgfSequence> seq;
-
-    // Here n_backrefs tells us how many actual backrefs there are in
-    // the vector backrefs. On the other hand, backrefs->len tells us
-    // how big buffer we have allocated.
-    size_t n_backrefs;
-    vector<PgfSequenceBackref> backrefs;
-};
-
-struct PgfSequenceItor;
-typedef ref<Node<PgfPhrasetableEntry>> PgfPhrasetable;
-
-
-#if __GNUC__
-#pragma GCC diagnostic push
-#pragma GCC diagnostic ignored "-Wattributes"
-#endif
-
-struct PgfPhrasetableIds {
-public:
-	PGF_INTERNAL_DECL PgfPhrasetableIds();
-	PGF_INTERNAL_DECL ~PgfPhrasetableIds() { end(); }
-
-	PGF_INTERNAL_DECL void start(ref<PgfConcr> concr);
-	PGF_INTERNAL_DECL size_t add(ref<PgfSequence> seq);
-	PGF_INTERNAL_DECL size_t get(ref<PgfSequence> seq);
-	PGF_INTERNAL_DECL void end();
-
-private:
-	size_t next_id;
-
-	struct PGF_INTERNAL_DECL SeqIdChain;
-
-	struct PGF_INTERNAL_DECL SeqIdPair {
-		SeqIdChain *chain;
-		ref<PgfSequence> seq;
-		size_t seq_id;
-	};
-
-	struct PGF_INTERNAL_DECL SeqIdChain : public SeqIdPair {
-		SeqIdChain *next;
-	};
-
-	size_t n_pairs;
-	SeqIdPair  *pairs;
-	SeqIdChain *chains;
-};
-
-#if __GNUC__
-#pragma GCC diagnostic pop
-#endif
-
-struct PgfConcrLincat;
-
-PGF_INTERNAL_DECL
-PgfPhrasetable phrasetable_internalize(PgfPhrasetable table,
-                                       ref<PgfSequence> seq,
-                                       ref<PgfConcrLincat> lincat,
-                                       object container,
-                                       size_t seq_index,
-                                       ref<PgfPhrasetableEntry> *pentry);
-
-PGF_INTERNAL_DECL
-ref<PgfSequence> phrasetable_relink(PgfPhrasetable table,
-                                    object container,
-                                    size_t seq_index,
-                                    size_t seq_id);
-
-PGF_INTERNAL_DECL
-PgfPhrasetable phrasetable_delete(PgfPhrasetable table,
-                                  object container,
-                                  size_t seq_index,
-                                  ref<PgfSequence> seq);
-
-PGF_INTERNAL_DECL
-size_t phrasetable_size(PgfPhrasetable table);
-
 struct PgfConcrLin;
+struct PgfConcrLincat;
 
 struct PGF_INTERNAL_DECL PgfTextSpot {
 	size_t pos;          // position in Unicode characters
 	const uint8_t *ptr;  // pointer into the spot location
 };
 
+struct PGF_INTERNAL_DECL PgfItem {
+    PgfMetaId res;
+
+    struct {
+        size_t &operator[](int i) {
+            PgfItem *item = containerof(PgfItem,vars,this);
+            return ((size_t*) (((PgfMetaId*) (item+1))+item->rule->args.size()))[i];
+        }
+        size_t size() {
+            PgfItem *item = containerof(PgfItem,vars,this);
+            return (item->rule->ranges != 0) ? item->rule->ranges.size() : 0;
+        }
+    } vars;
+
+    struct {
+        PgfMetaId &operator[](int i) {
+            PgfItem *item = containerof(PgfItem,args,this);
+            return ((PgfMetaId*) (item+1))[i];
+        }
+        size_t size() {
+            PgfItem *item = containerof(PgfItem,args,this);
+            return item->rule->args.size();
+        }
+    } args;
+
+    static
+    void release(ref<PgfItem> item) {
+        size_t ex_size =
+            sizeof(PgfMetaId) * item->args.size() +
+            sizeof(size_t)    * item->vars.size();
+        PgfDB::free(item, ex_size);
+    }
+
+    uint16_t pre_alt;
+    uint16_t pre_dot;
+    uint16_t dot;
+    ref<PgfConcrRule> rule;
+};
+
+struct PGF_INTERNAL_DECL PgfCCat {
+    ref<PgfConcrLincat> lincat;
+    PgfMetaId fid;
+    interval_t value, lin_idx;
+    prob_t viterbi_prob;
+
+    // Here n_items tells us how many actual items there are in
+    // the vector items. On the other hand, items.size() tells us
+    // how big buffer we have allocated.
+    size_t n_items;
+    vector<ref<PgfItem>> items;
+};
+
+template<class K>
+struct PGF_INTERNAL_DECL PgfPhrasetableValue {
+    ref<K> key;
+
+    // Here n_items tells us how many actual items there are in
+    // the vector items. On the other hand, items.size() tells us
+    // how big buffer we have allocated.
+    size_t n_items;
+    vector<ref<PgfItem>> items;
+};
+
+template <class K>
+using PgfPhrasetable = ref<Node<PgfPhrasetableValue<K>>>;
+
+template<class K>
+PGF_INTERNAL_DECL
+PgfPhrasetable<K> phrasetable_insert(PgfPhrasetable<K> table,
+                                     ref<K> key, ref<PgfItem> item);
+
+template<class K>
+PGF_INTERNAL_DECL
+vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable<K> phrasetable,
+                                        ref<K> key,
+                                        size_t *n_items);
+
 class PGF_INTERNAL_DECL PgfPhraseScanner {
 public:
     virtual void space(PgfTextSpot *start, PgfTextSpot *end, PgfExn* err)=0;
     virtual void start_matches(PgfTextSpot *spot, PgfExn* err)=0;
-    virtual void match(ref<PgfConcrLin> lin, size_t seq_index, PgfExn* err)=0;
+    virtual void match(ref<PgfConcrLin> lin, size_t lin_idx, PgfExn* err)=0;
     virtual void end_matches(PgfTextSpot *spot, PgfExn* err)=0;
 };
 
 PGF_INTERNAL_DECL
-void phrasetable_lookup(PgfPhrasetable table,
+void phrasetable_lookup(PgfPhrasetable<PgfSymbolKS> phrasetable,
                         PgfText *sentence,
                         bool case_sensitive,
                         PgfPhraseScanner *scanner, PgfExn* err);
 
 PGF_INTERNAL_DECL
-void phrasetable_lookup_cohorts(PgfPhrasetable table,
+void phrasetable_lookup_cohorts(PgfPhrasetable<PgfSymbolKS> phrasetable,
                                 PgfText *sentence,
                                 bool case_sensitive,
                                 PgfPhraseScanner *scanner, PgfExn* err);
 
+template <class V>
+void phrasetable_release(PgfPhrasetable<V> table)
+{
+    if (table == 0)
+        return;
+    phrasetable_release(table->left);
+    phrasetable_release(table->right);
+    for (size_t i = 0; i < table->value.n_items; i++) {
+        PgfItem::release(table->value.items[i]);
+    }
+    vector<ref<PgfItem>>::release(table->value.items);
+    Node<PgfPhrasetableValue<V>>::release(table);
+}
+
+
+typedef ref<Node<PgfCCat>> PgfEpsilontable;
+
+// Creates a new epsilon category with its first item.
+// The new category is mutable within the current transaction
 PGF_INTERNAL_DECL
-void phrasetable_iter(PgfConcr *concr,
+PgfEpsilontable epsilontable_insert(PgfEpsilontable table,
-                      PgfPhrasetable table,
+                                    ref<PgfConcrLincat> lincat,
-                      PgfSequenceItor* itor,
+                                    interval_t value, interval_t lin_idx,
-                      PgfMorphoCallback *callback,
+                                    PgfMetaId fid, prob_t viterbi_prob,
-                      PgfPhrasetableIds *seq_ids, PgfExn *err);
+                                    ref<PgfItem> item,
+                                    ref<PgfCCat> *pepsilon);
+
+// Adds a new item to an existing epsilon category. The category
+// must have been created by epsilontable_insert in the current transaction.
+PGF_INTERNAL_DECL
+void epsilontable_add(ref<PgfCCat> epsilon, ref<PgfItem> item);
 
 PGF_INTERNAL_DECL
-void phrasetable_release(PgfPhrasetable table);
+ref<PgfCCat> epsilontable_get(PgfEpsilontable table,
+                              PgfText *name, PgfMetaId fid);
 
-// The following are used internally in the parser
+PGF_INTERNAL
-
+void epsilontable_iter(PgfEpsilontable table, ref<PgfConcrLincat> lincat, std::function<void(ref<PgfCCat> arg)> &f);
-enum SeqMatch { SM_FULL_MATCH, SM_PREFIX, SM_PARTIAL };
 
 PGF_INTERNAL_DECL
-int text_sequence_cmp(PgfTextSpot *spot, const uint8_t *end,
+void epsilontable_release(PgfEpsilontable table);
-                      ref<PgfSequence> seq, size_t *p_i,
-                      bool case_sensitive, SeqMatch sm);
-
-// The following is used internally in the grammar builder
-
-PGF_INTERNAL_DECL
-void phrasetable_add_backref(ref<PgfPhrasetableEntry> entry, txn_t txn_id,
-                             object container,
-                             size_t seq_index);
 
 #endif

src/runtime/c/pgf/printer.cxx

@@ -499,15 +499,15 @@ void PgfPrinter::lparam(ref<PgfLParam> lparam)
     }
 }
 
-void PgfPrinter::lvar_ranges(vector<PgfVariableRange> vars, size_t *values)
+void PgfPrinter::lvar_ranges(vector<size_t> ranges, size_t *values)
 {
     puts("{");
-    for (size_t i = 0; i < vars.size(); i++) {
+    for (size_t i = 0; i < ranges.size(); i++) {
         if (i > 0)
             puts(", ");
-        lvar(vars[i].var);
+        lvar(i);
         if (values == NULL || values[i] == 0)
-            nprintf(32,"<%ld",vars[i].range);
+            nprintf(32,"<%ld",ranges[i]);
         else
             nprintf(32,"=%ld",values[i]-1);
     }
@@ -545,11 +545,11 @@ void PgfPrinter::symbol(PgfSymbol sym)
         auto sym_kp = ref<PgfSymbolKP>::untagged(sym);
         puts("pre {");
 
-        sequence(sym_kp->default_form);
+        symbols(sym_kp->default_form);
 
         for (size_t i = 0; i < sym_kp->alts.size(); i++) {
             puts("; ");
-            sequence(sym_kp->alts[i].form);
+            symbols(sym_kp->alts[i].form);
             puts(" /");
             for (size_t j = 0; j < sym_kp->alts[i].prefixes.size(); j++) {
                 puts(" ");
@@ -581,19 +581,86 @@ void PgfPrinter::symbol(PgfSymbol sym)
 	}
 }
 
-void PgfPrinter::sequence(ref<PgfSequence> seq)
+void PgfPrinter::symbols(vector<PgfSymbol> syms)
 {
-    for (size_t i = 0; i < seq->syms.size(); i++) {
+    for (size_t i = 0; i < syms.size(); i++) {
         if (i > 0)
             puts(" ");
 
-        symbol(seq->syms[i]);
+        symbol(syms[i]);
     }
 }
 
-void PgfPrinter::seq_id(PgfPhrasetableIds *seq_ids, ref<PgfSequence> seq)
+void PgfPrinter::item(ref<PgfItem> item)
 {
-	nprintf(5, "S%zu", seq_ids->get(seq));
+    switch (ref<PgfConcrLin>::get_tag(item->rule->container)) {
+    case PgfConcrLincat::tag: {
+        ref<PgfConcrLincat> lincat = ref<PgfConcrLincat>::untagged(item->rule->container);
+
+        if (item->rule->ranges != 0) {
+            lvar_ranges(item->rule->ranges, &item->vars[0]);
+            puts(" ");
+        }
+
+        puts("String(");
+        lparam(item->rule->res);
+        puts(") -> ");
+
+        efun(&lincat->name);
+        puts("[");
+        efun(&lincat->name);
+        puts("(");
+        lparam(item->rule->args[0]);
+        puts(")]; ");
+        break;
+    }
+    case PgfConcrLin::tag: {
+        ref<PgfConcrLin> lin = ref<PgfConcrLin>::untagged(item->rule->container);
+        ref<PgfDTyp> ty = lin->absfun->type;
+
+        if (item->rule->ranges != 0) {
+            lvar_ranges(item->rule->ranges, &item->vars[0]);
+            puts(" ");
+        }
+
+        efun(&ty->name);
+        puts("(");
+        lparam(item->rule->res);
+        puts(") -> ");
+
+        efun(&lin->name);
+        puts("[");
+        for (size_t i = 0; i < item->rule->args.size(); i++) {
+            if (i > 0)
+                puts(",");
+            if (item->args[i] == 0) {
+                efun(&ty->hypos.elem(i)->type->name);
+                puts("(");
+                lparam(item->rule->args[i]);
+                puts(")");
+            } else {
+                emeta(0);
+            }
+        }
+        puts("]; ");
+        break;
+    }
+    }
+
+    lparam(item->rule->lin_idx);
+    puts(" : ");
+
+    for (size_t i = 0; i < item->rule->syms.size(); i++) {
+        if (i > 0)
+            puts(" ");
+
+        if (item->pre_alt == 0 && item->dot == i)
+            puts(". ");
+        else if (item->pre_alt > 0 && item->pre_dot == i)
+            puts(". ");
+
+        symbol(item->rule->syms[i]);
+    }
 }
 
 void PgfPrinter::free_ref(object x)

src/runtime/c/pgf/printer.h

@@ -78,10 +78,10 @@ public:
     void parg(ref<PgfDTyp> ty, ref<PgfPArg> parg);
     void lvar(size_t var);
     void lparam(ref<PgfLParam> lparam);
-    void lvar_ranges(vector<PgfVariableRange> vars, size_t *values);
+    void lvar_ranges(vector<size_t> ranges, size_t *values);
-    void seq_id(PgfPhrasetableIds *seq_ids, ref<PgfSequence> seq);
     void symbol(PgfSymbol sym);
-    void sequence(ref<PgfSequence> seq);
+    void symbols(vector<PgfSymbol> syms);
+    void item(ref<PgfItem> item);
 
     virtual PgfExpr eabs(PgfBindType btype, PgfText *name, PgfExpr body);
     virtual PgfExpr eapp(PgfExpr fun, PgfExpr arg);

src/runtime/c/pgf/reader.cxx

@@ -10,6 +10,7 @@ PgfReader::PgfReader(FILE *in,PgfProbsCallback *probs_callback)
     this->probs_callback = probs_callback;
     this->abstract = 0;
     this->concrete = 0;
+    this->container = 0;
 }
 
 uint8_t PgfReader::read_uint8()
@@ -161,6 +162,21 @@ ref<C> PgfReader::read_vector(inline_vector<V> C::* field, void (PgfReader::*rea
     return loc;
 }
 
+template <class V>
+vector<V> PgfReader::read_null_vector(void (PgfReader::*read_value)(ref<V> val))
+{
+    size_t len = read_len();
+    if (len == 0) {
+        return 0;
+    } else {
+        vector<V> vec = vector<V>::alloc(len);
+        for (size_t i = 0; i < len; i++) {
+            (this->*read_value)(vec.elem(i));
+        }
+        return vec;
+    }
+}
+
 template <class V>
 vector<V> PgfReader::read_vector(void (PgfReader::*read_value)(ref<V> val))
 {
@@ -481,10 +497,9 @@ ref<PgfLParam> PgfReader::read_lparam()
     return lparam;
 }
 
-void PgfReader::read_variable_range(ref<PgfVariableRange> var_info)
+void PgfReader::read_variable_range(ref<size_t> var_range)
 {
-    var_info->var   = read_int();
+    *var_range = read_int();
-    var_info->range = read_int();
 }
 
 void PgfReader::read_parg(ref<PgfPArg> parg)
@@ -492,33 +507,6 @@ void PgfReader::read_parg(ref<PgfPArg> parg)
     auto param = read_lparam(); parg->param = param;
 }
 
-ref<PgfPResult> PgfReader::read_presult()
-{
-    vector<PgfVariableRange> vars = 0;
-    size_t n_vars = read_len();
-    if (n_vars > 0) {
-        vars = vector<PgfVariableRange>::alloc(n_vars);
-        for (size_t i = 0; i < n_vars; i++) {
-            read_variable_range(vars.elem(i));
-        }
-    }
-
-    size_t i0 = read_int();
-    size_t n_terms = read_len();
-    ref<PgfPResult> res =
-        PgfDB::malloc<PgfPResult>(n_terms*sizeof(PgfLParam::terms[0]));
-    res->vars = vars;
-    res->param.i0 = i0;
-    res->param.n_terms = n_terms;
-
-    for (size_t i = 0; i < n_terms; i++) {
-        res->param.terms[i].factor = read_int();
-        res->param.terms[i].var    = read_int();
-    }
-
-    return res;
-}
-
 template<class I>
 ref<I> PgfReader::read_symbol_idx()
 {
@@ -572,14 +560,14 @@ PgfSymbol PgfReader::read_symbol()
         ref<PgfSymbolKP> sym_kp = inline_vector<PgfAlternative>::alloc(&PgfSymbolKP::alts,n_alts);
 
         for (size_t i = 0; i < n_alts; i++) {
-            auto form     = read_seq();
+            auto form     = read_vector(&PgfReader::read_symbol2);
             auto prefixes = read_vector(&PgfReader::read_text2);
 
             sym_kp->alts[i].form     = form;
             sym_kp->alts[i].prefixes = prefixes;
         }
 
-        auto default_form = read_seq();
+        auto default_form = read_vector(&PgfReader::read_symbol2);
         sym_kp->default_form = default_form;
 
         sym = sym_kp.tagged();
@@ -616,80 +604,50 @@ PgfSymbol PgfReader::read_symbol()
     return sym;
 }
 
-ref<PgfSequence> PgfReader::read_seq()
+ref<PgfConcrRule> PgfReader::read_rule()
 {
-	size_t n_syms = read_len();
+    size_t n_syms = read_len();
+    ref<PgfConcrRule> rule = inline_vector<PgfSymbol>::alloc(&PgfConcrRule::syms, n_syms);
 
-	ref<PgfSequence> seq = inline_vector<PgfSymbol>::alloc(&PgfSequence::syms, n_syms);
+    vector<size_t> ranges = read_null_vector(&PgfReader::read_variable_range);
+    ref<PgfLParam> res = read_lparam();
+    vector<ref<PgfLParam>> args = read_null_vector(&PgfReader::read_lparam);
+    ref<PgfLParam> lin_idx = read_lparam();
+
+    rule->ranges = ranges;
+    rule->res  = res;
+    rule->container = container;
+    rule->args = args;
+    rule->lin_idx = lin_idx;
 
     for (size_t i = 0; i < n_syms; i++) {
         PgfSymbol sym = read_symbol();
-        seq->syms[i] = sym;
+        rule->syms[i] = sym;
     }
 
-    return seq;
+    return rule;
-}
-
-vector<ref<PgfSequence>> PgfReader::read_seq_ids(object container)
-{
-    size_t len = read_len();
-    vector<ref<PgfSequence>> vec = vector<ref<PgfSequence>>::alloc(len);
-    for (size_t i = 0; i < len; i++) {
-        size_t seq_id = read_len();
-        ref<PgfSequence> seq = phrasetable_relink(concrete->phrasetable,
-                                                  container, i,
-                                                  seq_id);
-        if (seq == 0) {
-            throw pgf_error("Invalid sequence id");
-        }
-        vec[i] = seq;
-    }
-    return vec;
-}
-
-PgfPhrasetable PgfReader::read_phrasetable(size_t len)
-{
-    if (len == 0)
-        return 0;
-
-    PgfPhrasetableEntry value;
-
-    size_t half = len/2;
-    PgfPhrasetable left  = read_phrasetable(half);
-    value.seq = read_seq();
-    value.n_backrefs = 0;
-    value.backrefs = 0;
-    PgfPhrasetable right = read_phrasetable(len-half-1);
-
-    PgfPhrasetable table = Node<PgfPhrasetableEntry>::new_node(value);
-    table->sz    = 1+Node<PgfPhrasetableEntry>::size(left)+Node<PgfPhrasetableEntry>::size(right);
-    table->left  = left;
-    table->right = right;
-    return table;
-}
-
-PgfPhrasetable PgfReader::read_phrasetable()
-{
-    size_t len = read_len();
-    return read_phrasetable(len);
 }
 
 ref<PgfConcrLincat> PgfReader::read_lincat()
 {
     ref<PgfConcrLincat> lincat = read_name(&PgfConcrLincat::name);
 
+    container = lincat.tagged();
+
     auto fields = read_lincat_fields(lincat);
     auto n_lindefs = read_len();
-    auto args = read_vector(&PgfReader::read_parg);
+    auto rules = read_vector(&PgfReader::read_rule2);
-    auto res  = read_vector(&PgfReader::read_presult2);
+
-    auto seqs = read_seq_ids(lincat.tagged());
+    container = 0;
+
+    for (size_t i = n_lindefs; i < rules.size(); i++) {
+        table_maker->insert_rule(rules[i]);
+    }
 
     lincat->abscat = namespace_lookup(abstract->cats, &lincat->name);
     lincat->fields = fields;
     lincat->n_lindefs = n_lindefs;
-    lincat->args = args;
+    lincat->rules = rules;
-    lincat->res  = res;
-    lincat->seqs = seqs;
     return lincat;
 }
 
@@ -715,13 +673,16 @@ ref<PgfConcrLin> PgfReader::read_lin()
     if (lin->lincat == 0)
         throw pgf_error("Found a lin which uses a category without a lincat");
 
-    auto args = read_vector(&PgfReader::read_parg);
+    container  = lin.tagged();
-    auto res  = read_vector(&PgfReader::read_presult2);
-    auto seqs = read_seq_ids(lin.tagged());
 
-    lin->args = args;
+    auto rules = read_vector(&PgfReader::read_rule2);
-    lin->res  = res;
+    lin->rules = rules;
-    lin->seqs = seqs;
+
+    container  = 0;
+
+    for (size_t i = 0; i < rules.size(); i++) {
+        table_maker->insert_rule(rules[i]);
+    }
 
     return lin;
 }
@@ -736,12 +697,18 @@ ref<PgfConcrPrintname> PgfReader::read_printname()
 ref<PgfConcr> PgfReader::read_concrete()
 {
     concrete = read_name(&PgfConcr::name);
+    concrete->phrasetable1 = 0;
+    concrete->phrasetable2 = 0;
+    concrete->phrasetable3 = 0;
+    concrete->phrasetable4 = 0;
+    concrete->epsilontable = 0;
+    concrete->last_fid = 0;
 
 	auto cflags = read_namespace<PgfFlag>(&PgfReader::read_flag);
 	concrete->cflags = cflags;
 
-	auto phrasetable = read_phrasetable();
+    PgfParseTableMaker tm(concrete);
-	concrete->phrasetable = phrasetable;
+    this->table_maker = &tm;
 
 	auto lincats = read_namespace<PgfConcrLincat>(&PgfReader::read_lincat);
 	concrete->lincats = lincats;
@@ -749,12 +716,14 @@ ref<PgfConcr> PgfReader::read_concrete()
 	auto lins = read_namespace<PgfConcrLin>(&PgfReader::read_lin);
 	concrete->lins = lins;
 
+    tm.prepare();
+
+    concrete->last_fid = tm.get_last_fid();
+    this->table_maker = NULL;
+
 	auto printnames = read_namespace<PgfConcrPrintname>(&PgfReader::read_printname);
 	concrete->printnames = printnames;
 
-    //PgfLRTableMaker maker(abstract, concrete);
-    //concrete->lrtable = maker.make();
-
     return concrete;
 }
 

src/runtime/c/pgf/reader.h

@@ -51,6 +51,9 @@ public:
     template <class C, class V>
     ref<C> read_vector(inline_vector<V> C::* field, void (PgfReader::*read_value)(ref<V> val));
 
+    template<class V>
+    vector<V> read_null_vector(void (PgfReader::*read_value)(ref<V> val));
+
     template<class V>
     vector<V> read_vector(void (PgfReader::*read_value)(ref<V> val));
 
@@ -70,17 +73,13 @@ public:
     void read_abstract(ref<PgfAbstr> abstract);
     void merge_abstract(ref<PgfAbstr> abstract);
 
+    ref<PgfConcrRule> read_rule();
     ref<PgfConcrLincat> read_lincat();
     vector<ref<PgfText>> read_lincat_fields(ref<PgfConcrLincat> lincat);
     ref<PgfLParam> read_lparam();
-    void read_variable_range(ref<PgfVariableRange> var_info);
+    void read_variable_range(ref<size_t> var_range);
     void read_parg(ref<PgfPArg> parg);
-    ref<PgfPResult> read_presult();
     PgfSymbol read_symbol();
-    ref<PgfSequence> read_seq();
-    vector<ref<PgfSequence>> read_seq_ids(object container);
-    PgfPhrasetable read_phrasetable(size_t len);
-    PgfPhrasetable read_phrasetable();
     ref<PgfConcrLin> read_lin();
     ref<PgfConcrPrintname> read_printname();
 
@@ -94,13 +93,17 @@ private:
     PgfProbsCallback *probs_callback;
     ref<PgfAbstr> abstract;
     ref<PgfConcr> concrete;
+    object container;
+
+    class PgfParseTableMaker *table_maker;
 
     object read_name_internal(size_t struct_size);
     object read_text_internal(size_t struct_size);
 
     void read_text2(ref<ref<PgfText>> r) { auto text = read_text(); *r = text; }
     void read_lparam(ref<ref<PgfLParam>> r) { auto lparam = read_lparam(); *r = lparam; }
-    void read_presult2(ref<ref<PgfPResult>> r) { auto res = read_presult(); *r = res; }
+    void read_rule2(ref<ref<PgfConcrRule>> r) { auto rule = read_rule(); *r = rule; }
+    void read_symbol2(ref<PgfSymbol> r) { auto sym = read_symbol(); *r = sym; }
 
     template<class I>
     ref<I> read_symbol_idx();

src/runtime/c/pgf/writer.cxx

@@ -144,6 +144,19 @@ void PgfWriter::write_vector(vector<V> vec, void (PgfWriter::*write_value)(ref<V
     }
 }
 
+template<class V>
+void PgfWriter::write_null_vector(vector<V> vec, void (PgfWriter::*write_value)(ref<V> val))
+{
+    if (vec == 0) {
+        write_len(0);
+    } else {
+        write_len(vec.size());
+        for (size_t i = 0; i < vec.size(); i++) {
+            (this->*write_value)(vec.elem(i));
+        }
+    }
+}
+
 void PgfWriter::write_literal(PgfLiteral literal)
 {
     auto tag = ref<PgfLiteral>::get_tag(literal);
@@ -277,10 +290,9 @@ void PgfWriter::write_abstract(ref<PgfAbstr> abstract)
     this->abstract = 0;
 }
 
-void PgfWriter::write_variable_range(ref<PgfVariableRange> var)
+void PgfWriter::write_variable_range(ref<size_t> var_range)
 {
-    write_int(var->var);
+    write_int(*var_range);
-    write_int(var->range);
 }
 
 void PgfWriter::write_lparam(ref<PgfLParam> lparam)
@@ -293,18 +305,19 @@ void PgfWriter::write_lparam(ref<PgfLParam> lparam)
     }
 }
 
-void PgfWriter::write_parg(ref<PgfPArg> parg)
+void PgfWriter::write_rule(ref<PgfConcrRule> rule)
 {
-    write_lparam(parg->param);
+    write_len(rule->syms.size());
-}
 
-void PgfWriter::write_presult(ref<PgfPResult> pres)
+    write_null_vector(rule->ranges, &PgfWriter::write_variable_range);
-{
+    write_lparam(rule->res);
-    if (pres->vars != 0)
+    write_null_vector(rule->args, &PgfWriter::write_lparam);
-        write_vector(pres->vars, &PgfWriter::write_variable_range);
+
-    else
+    write_lparam(rule->lin_idx);
-        write_len(0);
+
-    write_lparam(ref<PgfLParam>::from_ptr(&pres->param));
+    for (PgfSymbol sym : rule->syms) {
+        write_symbol(sym);
+    }
 }
 
 void PgfWriter::write_symbol(PgfSymbol sym)
@@ -341,10 +354,10 @@ void PgfWriter::write_symbol(PgfSymbol sym)
         write_len(sym_kp->alts.size());
         for (size_t i = 0; i < sym_kp->alts.size(); i++) {
 			ref<PgfAlternative> alt = sym_kp->alts.elem(i);
-            write_vector(alt->form->syms.as_vector(), &PgfWriter::write_symbol);
+            write_vector(alt->form, &PgfWriter::write_symbol);
             write_vector(alt->prefixes, &PgfWriter::write_text);
         }
-        write_vector(sym_kp->default_form->syms.as_vector(), &PgfWriter::write_symbol);
+        write_vector(sym_kp->default_form, &PgfWriter::write_symbol);
 		break;
 	}
 	case PgfSymbolBIND::tag:
@@ -359,36 +372,12 @@ void PgfWriter::write_symbol(PgfSymbol sym)
 	}
 }
 
-void PgfWriter::write_seq(ref<PgfSequence> seq)
-{
-	seq_ids.add(seq);
-    write_vector(seq->syms.as_vector(), &PgfWriter::write_symbol);
-}
-
-void PgfWriter::write_phrasetable(PgfPhrasetable table)
-{
-    write_len(phrasetable_size(table));
-    write_phrasetable_helper(table);
-}
-
-void PgfWriter::write_phrasetable_helper(PgfPhrasetable table)
-{
-    if (table == 0)
-        return;
-
-    write_phrasetable_helper(table->left);
-    write_seq(table->value.seq);
-    write_phrasetable_helper(table->right);
-}
-
 void PgfWriter::write_lincat(ref<PgfConcrLincat> lincat)
 {
     write_name(&lincat->name);
     write_vector(lincat->fields, &PgfWriter::write_lincat_field);
     write_len(lincat->n_lindefs);
-    write_vector(lincat->args, &PgfWriter::write_parg);
+    write_vector(lincat->rules, &PgfWriter::write_rule);
-    write_vector(lincat->res, &PgfWriter::write_presult);
-    write_vector(lincat->seqs, &PgfWriter::write_seq_id);
 }
 
 void PgfWriter::write_lincat_field(ref<ref<PgfText>> field)
@@ -399,9 +388,7 @@ void PgfWriter::write_lincat_field(ref<ref<PgfText>> field)
 void PgfWriter::write_lin(ref<PgfConcrLin> lin)
 {
     write_name(&lin->name);
-    write_vector(lin->args, &PgfWriter::write_parg);
+    write_vector(lin->rules, &PgfWriter::write_rule);
-    write_vector(lin->res, &PgfWriter::write_presult);
-    write_vector(lin->seqs, &PgfWriter::write_seq_id);
 }
 
 void PgfWriter::write_printname(ref<PgfConcrPrintname> printname)
@@ -428,16 +415,11 @@ void PgfWriter::write_concrete(ref<PgfConcr> concr)
         }
     }
 
-	seq_ids.start(concr);
-
     write_name(&concr->name);
     write_namespace<PgfFlag>(concr->cflags, &PgfWriter::write_flag);
-	write_phrasetable(concr->phrasetable);
     write_namespace<PgfConcrLincat>(concr->lincats, &PgfWriter::write_lincat);
 	write_namespace<PgfConcrLin>(concr->lins, &PgfWriter::write_lin);
 	write_namespace<PgfConcrPrintname>(concr->printnames, &PgfWriter::write_printname);
-
-	seq_ids.end();
 }
 
 void PgfWriter::write_pgf(ref<PgfPGF> pgf)

src/runtime/c/pgf/writer.h

@@ -24,6 +24,8 @@ public:
 
     template<class V>
     void write_vector(vector<V> vec, void (PgfWriter::*write_value)(ref<V> val));
+    template<class V>
+    void write_null_vector(vector<V> vec, void (PgfWriter::*write_value)(ref<V> val));
 
     void write_literal(PgfLiteral literal);
     void write_expr(PgfExpr expr);
@@ -40,14 +42,9 @@ public:
 
     void write_lincat(ref<PgfConcrLincat> lincat);
     void write_lincat_field(ref<ref<PgfText>> field);
-    void write_variable_range(ref<PgfVariableRange> var);
+    void write_variable_range(ref<size_t> var_range);
     void write_lparam(ref<PgfLParam> lparam);
-    void write_parg(ref<PgfPArg> linarg);
-    void write_presult(ref<PgfPResult> linres);
     void write_symbol(PgfSymbol sym);
-    void write_seq(ref<PgfSequence> seq);
-    void write_seq_id(ref<ref<PgfSequence>> r) { write_len(seq_ids.get(*r)); };
-    void write_phrasetable(PgfPhrasetable table);
     void write_lin(ref<PgfConcrLin> lin);
     void write_printname(ref<PgfConcrPrintname> printname);
 
@@ -58,18 +55,17 @@ public:
 private:
     template<class V>
     void write_namespace_helper(Namespace<V> nmsp, void (PgfWriter::*write_value)(ref<V>));
-    void write_phrasetable_helper(PgfPhrasetable table);
 
     void write_text(ref<ref<PgfText>> r) { write_text(&(**r)); };
     void write_lparam(ref<ref<PgfLParam>> r) { write_lparam(*r); };
+    void write_rule(ref<PgfConcrRule> rule);
     void write_symbol(ref<PgfSymbol> r) { write_symbol(*r); };
-    void write_presult(ref<ref<PgfPResult>> r) { write_presult(*r); };
+    void write_rule(ref<ref<PgfConcrRule>> r) { write_rule(*r); };
 
     FILE *out;
     PgfText **langs;
 
     ref<PgfAbstr> abstract;
-    PgfPhrasetableIds seq_ids;
 };
 
 #endif

src/runtime/haskell/PGF2.hsc

@@ -73,7 +73,7 @@ module PGF2 (-- * PGF
              graphvizAbstractTree, graphvizParseTree,
              Labels, getDepLabels,
              graphvizDependencyTree, conlls2latexDoc, getCncDepLabels,
-             graphvizWordAlignment, graphvizLRAutomaton,
+             graphvizWordAlignment,
 
              -- * Concrete syntax
              ConcName,Concr,languages,language,concreteName,languageCode,concreteFlag,
@@ -363,19 +363,14 @@ showPGF p =
           modifyIORef ref (\doc -> doc $$ text def)
 
     ppConcr name c = unsafePerformIO $ do
-      (seq_ids,doc3) <- prepareSequences c -- run first to update all seq_id
+      doc1 <- ppLincats c
-      doc1 <- ppLincats seq_ids c
+      doc2 <- ppLins c
-      doc2 <- ppLins seq_ids c
-      pgf_release_phrasetable_ids seq_ids
       return (text "concrete" <+> text name <+> char '{' $$
               nest 2 (doc1 $$
-                      doc2 $$
+                      doc2) $$
-                      (text "sequences" <+> char '{' $$ 
-                       nest 2 doc3 $$ 
-                       char '}')) $$
               char '}')
 
-    ppLincats seq_ids c = do
+    ppLincats c = do
       ref <- newIORef empty
       (allocaBytes (#size PgfItor) $ \itor ->
        bracket (wrapItorCallback (getLincats ref)) freeHaskellFunPtr $ \fptr ->
@@ -402,15 +397,15 @@ showPGF p =
                                        char ']')
           modifyIORef ref $ (\doc -> doc $$ def)
           forM_ (init [0..n_lindefs]) $ \i -> do
-            def <- bracket (pgf_print_lindef_internal seq_ids val i) free $ \c_text -> do
+            def <- bracket (pgf_print_lindef_internal val i) free $ \c_text -> do
                      fmap text (peekText c_text)
             modifyIORef ref (\doc -> doc $$ text "lindef" <+> def)
           forM_ (init [0..n_linrefs]) $ \i -> do
-            def <- bracket (pgf_print_linref_internal seq_ids val i) free $ \c_text -> do
+            def <- bracket (pgf_print_linref_internal val i) free $ \c_text -> do
                      fmap text (peekText c_text)
             modifyIORef ref $ (\doc -> doc $$ text "linref" <+> def)
 
-    ppLins seq_ids c = do
+    ppLins c = do
       ref <- newIORef empty
       (allocaBytes (#size PgfItor) $ \itor ->
        bracket (wrapItorCallback (getLins ref)) freeHaskellFunPtr $ \fptr ->
@@ -421,30 +416,13 @@ showPGF p =
       where
         getLins :: IORef Doc -> ItorCallback
         getLins ref itor key val exn = do
-          n_prods <- pgf_get_lin_get_prod_count val
+          n_prods <- pgf_get_lin_rules_count val
           forM_ (init [0..n_prods]) $ \i -> do
-            def <- bracket (pgf_print_lin_internal seq_ids val i) free $ \c_text -> do
+            def <- bracket (pgf_print_lin_internal val i) free $ \c_text -> do
                      fmap text (peekText c_text)
             modifyIORef ref (\doc -> doc $$ text "lin" <+> def)
             return ()
 
-    prepareSequences c = do
-      ref <- newIORef empty
-      seq_ids <- (allocaBytes (#size PgfSequenceItor) $ \itor ->
-                  bracket (wrapSequenceItorCallback (getSequences ref)) freeHaskellFunPtr $ \fptr ->
-                  withForeignPtr (c_revision c) $ \c_revision -> do
-                    (#poke PgfSequenceItor, fn) itor fptr
-                    withPgfExn "showPGF" (pgf_iter_sequences (a_db p) c_revision itor nullPtr))
-      doc <- readIORef ref
-      return (seq_ids, doc)
-      where
-        getSequences :: IORef Doc -> SequenceItorCallback
-        getSequences ref itor seq_id val exn = do
-          def <- bracket (pgf_print_sequence_internal seq_id val) free $ \c_text -> do
-                     fmap text (peekText c_text)
-          modifyIORef ref $ (\doc -> doc $$ def)
-          return 0
-
 -- | The abstract language name is the name of the top-level
 -- abstract module
 abstractName :: PGF -> AbsName
@@ -617,7 +595,12 @@ checkContext :: PGF -> [Hypo] -> Either String [Hypo]
 checkContext pgf ctxt = Right ctxt
 
 compute :: PGF -> Expr -> Expr
-compute = error "TODO: compute"
+compute p e =
+  unsafePerformIO $
+  withForeignPtr (a_revision p) $ \c_revision ->
+  bracket (newStablePtr e) freeStablePtr $ \c_e ->
+  bracket (withPgfExn "compute" (pgf_compute (a_db p) c_revision c_e marshaller unmarshaller)) freeStablePtr $ \c_e ->
+    deRefStablePtr c_e
 
 concreteName :: Concr -> ConcName
 concreteName c =
@@ -830,8 +813,7 @@ fullFormLexicon c = unsafePerformIO $ do
    withForeignPtr (c_revision c) $ \c_revision -> do
      (#poke PgfSequenceItor,   fn) itor1 fptr1
      (#poke PgfMorphoCallback, fn) itor2 fptr2
-     seq_ids <- withPgfExn "fullFormLexicon" (pgf_iter_sequences (c_db c) c_revision itor1 itor2)
+     withPgfExn "fullFormLexicon" (pgf_iter_sequences (c_db c) c_revision itor1 itor2))
-     pgf_release_phrasetable_ids seq_ids)
   fmap (reverse2 []) (readIORef ref)
   where
     getSequences ref _ seq_id val exn = do
@@ -866,19 +848,20 @@ data ParseOutput a
 parse :: Concr -> Type -> String -> ParseOutput [(Expr,Float)]
 parse c ty sent =
   unsafePerformIO $
-  withForeignPtr (c_revision c) $ \c_revision ->
+  withForeignPtr (c_revision c) $ \c_revision_ptr ->
   bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
   withText sent $ \c_sent -> do
-    c_enum <- withPgfExn "parse" (pgf_parse (c_db c) c_revision c_ty marshaller unmarshaller c_sent)
+    c_enum <- withPgfExn "parse" (pgf_parse (c_db c) c_revision_ptr c_ty marshaller unmarshaller c_sent)
-    exprs <- enumerateExprs (c_db c) c_enum
+    exprs <- enumerateExprs (c_db c) (c_revision c) c_enum
     return (ParseOk exprs)
 
-enumerateExprs c_db c_enum_ptr = do
+enumerateExprs c_db c_revision c_enum_ptr = do
   c_enum <- newForeignPtr pgf_free_expr_enum c_enum_ptr
   c_fetch <- (#peek PgfExprEnumVtbl, fetch) =<< (#peek PgfExprEnum, vtbl) c_enum_ptr
   unsafeInterleaveIO (fetchLazy c_fetch c_enum)
   where
     fetchLazy c_fetch c_enum =
+      withForeignPtr c_revision $ \_ ->
       withForeignPtr c_enum $ \c_enum_ptr ->
       alloca $ \p_prob -> do
         c_expr <- callFetch c_fetch c_enum_ptr c_db p_prob
@@ -1182,11 +1165,11 @@ generateAllExt p ty dp cs
   | otherwise = 
       unsafePerformIO $
       bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
-      withForeignPtr (a_revision p) $ \a_revision ->
+      withForeignPtr (a_revision p) $ \a_revision_ptr ->
       withPgfConcrs cs $ \c_db c_revisions n_revisions ->
       mask_ $ do
-        c_enum <- withPgfExn "generateAllExt" (pgf_generate_all (a_db p) a_revision c_revisions n_revisions c_ty (fromIntegral dp) marshaller unmarshaller)
+        c_enum <- withPgfExn "generateAllExt" (pgf_generate_all (a_db p) a_revision_ptr c_revisions n_revisions c_ty (fromIntegral dp) marshaller unmarshaller)
-        enumerateExprs (a_db p) c_enum
+        enumerateExprs (a_db p) (a_revision p) c_enum
 
 generateAllFrom :: PGF -> Expr -> [(Expr,Float)]
 generateAllFrom p ty = generateAllFromExt p ty maxBound []
@@ -1484,15 +1467,6 @@ graphvizDependencyTree
   -> String -- ^ Rendered output in the specified format
 graphvizDependencyTree format debug mlab mclab concr t = error "TODO: graphvizDependencyTree"
 
-graphvizLRAutomaton :: Concr -> String
-graphvizLRAutomaton c =
-  unsafePerformIO $
-  withForeignPtr (c_revision c) $ \c_revision ->
-  bracket (withPgfExn "graphvizLRAutomaton" (pgf_graphviz_lr_automaton (c_db c) c_revision)) free $ \c_text ->
-    if c_text == nullPtr
-      then return ""
-      else peekText c_text
-
 ---------------------- should be a separate module?
 
 -- visualization with latex output. AR Nov 2015

src/runtime/haskell/PGF2/FFI.hsc

@@ -48,9 +48,9 @@ data PgfSequenceItor
 data PgfProbsCallback
 data PgfMorphoCallback
 data PgfCohortsCallback
-data PgfPhrasetableIds
 data PgfExprEnum
 data PgfAlignmentPhrase
+data PgfParseTableMaker
 
 type Wrapper a = a -> IO (FunPtr a)
 type Dynamic a = FunPtr a -> a
@@ -150,26 +150,22 @@ foreign import ccall "wrapper" wrapCohortsCallback :: Wrapper CohortsCallback
 
 foreign import ccall pgf_lookup_cohorts :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfCohortsCallback -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_iter_sequences :: Ptr PgfDB -> Ptr Concr -> Ptr PgfSequenceItor -> Ptr PgfMorphoCallback -> Ptr PgfExn -> IO (Ptr PgfPhrasetableIds)
+foreign import ccall pgf_iter_sequences :: Ptr PgfDB -> Ptr Concr -> Ptr PgfSequenceItor -> Ptr PgfMorphoCallback -> Ptr PgfExn -> IO ()
 
 foreign import ccall pgf_get_lincat_counts_internal :: Ptr () -> Ptr CSize -> IO ()
 
 foreign import ccall pgf_get_lincat_field_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
 
-foreign import ccall pgf_print_lindef_internal :: Ptr PgfPhrasetableIds -> Ptr () -> CSize -> IO (Ptr PgfText)
+foreign import ccall pgf_print_lindef_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
 
-foreign import ccall pgf_print_linref_internal :: Ptr PgfPhrasetableIds -> Ptr () -> CSize -> IO (Ptr PgfText)
+foreign import ccall pgf_print_linref_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
 
-foreign import ccall pgf_get_lin_get_prod_count :: Ptr () -> IO CSize
+foreign import ccall pgf_get_lin_rules_count :: Ptr () -> IO CSize
 
-foreign import ccall pgf_print_lin_internal :: Ptr PgfPhrasetableIds -> Ptr () -> CSize -> IO (Ptr PgfText)
+foreign import ccall pgf_print_lin_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
-
-foreign import ccall pgf_print_sequence_internal :: CSize -> Ptr () -> IO (Ptr PgfText)
 
 foreign import ccall pgf_sequence_get_text_internal :: Ptr () -> IO (Ptr PgfText)
 
-foreign import ccall pgf_release_phrasetable_ids :: Ptr PgfPhrasetableIds -> IO ()
-
 type ItorCallback = Ptr PgfItor -> Ptr PgfText -> Ptr () -> Ptr PgfExn -> IO ()
 
 foreign import ccall "wrapper" wrapItorCallback :: Wrapper ItorCallback
@@ -210,6 +206,8 @@ foreign import ccall pgf_infer_expr :: Ptr PgfDB -> Ptr PGF -> Ptr (StablePtr Ex
 
 foreign import ccall pgf_check_type :: Ptr PgfDB -> Ptr PGF -> StablePtr Type -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
 
+foreign import ccall pgf_compute :: Ptr PgfDB -> Ptr PGF -> StablePtr Expr -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr)
+
 foreign import ccall pgf_generate_random :: Ptr PgfDB -> Ptr PGF -> Ptr (Ptr Concr) -> CSize -> StablePtr Type -> CSize -> Ptr Word64 -> Ptr (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr)
 
 foreign import ccall pgf_generate_random_from :: Ptr PgfDB -> Ptr PGF -> Ptr (Ptr Concr) -> CSize -> StablePtr Expr -> CSize -> Ptr Word64 -> Ptr (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr)
@@ -230,9 +228,11 @@ foreign import ccall pgf_create_category :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText
 
 foreign import ccall pgf_drop_category :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_create_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr Concr)
+foreign import ccall pgf_create_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr (Ptr PgfParseTableMaker) -> Ptr PgfExn -> IO (Ptr Concr)
 
-foreign import ccall pgf_clone_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr Concr)
+foreign import ccall pgf_clone_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr (Ptr PgfParseTableMaker) -> Ptr PgfExn -> IO (Ptr Concr)
+
+foreign import ccall pgf_free_parse_table :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> IO ()
 
 foreign import ccall pgf_drop_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO ()
 
@@ -244,7 +244,7 @@ foreign import ccall "dynamic" callLinBuilder1 :: Dynamic (Ptr PgfLinBuilderIfac
 
 foreign import ccall "dynamic" callLinBuilder2 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> Ptr PgfExn -> IO ())
 
-foreign import ccall "dynamic" callLinBuilder3 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> CSize -> Ptr CSize -> Ptr PgfExn -> IO ())
+foreign import ccall "dynamic" callLinBuilder3 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> Ptr CSize -> Ptr PgfExn -> IO ())
 
 foreign import ccall "dynamic" callLinBuilder4 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> CSize -> Ptr CSize -> Ptr PgfExn -> IO ())
 
@@ -254,13 +254,13 @@ foreign import ccall "dynamic" callLinBuilder6 :: Dynamic (Ptr PgfLinBuilderIfac
 
 foreign import ccall "dynamic" callLinBuilder7 :: Dynamic (Ptr PgfLinBuilderIface -> Ptr PgfExn -> IO CSize)
 
-foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> CSize -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> CSize -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
 
 foreign import ccall pgf_drop_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_create_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_create_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_alter_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_alter_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
 
 foreign import ccall pgf_drop_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()
 
@@ -318,8 +318,6 @@ foreign import ccall pgf_graphviz_parse_tree :: Ptr PgfDB -> Ptr Concr -> Stable
 
 foreign import ccall pgf_graphviz_word_alignment :: Ptr PgfDB -> Ptr (Ptr Concr) -> CSize -> StablePtr Expr -> Ptr PgfPrintContext -> Ptr PgfMarshaller -> Ptr PgfGraphvizOptions -> Ptr PgfExn -> IO (Ptr PgfText)
 
-foreign import ccall pgf_graphviz_lr_automaton :: Ptr PgfDB -> Ptr Concr -> Ptr PgfExn -> IO (Ptr PgfText)
-
 
 -----------------------------------------------------------------------
 -- Texts

src/runtime/haskell/PGF2/Transactions.hsc

@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-}
 module PGF2.Transactions
           ( -- transactions
             TxnID
@@ -18,15 +19,14 @@ module PGF2.Transactions
           , setAbstractFlag
 
             -- concrete syntax
-          , Token, SeqId, LIndex, LVar, LParam(..)
+          , Token, LIndex, LVar, LParam(..)
-          , PArg(..), Symbol(..), Production(..)
+          , PArg(..), Symbol(..), Rule(..)
 
           , createConcrete
           , alterConcrete
           , dropConcrete
           , mergePGF
           , setConcreteFlag
-          , SeqTable
           , createLincat
           , dropLincat
           , createLin, alterLin
@@ -50,27 +50,31 @@ import Data.IORef
 #include <pgf/pgf.h>
 
 newtype Transaction k a =
-  Transaction (Ptr PgfDB -> Ptr PGF -> Ptr k -> Ptr PgfExn -> IO a)
+  Transaction (Ptr PgfDB -> Ptr PGF -> TransactionCtxt k -> Ptr PgfExn -> IO a)
+
+type family TransactionCtxt a
+type instance TransactionCtxt PGF = ()
+type instance TransactionCtxt Concr = (Ptr Concr, Ptr PgfParseTableMaker)
 
 instance Functor (Transaction k) where
-  fmap f (Transaction g) = Transaction $ \c_db c_abstr c_revision c_exn -> do
+  fmap f (Transaction g) = Transaction $ \c_db c_abstr ctxt c_exn -> do
-    res <- g c_db c_abstr c_revision c_exn
+    res <- g c_db c_abstr ctxt c_exn
     return (f res)
 
 instance Applicative (Transaction k) where
-  pure x = Transaction $ \c_db _ c_revision c_exn -> return x
+  pure x = Transaction $ \c_db _ _ c_exn -> return x
   f <*> g = do
     f <- f
     g <- g
     return (f g)
 
 instance Monad (Transaction k) where
-  (Transaction f) >>= g = Transaction $ \c_db c_abstr c_revision c_exn -> do
+  (Transaction f) >>= g = Transaction $ \c_db c_abstr ctxt c_exn -> do
-    res <- f c_db c_abstr c_revision c_exn
+    res <- f c_db c_abstr ctxt c_exn
     ex_type <- (#peek PgfExn, type) c_exn
     if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
       then case g res of
-             Transaction g -> g c_db c_abstr c_revision c_exn
+             Transaction g -> g c_db c_abstr ctxt c_exn
       else return undefined
 
 #if !(MIN_VERSION_base(4,13,0))
@@ -79,7 +83,7 @@ instance Monad (Transaction k) where
 #endif
 
 instance Fail.MonadFail (Transaction k) where
-  fail msg = Transaction $ \c_db c_abstr c_revision c_exn -> fail msg
+  fail msg = Transaction $ \c_db c_abstr ctxt c_exn -> fail msg
 
 data TxnID = TxnID (Ptr PgfDB) (ForeignPtr PGF)
 
@@ -103,7 +107,7 @@ inTransaction :: TxnID -> Transaction PGF a -> IO a
 inTransaction (TxnID db fptr) (Transaction f) =
   withForeignPtr fptr $ \c_revision -> do
   withPgfExn "inTransaction" $ \c_exn ->
-    f db c_revision c_revision c_exn
+    f db c_revision () c_exn
 
 {- | @modifyPGF gr t@ updates the grammar @gr@ by performing the
    transaction @t@. The changes are applied to the new grammar
@@ -117,7 +121,7 @@ modifyPGF p (Transaction f) =
     c_revision <- pgf_start_transaction (a_db p) c_exn
     ex_type <- (#peek PgfExn, type) c_exn
     if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
-      then do ((restore (f (a_db p) c_revision c_revision c_exn))
+      then do ((restore (f (a_db p) c_revision () c_exn))
                `catch`
                (\e -> do
                     pgf_free_revision_ (a_db p) c_revision
@@ -151,11 +155,11 @@ checkoutPGF p = do
      already a function with the same name then an exception is thrown.
 -}
 createFunction :: Fun -> Type -> Int -> [[Instr]] -> Float -> Transaction PGF Fun
-createFunction name ty arity bytecode prob = Transaction $ \c_db _ c_revision c_exn ->
+createFunction name ty arity bytecode prob = Transaction $ \c_db c_abstr _ c_exn ->
   withText name $ \c_name ->
   bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
   (if null bytecode then (\f -> f nullPtr) else (allocaBytes 0)) $ \c_bytecode -> do
-    c_name <- pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) c_bytecode prob marshaller c_exn
+    c_name <- pgf_create_function c_db c_abstr c_name c_ty (fromIntegral arity) c_bytecode prob marshaller c_exn
     if c_name == nullPtr
       then return ""
       else do name  <- peekText c_name
@@ -163,75 +167,78 @@ createFunction name ty arity bytecode prob = Transaction $ \c_db _ c_revision c_
               return name
 
 dropFunction :: Fun -> Transaction PGF ()
-dropFunction name = Transaction $ \c_db _ c_revision c_exn ->
+dropFunction name = Transaction $ \c_db c_abstr _ c_exn ->
   withText name $ \c_name -> do
-    pgf_drop_function c_db c_revision c_name c_exn
+    pgf_drop_function c_db c_abstr c_name c_exn
 
 createCategory :: Cat -> [Hypo] -> Float -> Transaction PGF ()
-createCategory name hypos prob = Transaction $ \c_db _ c_revision c_exn ->
+createCategory name hypos prob = Transaction $ \c_db c_abstr _ c_exn ->
   withText name $ \c_name ->
   withHypos hypos $ \n_hypos c_hypos -> do
-    pgf_create_category c_db c_revision c_name n_hypos c_hypos prob marshaller c_exn
+    pgf_create_category c_db c_abstr c_name n_hypos c_hypos prob marshaller c_exn
 
 dropCategory :: Cat -> Transaction PGF ()
-dropCategory name = Transaction $ \c_db _ c_revision c_exn ->
+dropCategory name = Transaction $ \c_db c_abstr _ c_exn ->
   withText name $ \c_name -> do
-    pgf_drop_category c_db c_revision c_name c_exn
+    pgf_drop_category c_db c_abstr c_name c_exn
 
 createConcrete :: ConcName -> Transaction Concr () -> Transaction PGF ()
-createConcrete name (Transaction f) = Transaction $ \c_db c_abstr c_revision c_exn ->
+createConcrete name (Transaction f) = Transaction $ \c_db c_abstr _ c_exn ->
-  withText name $ \c_name -> do
+  withText name $ \c_name ->
-  bracketPtr (pgf_create_concrete c_db c_revision c_name c_exn)
+  bracketCnc c_exn
-             (pgf_free_concr_revision_ c_db) $ \c_concr_revision ->
+             (pgf_create_concrete c_db c_abstr c_name)
-    f c_db c_abstr c_concr_revision c_exn
+             (\c tm -> pgf_free_parse_table c_db c_abstr c tm >> pgf_free_concr_revision_ c_db c) $ \ctxt -> do
+    f c_db c_abstr ctxt c_exn
 
 alterConcrete :: ConcName -> Transaction Concr a -> Transaction PGF a
-alterConcrete name (Transaction f) = Transaction $ \c_db c_abstr c_revision c_exn ->
+alterConcrete name (Transaction f) = Transaction $ \c_db c_abstr _ c_exn ->
   withText name $ \c_name -> do
-  bracketPtr (pgf_clone_concrete c_db c_revision c_name c_exn)
+  bracketCnc c_exn
-             (pgf_free_concr_revision_ c_db) $ \c_concr_revision ->
+             (pgf_clone_concrete c_db c_abstr c_name)
-    f c_db c_abstr c_concr_revision c_exn
+             (\c tm -> pgf_free_parse_table c_db c_abstr c tm >> pgf_free_concr_revision_ c_db c) $ \ctxt -> do
+    f c_db c_abstr ctxt c_exn
 
-bracketPtr before after thing =
+bracketCnc c_exn before after thing =
+  alloca $ \p_tm ->
   mask $ \restore -> do
-    a <- before
+    c <- before p_tm c_exn
-    if a == nullPtr
+    if c == nullPtr
       then return undefined
-      else do r <- restore (thing a) `onException` after a
+      else do tm <- peek p_tm
-              _ <- after a
+              r <- restore (thing (c,tm)) `onException` after c tm
+              _ <- after c tm
               return r
 
 dropConcrete :: ConcName -> Transaction PGF ()
-dropConcrete name = Transaction $ \c_db _ c_revision c_exn ->
+dropConcrete name = Transaction $ \c_db c_abstr _ c_exn ->
   withText name $ \c_name -> do
-    pgf_drop_concrete c_db c_revision c_name c_exn
+    pgf_drop_concrete c_db c_abstr c_name c_exn
 
 mergePGF :: FilePath -> Transaction PGF ()
-mergePGF fpath = Transaction $ \c_db _ c_revision c_exn ->
+mergePGF fpath = Transaction $ \c_db c_abstr _ c_exn ->
   withCString fpath $ \c_fpath ->
-    pgf_merge_pgf c_db c_revision c_fpath c_exn
+    pgf_merge_pgf c_db c_abstr c_fpath c_exn
 
 setGlobalFlag :: String -> Literal -> Transaction PGF ()
-setGlobalFlag name value = Transaction $ \c_db _ c_revision c_exn ->
+setGlobalFlag name value = Transaction $ \c_db c_abstr _ c_exn ->
   withText name $ \c_name ->
   bracket (newStablePtr value) freeStablePtr $ \c_value ->
-    pgf_set_global_flag c_db c_revision c_name c_value marshaller c_exn
+    pgf_set_global_flag c_db c_abstr c_name c_value marshaller c_exn
 
 setAbstractFlag :: String -> Literal -> Transaction PGF ()
-setAbstractFlag name value = Transaction $ \c_db _ c_revision c_exn ->
+setAbstractFlag name value = Transaction $ \c_db c_abstr _ c_exn ->
   withText name $ \c_name ->
   bracket (newStablePtr value) freeStablePtr $ \c_value ->
-    pgf_set_abstract_flag c_db c_revision c_name c_value marshaller c_exn
+    pgf_set_abstract_flag c_db c_abstr c_name c_value marshaller c_exn
 
 setConcreteFlag :: String -> Literal -> Transaction Concr ()
-setConcreteFlag name value = Transaction $ \c_db _ c_revision c_exn ->
+setConcreteFlag name value = Transaction $ \c_db _ (c_revision,_) c_exn ->
   withText name $ \c_name ->
   bracket (newStablePtr value) freeStablePtr $ \c_value ->
     pgf_set_concrete_flag c_db c_revision c_name c_value marshaller c_exn
 
 type Token  = String
 
-type SeqId  = Int
 type LIndex = Int
 type LVar   = Int
 data LParam  = LParam {-# UNPACK #-} !LIndex [(LIndex,LVar)]
@@ -251,22 +258,21 @@ data Symbol
   | SymALL_CAPIT                    -- the special ALL_CAPIT token
   deriving (Eq,Ord,Show)
 
+type Quantifiers = [Int]
+data Rule = Rule Quantifiers LParam [LParam] LParam [Symbol]
+                 deriving (Eq,Ord,Show)
+
 data PArg = PArg [(LIndex,LIndex)] {-# UNPACK #-} !LParam
             deriving (Eq,Show)
 
-data Production = Production [(LVar,LIndex)] [PArg] LParam [SeqId]
+createLincat :: Cat -> [String] -> [Rule] -> [Rule] -> Transaction Concr ()
-                 deriving (Eq,Show)
+createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr (c_revision,tm) c_exn ->
-
-type SeqTable = Seq.Seq (Either [Symbol] SeqId)
-
-createLincat :: Cat -> [String] -> [Production] -> [Production] -> SeqTable -> Transaction Concr SeqTable
-createLincat name fields lindefs linrefs seqtbl = Transaction $ \c_db c_abstr c_revision c_exn ->
   let n_fields = length fields
   in withText name $ \c_name ->
      allocaBytes (n_fields*(#size PgfText*)) $ \c_fields ->
      withTexts c_fields 0 fields $
-     withBuildLinIface (lindefs++linrefs) seqtbl $ \c_build ->
+     withBuildLinIface (lindefs++linrefs) $ \c_build ->
-       pgf_create_lincat c_db c_abstr c_revision c_name
+       pgf_create_lincat c_db c_abstr c_revision tm c_name
                          (fromIntegral n_fields) c_fields
                          (fromIntegral (length lindefs)) (fromIntegral (length linrefs))
                          c_build c_exn
@@ -278,31 +284,29 @@ createLincat name fields lindefs linrefs seqtbl = Transaction $ \c_db c_abstr c_
         withTexts p (i+1) ss f
 
 dropLincat :: Cat -> Transaction Concr ()
-dropLincat name = Transaction $ \c_db  c_abstr c_revision c_exn ->
+dropLincat name = Transaction $ \c_db  c_abstr (c_revision,tm) c_exn ->
   withText name $ \c_name ->
     pgf_drop_lincat c_db  c_abstr c_revision c_name c_exn
 
-createLin :: Fun -> [Production] -> SeqTable -> Transaction Concr SeqTable
+createLin :: Fun -> [Rule] -> Transaction Concr ()
-createLin name prods seqtbl = Transaction $ \c_db c_abstr c_revision c_exn ->
+createLin name rules = Transaction $ \c_db c_abstr (c_revision,tm) c_exn ->
   withText name $ \c_name ->
-  withBuildLinIface prods seqtbl $ \c_build ->
+  withBuildLinIface rules $ \c_build ->
-    pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn
+    pgf_create_lin c_db c_abstr c_revision tm c_name (fromIntegral (length rules)) c_build c_exn
 
-alterLin :: Fun -> [Production] -> SeqTable -> Transaction Concr SeqTable
+alterLin :: Fun -> [Rule] -> Transaction Concr ()
-alterLin name prods seqtbl = Transaction $ \c_db c_abstr c_revision c_exn ->
+alterLin name rules = Transaction $ \c_db c_abstr (c_revision,tm) c_exn ->
   withText name $ \c_name ->
-  withBuildLinIface prods seqtbl $ \c_build ->
+  withBuildLinIface rules $ \c_build ->
-    pgf_alter_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn
+    pgf_alter_lin c_db c_abstr c_revision tm c_name (fromIntegral (length rules)) c_build c_exn
 
-withBuildLinIface prods seqtbl f = do
+withBuildLinIface rules f = do
-  ref <- newIORef seqtbl
   (allocaBytes (#size PgfBuildLinIface) $ \c_build ->
    allocaBytes (#size PgfBuildLinIfaceVtbl) $ \vtbl ->
-   bracket (wrapLinBuild (build ref)) freeHaskellFunPtr $ \c_callback -> do
+   bracket (wrapLinBuild build) freeHaskellFunPtr $ \c_callback -> do
      (#poke PgfBuildLinIface, vtbl) c_build vtbl
      (#poke PgfBuildLinIfaceVtbl, build) vtbl c_callback
      f c_build)
-  readIORef ref
   where
     forM_ []     c_exn f = return ()
     forM_ (x:xs) c_exn f = do
@@ -311,31 +315,23 @@ withBuildLinIface prods seqtbl f = do
         then f x >> forM_ xs c_exn f
         else return ()
 
-    build ref _ c_builder c_exn = do
+    build _ c_builder c_exn = do
       vtbl <- (#peek PgfLinBuilderIface, vtbl) c_builder
-      forM_ prods c_exn $ \(Production vars args res seqids) -> do
+      forM_ rules c_exn $ \(Rule vars res args lin_idx seq) -> do
-        fun <- (#peek PgfLinBuilderIfaceVtbl, start_production) vtbl
+        fun <- (#peek PgfLinBuilderIfaceVtbl, start_rule) vtbl
-        callLinBuilder0 fun c_builder c_exn
+        callLinBuilder2 fun c_builder (fromIntegral (length vars)) (fromIntegral (length seq)) c_exn
         fun <- (#peek PgfLinBuilderIfaceVtbl, add_argument) vtbl
-        forM_ args c_exn $ \(PArg hypos param) ->
+        forM_ args c_exn $ \arg ->
-          callLParam (callLinBuilder3 fun c_builder (fromIntegral (length hypos))) param c_exn
+          callLParam (callLinBuilder3 fun c_builder) arg c_exn
         fun <- (#peek PgfLinBuilderIfaceVtbl, set_result) vtbl
-        callLParam (callLinBuilder3 fun c_builder (fromIntegral (length vars))) res c_exn
+        callLParam (callLinBuilder3 fun c_builder) res c_exn
+        fun <- (#peek PgfLinBuilderIfaceVtbl, set_lin_idx) vtbl
+        callLParam (callLinBuilder3 fun c_builder) lin_idx c_exn
         fun <- (#peek PgfLinBuilderIfaceVtbl, add_variable) vtbl
-        forM_ vars c_exn $ \(v,r) ->
+        forM_ vars c_exn $ \r ->
-          callLinBuilder2 fun c_builder (fromIntegral v) (fromIntegral r) c_exn
+          callLinBuilder1 fun c_builder (fromIntegral r) c_exn
-        fun <- (#peek PgfLinBuilderIfaceVtbl, add_sequence_id) vtbl
+        forM_ seq c_exn (addSymbol c_builder vtbl c_exn)
-        seqtbl <- readIORef ref
+        fun <- (#peek PgfLinBuilderIfaceVtbl, end_rule) vtbl
-        forM_ seqids c_exn $ \seqid ->
-          case Seq.index seqtbl seqid of
-            Left syms   -> do fun    <- (#peek PgfLinBuilderIfaceVtbl, start_sequence) vtbl
-                              callLinBuilder1 fun c_builder (fromIntegral (length syms)) c_exn
-                              forM_ syms c_exn (addSymbol c_builder vtbl c_exn)
-                              fun <- (#peek PgfLinBuilderIfaceVtbl, end_sequence) vtbl
-                              seqid' <- callLinBuilder7 fun c_builder c_exn
-                              writeIORef ref $! Seq.update seqid (Right (fromIntegral seqid')) seqtbl
-            Right seqid -> do callLinBuilder1 fun c_builder (fromIntegral seqid) c_exn
-        fun <- (#peek PgfLinBuilderIfaceVtbl, end_production) vtbl
         callLinBuilder0 fun c_builder c_exn
 
     addSymbol c_builder vtbl c_exn (SymCat d r) = do
@@ -406,12 +402,12 @@ withBuildLinIface prods seqtbl f = do
           pokeTerms (c_terms `plusPtr` (2*(#size size_t))) terms
 
 dropLin :: Fun -> Transaction Concr ()
-dropLin name = Transaction $ \c_db c_abstr c_revision c_exn ->
+dropLin name = Transaction $ \c_db c_abstr (c_revision,_) c_exn ->
   withText name $ \c_name ->
     pgf_drop_lin c_db c_abstr c_revision c_name c_exn
 
 setPrintName :: Fun -> String -> Transaction Concr ()
-setPrintName fun name = Transaction $ \c_db _ c_revision c_exn ->
+setPrintName fun name = Transaction $ \c_db _ (c_revision,_) c_exn ->
   withText fun $ \c_fun ->
   withText name $ \c_name -> do
     pgf_set_printname c_db c_revision c_fun c_name c_exn
@@ -434,7 +430,7 @@ getFunctionType fun = Transaction $ \c_db c_revision _ c_exn -> do
 -- | A monadic version of 'categoryFields' which returns the fields of
 -- a category from grammar in the current transaction.
 getCategoryFields :: Cat -> Transaction Concr (Maybe [String])
-getCategoryFields cat = Transaction $ \c_db _ c_revision c_exn ->
+getCategoryFields cat = Transaction $ \c_db _ (c_revision,_) c_exn ->
   withText cat $ \c_cat ->
   alloca $ \p_n_fields -> do
     c_fields <- pgf_category_fields c_db c_revision c_cat p_n_fields c_exn

src/runtime/python/pypgf.c

@@ -243,7 +243,7 @@ BIND_alloc(PyTypeObject *self, Py_ssize_t nitems)
 static PyTypeObject pgf_BINDType = {
     PyVarObject_HEAD_INIT(NULL, 0)
     //0,                       /*ob_size*/
-    "pgf.BINDType",            /*tp_name*/
+    "pgf.BIND",                /*tp_name*/
     sizeof(BINDObject),        /*tp_basicsize*/
     0,                         /*tp_itemsize*/
     (destructor) BIND_dealloc, /*tp_dealloc*/
@@ -1952,6 +1952,34 @@ pgf_showExpr(PyObject *self, PyObject *args)
     return str;
 }
 
+static void
+collect_funs(PyObject *pylist,ExprObject *expr) {
+    if (Py_TYPE(expr) == &pgf_ExprAbsType) {
+        collect_funs(pylist,((ExprAbsObject*) expr)->body);
+    } else if (Py_TYPE(expr) == &pgf_ExprAppType) {
+        collect_funs(pylist,((ExprAppObject*) expr)->fun);
+        collect_funs(pylist,((ExprAppObject*) expr)->arg);
+    } else if (Py_TYPE(expr) == &pgf_ExprFunType) {
+        PyList_Append(pylist,((ExprFunObject*) expr)->name);
+    } else if (Py_TYPE(expr) == &pgf_ExprTypedType) {
+        collect_funs(pylist,((ExprTypedObject*) expr)->expr);
+    } else if (Py_TYPE(expr) == &pgf_ExprImplArgType) {
+        collect_funs(pylist,((ExprImplArgObject*) expr)->expr);
+    }
+}
+
+static PyObject *
+pgf_exprFunctions(PyObject *self, PyObject *args)
+{
+    ExprObject *expr;
+    if (!PyArg_ParseTuple(args, "O!", &pgf_ExprType, &expr))
+        return NULL;
+
+    PyObject *pylist = PyList_New(0);
+    collect_funs(pylist,(ExprObject*) expr);
+    return pylist;
+}
+
 static TypeObject *
 pgf_readType(PyObject *self, PyObject *args)
 {
@@ -2081,6 +2109,8 @@ static PyMethodDef module_methods[] = {
      "Parses a string as an abstract tree"},
     {"showExpr", (void*)pgf_showExpr, METH_VARARGS,
      "Renders an expression as a string"},
+    {"exprFunctions", (void*)pgf_exprFunctions, METH_VARARGS,
+     "Returns the list of functions used in an expression"},
     {"readType", (void*)pgf_readType, METH_VARARGS,
      "Parses a string as an abstract type"},
     {"showType", (void*)pgf_showType, METH_VARARGS,