From 3a1990fd1d399960babfbcb055b262d979a21d60 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sun, 18 May 2025 07:20:12 +0200
Subject: [PATCH 001/144] switch to using the new type checker by default

---
 src/compiler/api/GF/Command/SourceCommands.hs |  6 +--
 src/compiler/api/GF/Compile/CheckGrammar.hs   | 38 ++++++++++---------
 .../api/GF/Compile/Compute/Concrete2.hs       |  8 ++--
 src/compiler/api/GF/Compile/Repl.hs           | 14 +++----
 .../api/GF/Compile/TypeCheck/ConcreteNew.hs   | 32 ++++++++++------
 src/compiler/api/GF/Grammar/Grammar.hs        |  2 +-
 src/compiler/api/GF/Grammar/Parser.y          |  4 +-
 7 files changed, 56 insertions(+), 48 deletions(-)

diff --git a/src/compiler/api/GF/Command/SourceCommands.hs b/src/compiler/api/GF/Command/SourceCommands.hs
index f7f98308d..2ef833a5c 100644
--- a/src/compiler/api/GF/Command/SourceCommands.hs
+++ b/src/compiler/api/GF/Command/SourceCommands.hs
@@ -245,10 +245,10 @@ checkComputeTerm os sgr t =
              Nothing -> checkError (pp "No source grammar in scope")
              Just mo -> return mo
      t <- renameSourceTerm sgr mo t
-     ttys <- inferLType g t
+     (t,_) <- inferLType g t
      if isOpt "flat" os
-       then fmap concat (mapM (\(t,_) -> fmap (map evalStr) (normalFlatForm g t)) ttys)
-       else fmap concat (mapM (\(t,_) -> fmap (singleton . evalStr) (normalForm g t)) ttys)
+       then fmap (map evalStr) (normalFlatForm g t)
+       else fmap (singleton . evalStr) (normalForm g t)
   where
     -- ** Try to compute pre{...} tokens in token sequences
     singleton x = [x]
diff --git a/src/compiler/api/GF/Compile/CheckGrammar.hs b/src/compiler/api/GF/Compile/CheckGrammar.hs
index 14fa23f47..9003a3485 100644
--- a/src/compiler/api/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/api/GF/Compile/CheckGrammar.hs
@@ -27,9 +27,9 @@ import GF.Infra.Ident
 import GF.Infra.Option
 
 import GF.Compile.TypeCheck.Abstract
-import GF.Compile.TypeCheck.Concrete(checkLType,inferLType,ppType)
-import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
-import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef)
+import GF.Compile.TypeCheck.Concrete(ppType)
+import GF.Compile.TypeCheck.ConcreteNew(checkLType,inferLType)
+import GF.Compile.Compute.Concrete2(normalForm,Globals(..),stdPredef)
 
 import GF.Grammar
 import GF.Grammar.Lexer
@@ -173,26 +173,26 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
     CncCat mty mdef mref mpr mpmcfg -> do
       mty  <- case mty of
                 Just (L loc typ) -> chIn loc "linearization type of" $ do
-                                      (typ,_) <- checkLType gr [] typ typeType
-                                      typ  <- normalForm (Gl gr stdPredef) typ
+                                      (typ,_) <- checkLType g typ typeType
+                                      typ  <- normalForm g 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 gr [] def (mkFunType [typeStr] typ)
+                       (def,_) <- checkLType g 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 gr [] ref (mkFunType [typ] typeStr)
+                       (ref,_) <- checkLType g 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 gr [] t typeStr
+                       (t,_) <- checkLType g t typeStr
                        return (Just (L loc t))
                 _ -> return Nothing
       update sm c (CncCat mty mdef mref mpr mpmcfg)
@@ -201,13 +201,13 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
       mt <- case (mty,mt) of
               (Just (_,cat,cont,val),Just (L loc trm)) ->
                   chIn loc "linearization of" $ do
-                     (trm,_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val)  -- erases arg vars
+                     (trm,_) <- checkLType g trm (mkFunType (map (\(_,_,ty) -> ty) 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 gr [] t typeStr
+                       (t,_) <- checkLType g t typeStr
                        return (Just (L loc t))
                 _ -> return Nothing
       update sm c (CncFun mty mt mpr mpmcfg)
@@ -216,14 +216,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 gr [] ty typeType
-                         normalForm (Gl gr stdPredef) ty
+                         (ty,_) <- checkLType g ty typeType
+                         normalForm g ty
            (de',_) <- chIn locd "operation" $
-                         checkLType gr [] de ty'
+                         checkLType g de ty'
            return (Just (L loct ty'), Just (L locd de'))
          (Nothing         , Just (L locd de)) -> do
            (de',ty') <- chIn locd "operation" $
-                          inferLType gr [] de
+                          inferLType g de
            return (Just (L locd ty'), Just (L locd de'))
          (Just (L loct ty), Nothing) -> do
            chIn loct "operation" $
@@ -231,9 +231,9 @@ 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 gr [] 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 g 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 <- mapM (uncurry $ flip (checkLType gr []))
+      tysts1 <- mapM (uncurry $ flip (checkLType g))
                   [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
       --- this can only be a partial guarantee, since matching
       --- with value type is only possible if expected type is given
@@ -249,11 +249,12 @@ 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)
    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 (Gl gr stdPredef) ty >>= \ty -> return (b,v,ty)) co
+     co <- mapM (\(b,v,ty) -> normalForm g 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)
@@ -327,6 +328,7 @@ linTypeOfType cnc m (L loc typ) = do
                              plusRecType vars val
      return ((Explicit,varX i,rec),cat)
    lookLin (_,c) = checks [ --- rather: update with defLinType ?
-      lookupLincat cnc m c >>= normalForm (Gl cnc stdPredef)
+      lookupLincat cnc m c >>= normalForm g
      ,return defLinType
      ]
+   g = Gl cnc (stdPredef g)
diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index ee7e4b024..d8e24a363 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -86,7 +86,7 @@ data Value
   | VAlts Value [(Value, Value)]
   | VStrs [Value]
   | VMarkup Ident [(Ident,Value)] [Value]
-  | VReset Ident (Maybe Value) Value QIdent
+  | VReset Ident (Maybe Value) Value (Maybe QIdent)
   | VSymCat Int LIndex [(LIndex, (Value, Type))]
   | VError Doc
     -- These two constructors are only used internally
@@ -932,7 +932,7 @@ 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
   return (Markup tag as ts)
-value2termM flat xs (VReset ctl mb_cv v qid) = do
+value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
   ts <- reset (value2termM True xs v)
   reduce ctl mb_cv ts
   where
@@ -960,8 +960,8 @@ value2termM flat xs (VReset ctl mb_cv v qid) = do
            ([],       _) -> mzero
            ([t],      _) -> return t
            (ts,Just cv)  ->
-             do let cat = showIdent (snd qid)
-                    mn  = fst qid
+             do let Just (mn,id) = mb_qid
+                    cat = showIdent id
                 ct <- value2termM flat xs cv
                 t <- listify mn cat ts
                 return (App (App (QC (mn,identS ("Conj"++cat))) ct) t)
diff --git a/src/compiler/api/GF/Compile/Repl.hs b/src/compiler/api/GF/Compile/Repl.hs
index 8cb7d92a0..fd06bb8cd 100644
--- a/src/compiler/api/GF/Compile/Repl.hs
+++ b/src/compiler/api/GF/Compile/Repl.hs
@@ -167,12 +167,11 @@ runRepl' opts@ReplOpts { lang, evalToFlat } gl@(Gl g _) = do
     -- Show the inferred type of an expression
     command st "t" arg = do
       parseThen lang g arg $ \main ->
-        execCheck (inferLType gl main) $ \res ->
-          forM_ res $ \(t, ty) ->
-            let t' = case t of
-                       Typed _ _ -> t
-                       t         -> Typed t ty
-            in outputStrLn $ render (ppTerm Unqualified 0 t')
+        execCheck (inferLType gl main) $ \(t, ty) ->
+          let t' = case t of
+                     Typed _ _ -> t
+                     t         -> Typed t ty
+          in outputStrLn $ render (ppTerm Unqualified 0 t')
       nlrepl st
     
     -- Show the results of the last evaluated expression
@@ -274,8 +273,7 @@ runRepl' opts@ReplOpts { lang, evalToFlat } gl@(Gl g _) = do
         Nothing      -> nlrepl st
 
     doEval st t opts = inferLType gl t >>= \case
-      []          -> fail $ "No result while checking type: " ++ render (ppTerm Unqualified 0 t)
-      ((t', _):_) -> runEvalMWithOpts gl opts (value2termM evalToFlat [] (eval gl [] unit t' []))
+      (t', _) -> runEvalMWithOpts gl opts (value2termM evalToFlat [] (eval gl [] unit t' []))
     
     outputResults rs =
       forM_ (zip [1..] rs) $ \(i, ResultState r _ opts _) ->
diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
index 90ddfa3bd..9fa151701 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -25,12 +25,16 @@ import Data.Bifunctor(second)
 import Data.Functor((<&>))
 import qualified Control.Monad.Fail as Fail
 
-checkLType :: Globals -> Term -> Type -> Check [(Term, Type)]
-checkLType globals t ty = runEvalM globals $
-  do let (c1,c2) = split unit
-     (t,vty) <- checkLType' c1 t (eval globals [] c2 ty [])
-     ty <- value2termM True [] vty
-     return (t,ty)
+checkLType :: Globals -> Term -> Type -> Check (Term, Type)
+checkLType globals t ty = do
+  res <- runEvalM globals $ do
+            let (c1,c2) = split unit
+            (t,vty) <- checkLType' c1 t (eval globals [] c2 ty [])
+            ty <- value2termM True [] vty
+            return (t,ty)
+  case res of
+    [tty] -> return tty
+    _     -> checkError (pp "Encountered variants while type checking")
 
 checkLType' :: Choice -> Term -> Constraint -> EvalM (Term, Constraint)
 checkLType' c t vty = do
@@ -38,11 +42,15 @@ checkLType' c t vty = do
   t <- zonkTerm [] t
   return (t,vty)
 
-inferLType :: Globals -> Term -> Check [(Term, Type)]
-inferLType globals t = runEvalM globals $ do
-  (t,vty) <- inferLType' t
-  ty <- value2termM True [] vty
-  return (t,ty)
+inferLType :: Globals -> Term -> Check (Term, Type)
+inferLType globals t = do
+  res <- runEvalM globals $ do
+            (t,vty) <- inferLType' t
+            ty <- value2termM True [] vty
+            return (t,ty)
+  case res of
+    [tty] -> return tty
+    _     -> checkError (pp "Encountered variants while type checking")
 
 inferLType' :: Term -> EvalM (Term, Constraint)
 inferLType' t = do
@@ -404,7 +412,7 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
                      Nothing -> evalError (pp "[list: .. | ..] requires an argument")
          (t,ty) <- tcRho scope c2 t mb_ty
          case ty of
-           VApp c qid [] -> return (Reset ctl mb_ct t qid, ty)
+           VApp c qid [] -> return (Reset ctl mb_ct t (Just qid), ty)
            _             -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty)
   | otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
 tcRho scope s (Opts n cs) mb_ty = do
diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs
index 0300b19a8..c2ad8660a 100644
--- a/src/compiler/api/GF/Grammar/Grammar.hs
+++ b/src/compiler/api/GF/Grammar/Grammar.hs
@@ -399,7 +399,7 @@ data Term =
  | FV [Term]                     -- ^ alternatives in free variation: @variants { s ; ... }@
 
  | Markup Ident [(Ident,Term)] [Term]
- | Reset Ident (Maybe Term) Term QIdent
+ | Reset Ident (Maybe Term) Term (Maybe QIdent)
 
  | Alts Term [(Term, Term)]      -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
  | Strs [Term]                   -- ^ conditioning prefix strings: @strs {s ; ...}@
diff --git a/src/compiler/api/GF/Grammar/Parser.y b/src/compiler/api/GF/Grammar/Parser.y
index c81724d24..9167e5c1c 100644
--- a/src/compiler/api/GF/Grammar/Parser.y
+++ b/src/compiler/api/GF/Grammar/Parser.y
@@ -487,8 +487,8 @@ Exp6
   | '{' ListLocDef '}'    {% mkR $2 }
   | '<' ListTupleComp '>' { R (tuple2record $2) }
   | '<' Exp ':' Exp '>'   { Typed $2 $4      }
-  | '[' Control '|' Tag ']'      { Reset (fst $2) (snd $2) $4 undefined }
-  | '[' Control '|' Exp ']'      { Reset (fst $2) (snd $2) $4 undefined }
+  | '[' Control '|' Tag ']'      { Reset (fst $2) (snd $2) $4 Nothing }
+  | '[' Control '|' Exp ']'      { Reset (fst $2) (snd $2) $4 Nothing }
   | '(' Exp ')'           { $2 }
 
 ListExp :: { [Term] }

From 68ae919afa9873e0876cb7b97ca6304bb5ad81d3 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sun, 18 May 2025 07:46:56 +0200
Subject: [PATCH 002/144] avoid unnecessary variants

---
 src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
index 9fa151701..c7a929f17 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -501,7 +501,7 @@ resolveOverloads scope c t0 q args mb_ty = do
                       arg_tys <- mapCM (checkArg g) c1 args
                       let v_ttys = mapC (\c (t,ty) -> (t,eval g [] c ty [])) c2 ttys
                       try (\(fun,fun_ty) -> reapply2 scope c3 fun fun_ty arg_tys mb_ty)
-                          (\ttys -> fmap (\(ts,ty) -> (FV ts,ty)) (snd (minimum g ttys)))
+                          (\ttys -> fmap (\(ts,ty) -> (mkFV ts,ty)) (snd (minimum g ttys)))
                           v_ttys
   where
     checkArg g c (ImplArg arg) = do
@@ -515,6 +515,9 @@ resolveOverloads scope c t0 q args mb_ty = do
       let v = eval g (scopeEnv scope) c2 arg []
       return (arg,v,arg_ty)
 
+    mkFV [t] = t
+    mkFV ts  = FV ts
+
     minimum g []                    = (maxBound,err)
       where
         err = evalError (pp "Overload resolution failed")

From 6f9f187c7059967cb3c2a8c61c51c15cbe8827a8 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Mon, 19 May 2025 13:08:54 +0200
Subject: [PATCH 003/144] two hacks for backwards compatibility

---
 src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
index c7a929f17..b0923a6e5 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -782,6 +782,10 @@ subsCheckRho scope t (VTable p1 r1) rho2 = do                 -- Rule TABLE
   subsCheckTbl scope t p1 r1 p2 r2
 subsCheckRho scope t (VSort s1) (VSort s2)                    -- Rule PTYPE
   | s1 == cPType && s2 == cType = return t
+subsCheckRho scope t (VApp _ p1 []) rho2                      -- for backwards compatibility
+  | p1 == (cPredef,cErrorType) = return t
+subsCheckRho scope t (VApp _ p1 _) (VApp _ p2 _)              -- This is not correct but there is in the RGL nextPrec relies on it.
+  | p1 == (cPredef,cInt) && p2 == (cPredef,cInts) = return t  -- Should be only a temporary hack.
 subsCheckRho scope t (VApp _ p1 _) (VApp _ p2 _)              -- Rule INT1
   | p1 == (cPredef,cInts) && p2 == (cPredef,cInt) = return t
 subsCheckRho scope t (VApp _ p1 [VInt i]) (VApp _ p2 [VInt j]) -- Rule INT2

From fd27a2ebd32ea12ebccca9e404c0bc06b25bad87 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 21 May 2025 13:39:03 +0200
Subject: [PATCH 004/144] minimal set of changes to make Bulgarian compile with
 the new typechecker

---
 .../api/GF/Compile/Compute/Concrete2.hs       |  92 +++++-----
 .../api/GF/Compile/TypeCheck/ConcreteNew.hs   | 159 +++++++++---------
 2 files changed, 131 insertions(+), 120 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index d8e24a363..6c2639740 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -65,7 +65,7 @@ data Value
   | VGen  {-# UNPACK #-} !Int [Value]
   | VClosure Env Choice Term
   | VProd BindType Ident Value Value
-  | VRecType [(Label, Value)]
+  | VRecType [(Label, Bool, Value)]
   | VR [(Label, Value)]
   | VP Value Label [Value]
   | VExtR Value Value
@@ -89,10 +89,7 @@ data Value
   | VReset Ident (Maybe Value) Value (Maybe QIdent)
   | VSymCat Int LIndex [(LIndex, (Value, Type))]
   | VError Doc
-    -- These two constructors are only used internally
-    -- in the type checker.
-  | VCRecType [(Label, Bool, Value)]
-  | VCInts (Maybe Integer) (Maybe Integer)
+  | VInts (Maybe Integer) (Maybe Integer)
 
 data Variants
   = VarFree [Value]
@@ -109,7 +106,7 @@ unvariants (VarOpts n cs) = snd <$> cs
 isCanonicalForm :: Bool -> Value -> Bool
 isCanonicalForm flat  (VClosure {})       = True
 isCanonicalForm flat  (VProd b x d cod)   = isCanonicalForm flat d && isCanonicalForm flat cod
-isCanonicalForm flat  (VRecType fs)       = all (isCanonicalForm flat . snd) fs
+isCanonicalForm flat  (VRecType fs)       = all (\(l,_,ty) -> isCanonicalForm flat ty) fs
 isCanonicalForm flat  (VR {})             = True
 isCanonicalForm flat  (VTable d cod)      = isCanonicalForm flat d && isCanonicalForm flat cod
 isCanonicalForm flat  (VT {})             = True
@@ -197,10 +194,13 @@ eval g env s (Abs b x t)    []  = VClosure env s (Abs b x t)
 eval g env s (Abs b x t) (v:vs) = eval g ((x,v):env) s t vs
 eval g env s (Meta i)       vs  = VMeta i vs
 eval g env s (ImplArg t)    []  = eval g env s t []
-eval g env s (Prod b x t1 t2)[] = let (s1,s2) = split s
+eval g env s (Prod b x t1 t2)[]
+  | x == identW                 = let (s1,s2) = split s
+                                  in VProd b x (eval g env s1 t1 []) (eval g env s2 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, eval g env s ty [])) s lbls)
+eval g env s (RecType lbls) []  = VRecType (mapC (\s (lbl,ty) -> (lbl, True, eval g env s ty [])) s lbls)
 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 $$
@@ -214,7 +214,7 @@ eval g env s (P t lbl)      vs  = let project (VR as)        = case lookup lbl a
 eval g env s (ExtR t1 t2)   []  = let (s1,s2) = split s
 
                                       extend (VR       as1) (VR       as2)   = VR       (foldl (\as (lbl,v) -> update lbl v as) as1 as2)
-                                      extend (VRecType as1) (VRecType as2)   = VRecType (foldl (\as (lbl,v) -> update lbl v as) as1 as2)
+                                      extend (VRecType as1) (VRecType as2)   = VRecType (foldl (\as (lbl,o,v) -> update3 lbl o v as) as1 as2)
                                       extend (VFV i fvs)    v2               = VFV i (mapVariants (`extend` v2) fvs)
                                       extend v1             (VFV i fvs)      = VFV i (mapVariants (v1 `extend`) fvs)
                                       extend (VMeta i vs)   v2               = VSusp i (\v -> extend (apply g v vs) v2) []
@@ -391,7 +391,9 @@ bubble v = snd (bubble v)
     bubble (VGen i vs) = liftL (VGen i) vs
     bubble (VClosure env c t) = liftL' (\env -> VClosure env c t) env
     bubble (VProd bt x v1 v2) = lift2 (VProd bt x) v1 v2
-    bubble (VRecType as) = liftL' VRecType as
+    bubble v@(VRecType lbls) =
+      let (union,lbls') = mapAccumL descendR Map.empty lbls
+      in (union, addVariants (VRecType lbls') union)
     bubble (VR as) = liftL' VR as
     bubble (VP v l vs) = lift1L (\v vs -> VP v l vs) v vs
     bubble (VExtR v1 v2) = lift2 VExtR v1 v2
@@ -427,10 +429,7 @@ bubble v = snd (bubble v)
       let (union,vs') = mapAccumL descendC Map.empty vs
       in (union, addVariants (VSymCat d i0 vs') union)
     bubble v@(VError _) = lift0 v
-    bubble v@(VCRecType lbls) =
-      let (union,lbls') = mapAccumL descendR Map.empty lbls
-      in (union, addVariants (VCRecType lbls') union)
-    bubble v@(VCInts _ _) = lift0 v
+    bubble v@(VInts _ _) = lift0 v
 
     lift0 v = (Map.empty, v)
 
@@ -527,6 +526,11 @@ update lbl v (a@(lbl',_):as)
   | lbl==lbl'                = (lbl,v) : as
   | otherwise                = a : update lbl v as
 
+update3 lbl o v []           = [(lbl,o,v)]
+update3 lbl o v (a@(lbl',o',_):as)
+  | lbl==lbl'                = (lbl,o||o',v) : as
+  | otherwise                = a : update3 lbl o v as
+
 patternMatch g s v0 []                      = v0
 patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
   where
@@ -822,23 +826,19 @@ value2termM flat xs (VClosure env s (Abs b x t)) = do
       x' = mkFreshVar xs x
   t <- value2termM flat (x':xs) v
   return (Abs b x' t)
-value2termM flat xs (VProd b x v1 v2)
-  | x == identW = do t1 <- value2termM flat xs v1
-                     v2 <- case v2 of
-                             VClosure env s t2 -> do g <- globals
-                                                     return (eval g env s t2 [])
-                             v2                -> return v2
-                     t2 <- value2termM flat xs v2
-                     return (Prod b x t1 t2)
-  | otherwise   = do t1 <- value2termM flat xs v1
-                     v2 <- case v2 of
-                             VClosure env s t2 -> do g <- globals
-                                                     return (eval g ((x,VGen (length xs) []):env) s t2 [])
-                             v2                -> return v2
-                     t2 <- value2termM flat (x:xs) v2
-                     return (Prod b (mkFreshVar xs x) t1 t2)
+value2termM flat xs (VClosure env s t) = do
+  return t
+value2termM flat xs (VProd b x v1 (VClosure env c2 t2)) = do
+  g <- globals
+  t1 <- value2termM flat xs v1
+  t2 <- value2termM flat (x:xs) (eval g ((x,VGen (length xs) []):env) c2 t2 [])
+  return (Prod b (mkFreshVar xs x) t1 t2)
+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
-  lbls <- mapM (\(lbl,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
+  lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
   return (RecType lbls)
 value2termM flat xs (VR as) = do
   as <- mapM (\(lbl,v) -> fmap (\t -> (lbl,(Nothing,t))) (value2termM flat xs v)) as
@@ -972,12 +972,9 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
     listify mn cat (t1:ts) = do t2 <- listify mn cat ts
                                 return (App (App (QC (mn,identS ("Cons"++cat))) t1) t2)
 value2termM flat xs (VError msg) = evalError msg
-value2termM flat xs (VCRecType lbls) = do
-  lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
-  return (RecType lbls)
-value2termM flat xs (VCInts Nothing    Nothing) = return (App (QC (cPredef,cInts)) (Meta 0))
-value2termM flat xs (VCInts (Just min) Nothing) = return (App (QC (cPredef,cInts)) (EInt min))
-value2termM flat xs (VCInts _       (Just max)) = return (App (QC (cPredef,cInts)) (EInt max))
+value2termM flat xs (VInts Nothing    Nothing) = return (App (QC (cPredef,cInts)) (Meta 0))
+value2termM flat xs (VInts (Just min) Nothing) = return (App (QC (cPredef,cInts)) (EInt min))
+value2termM flat xs (VInts _       (Just max)) = return (App (QC (cPredef,cInts)) (EInt max))
 value2termM flat xs v = evalError ("value2termM" <+> ppValue Unqualified 5 v)
 
 
@@ -999,11 +996,17 @@ ppValue q d (VSusp i k vs) = prec d 4 (hsep (pp "#susp" : (if i > 0 then pp "?"
 ppValue q d (VGen _ _) = pp "VGen"
 ppValue q d (VClosure env c t) = pp "[|" <> ppTerm q 4 t <> pp "|]"
 ppValue q d (VProd _ _ _ _) = pp "VProd"
-ppValue q d (VRecType _) = pp "VRecType"
+ppValue q d (VRecType xs)
+  | 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 <+> (if o then ":" else ":?") <+> ppValue q 0 v | (l,o,v) <- xs]))
 ppValue q d (VR _) = pp "VR"
 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 _ _) = pp "VTable"
+ppValue q d (VTable kt vt) = prec d 0 (ppValue q 3 kt <+> "=>" <+> ppValue q 0 vt)
 ppValue q d (VT t _ _ cs) = "table" <+> ppValue q 0 t <+> '{' $$
                                nest 2 (vcat (punctuate ';' (map (ppCase q) cs))) $$
                             '}'
@@ -1026,13 +1029,12 @@ ppValue q d (VStrs _) = pp "VStrs"
 ppValue q d (VMarkup _ _ _) = pp "VMarkup"
 ppValue q d (VSymCat i r rs) = pp '<' <> pp i <> pp ',' <> pp r <> pp '>'
 ppValue q d (VError msg) = prec d 4 (pp "error" <+> ppTerm q 5 (K (show msg)))
-ppValue q d (VCRecType ass) = pp "VCRecType"
-ppValue q d (VCInts Nothing    Nothing)    = prec d 4 (pp "Ints ?")
-ppValue q d (VCInts (Just min) Nothing)    = prec d 4 (pp "Ints" <+> brackets (pp min <> ".."))
-ppValue q d (VCInts Nothing    (Just max)) = prec d 4 (pp "Ints" <+> brackets (".." <> pp max))
-ppValue q d (VCInts (Just min) (Just max))
-   | min == max                            = prec d 4 (pp "Ints" <+> min)
-   | otherwise                             = prec d 4 (pp "Ints" <+> brackets (pp min <> ".." <> pp max))
+ppValue q d (VInts Nothing    Nothing)    = prec d 4 (pp "Ints ?")
+ppValue q d (VInts (Just min) Nothing)    = prec d 4 (pp "Ints" <+> brackets (pp min <> ".."))
+ppValue q d (VInts Nothing    (Just max)) = prec d 4 (pp "Ints" <+> brackets (".." <> pp max))
+ppValue q d (VInts (Just min) (Just max))
+   | min == max                           = prec d 4 (pp "Ints" <+> min)
+   | otherwise                            = prec d 4 (pp "Ints" <+> brackets (pp min <> ".." <> pp max))
 
 ppAltern q (x,y) = ppValue q 0 x <+> '/' <+> ppValue q 0 y
 
diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
index b0923a6e5..94459ba90 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -118,7 +118,7 @@ tcRho scope c (Abs bt var body) Nothing = do                   -- ABS1
         VClosure env c t -> do g  <- globals
                                check m (n+1) (b,x:xs) (eval g ((x,VGen n []):env) c t [])
         v2               -> check m n st v2
-    check m n st (VRecType as)     = foldM (\st (l,v) -> check m n st v) st as
+    check m n st (VRecType as)     = foldM (\st (l,_,v) -> check m n st v) st as
     check m n st (VR as)           =
       foldM (\st (lbl,tnk) -> check m n st tnk) st as
     check m n st (VP v l vs)       =
@@ -156,13 +156,13 @@ tcRho scope c t@(Abs Implicit var body) (Just ty) = do         -- ABS2
   if bt == Implicit
     then return ()
     else evalError (ppTerm Unqualified 0 t <+> "is an implicit function, but no implicit function is expected")
-  body_ty <- evalCodomain scope x body_ty
+  body_ty <- evalCodomain x (VGen (length scope) []) body_ty
   (body, body_ty) <- tcRho ((var,var_ty):scope) c body (Just body_ty)
   return (Abs Implicit var body,ty)
 tcRho scope c (Abs Explicit var body) (Just ty) = do           -- ABS3
   (scope,f,ty') <- skolemise scope ty
   (_,x,var_ty,body_ty) <- unifyFun scope ty'
-  body_ty <- evalCodomain scope x body_ty
+  body_ty <- evalCodomain x (VGen (length scope) []) body_ty
   (body, body_ty) <- tcRho ((var,var_ty):scope) c body (Just body_ty)
   return (f (Abs Explicit var body),ty)
 tcRho scope c (Meta _) mb_ty = do
@@ -292,7 +292,7 @@ tcRho scope c (R rs) Nothing = do
   lttys <- inferRecFields scope c rs
   rs <- mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
   return (R        rs,
-          VRecType [(l, ty) | (l,t,ty) <- lttys]
+          VRecType [(l,True,ty) | (l,t,ty) <- lttys]
          )
 tcRho scope c (R rs) (Just ty) = do
   (scope,f,ty') <- skolemise scope ty
@@ -300,11 +300,11 @@ tcRho scope c (R rs) (Just ty) = do
     (VRecType ltys) -> do lttys <- checkRecFields scope c rs ltys
                           rs <- mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
                           return ((f . R)  rs,
-                                  VRecType [(l, ty) | (l,t,ty) <- lttys]
+                                  VRecType [(l,True,ty) | (l,t,ty) <- lttys]
                                  )
     ty              -> do lttys <- inferRecFields scope c rs
                           t <- liftM (f . R) (mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys)
-                          let ty' = VRecType [(l, ty) | (l,t,ty) <- lttys]
+                          let ty' = VRecType [(l,True,ty) | (l,t,ty) <- lttys]
                           t <- subsCheckRho scope t ty' ty
                           return (t, ty')
 tcRho scope c (P t l) mb_ty = do
@@ -312,7 +312,7 @@ tcRho scope c (P t l) mb_ty = do
               Just ty -> return ty
               Nothing -> do i <- newResiduation scope
                             return (VMeta i [])
-  (t,t_ty) <- tcRho scope c t (Just (VRecType [(l,l_ty)]))
+  (t,t_ty) <- tcRho scope c t (Just (VRecType [(l,True,l_ty)]))
   return (P t l,l_ty)
 tcRho scope c (C t1 t2) mb_ty = do
   let (c1,c2,c3,c4) = split4 c
@@ -423,11 +423,11 @@ tcRho scope s (Opts n cs) mb_ty = do
   return (Opts n (zip ls ts), ty)
 tcRho scope s t _ = unimplemented ("tcRho "++show t)
 
-evalCodomain :: Scope -> Ident -> Value -> EvalM Value
-evalCodomain scope x (VClosure env c t) = do
+evalCodomain :: Ident -> Value -> Value -> EvalM Value
+evalCodomain x v (VClosure env c ty) = do
   g <- globals
-  return (eval g ((x,VGen (length scope) []):env) c t [])
-evalCodomain scope x t = return t
+  return (eval g ((x,v):env) c ty [])
+evalCodomain x _ ty = return ty
 
 tcUnifying :: Scope -> Choice -> [Term] -> Maybe Rho -> EvalM ([Term], Constraint)
 tcUnifying scope c ts mb_ty = do
@@ -471,20 +471,16 @@ reapply1 scope c fun fun_ty ((ImplArg arg):args) = do -- Implicit arg case
      evalError (ppTerm Unqualified 0 (App fun (ImplArg arg)) <+>
                 "is an implicit argument application, but no implicit argument is expected")
   (arg,_) <- tcRho scope c1 arg (Just arg_ty)
-  res_ty <- case res_ty of
-              VClosure res_env res_c res_ty -> do g <- globals
-                                                  return (eval g ((x,eval g (scopeEnv scope) c2 arg []):res_env) res_c res_ty [])
-              res_ty                        -> return res_ty
+  g <- globals
+  res_ty <- evalCodomain x (eval g (scopeEnv scope) c2 arg []) res_ty
   reapply1 scope c3 (App fun (ImplArg arg)) res_ty args
 reapply1 scope c fun fun_ty (arg:args) = do -- Explicit arg (fallthrough) case
   let (c1,c2,c3,c4) = split4 c
   (fun,fun_ty) <- instantiate scope fun fun_ty
   (_, x, arg_ty, res_ty) <- unifyFun scope fun_ty
   (arg,_) <- tcRho scope c1 arg (Just arg_ty)
-  res_ty <- case res_ty of
-              VClosure res_env res_c res_ty -> do g <- globals
-                                                  return (eval g ((x,eval g (scopeEnv scope) c2 arg []):res_env) res_c res_ty [])
-              res_ty                  -> return res_ty
+  g <- globals
+  res_ty <- evalCodomain x (eval g (scopeEnv scope) c2 arg []) res_ty
   reapply1 scope c3 (App fun arg) res_ty args
 
 resolveOverloads :: Scope -> Choice -> Term -> QIdent -> [Term] -> Maybe Rho -> EvalM (Term,Rho)
@@ -566,19 +562,13 @@ reapply2 scope c fun fun_ty ((ImplArg arg,arg_v,arg_ty):args) mb_ty = do -- Impl
      evalError (ppTerm Unqualified 0 (App fun (ImplArg arg)) <+>
                 "is an implicit argument application, but no implicit argument is expected")
   arg <- subsCheckRho scope arg arg_ty' arg_ty
-  res_ty <- case res_ty of
-              VClosure res_env res_c res_ty -> do g <- globals
-                                                  return (eval g ((x,arg_v):res_env) res_c res_ty [])
-              res_ty                        -> return res_ty
+  res_ty <- evalCodomain x arg_v res_ty
   reapply2 scope c (App fun (ImplArg arg)) res_ty args mb_ty
 reapply2 scope c fun fun_ty ((arg,arg_v,arg_ty):args) mb_ty = do -- Explicit arg (fallthrough) case
   (fun,fun_ty) <- instantiate scope fun fun_ty
   (_, x, arg_ty', res_ty) <- unifyFun scope fun_ty
   arg <- subsCheckRho scope arg arg_ty arg_ty'
-  res_ty <- case res_ty of
-              VClosure res_env res_c res_ty -> do g <- globals
-                                                  return (eval g ((x,arg_v):res_env) res_c res_ty [])
-              res_ty                  -> return res_ty
+  res_ty <- evalCodomain x arg_v res_ty
   reapply2 scope c (App fun arg) res_ty args mb_ty
 
 tcPatt scope c PW        ty0 =
@@ -600,7 +590,7 @@ tcPatt scope c (PP q ps) ty0 = do
   unify scope ty0 ty
   return scope
 tcPatt scope c (PInt i) ty0 = do
-  unify scope (vtypeInts i) ty0
+  subsCheckRho scope (EInt i) (vtypeInts i) ty0
   return scope
 tcPatt scope c (PString s) ty0 = do
   unify scope ty0 vtypeStr
@@ -608,12 +598,18 @@ tcPatt scope c (PString s) ty0 = do
 tcPatt scope c PChar ty0 = do
   unify scope ty0 vtypeStr
   return scope
+tcPatt scope c (PChars cs) ty0 = do
+  unify scope ty0 vtypeStr
+  return scope
 tcPatt scope c (PSeq _ _ p1 _ _ p2) ty0 = do
   unify scope ty0 vtypeStr
   let (c1,c2) = split c
   scope <- tcPatt scope c1 p1 vtypeStr
   scope <- tcPatt scope c2 p2 vtypeStr
   return scope
+tcPatt scope c (PRep _ _ p) ty0 = do
+  unify scope ty0 vtypeStr
+  tcPatt scope c p vtypeStr
 tcPatt scope c (PAs x p) ty0 = do
   tcPatt ((x,ty0):scope) c p ty0
 tcPatt scope c (PR rs) ty0 = do
@@ -626,7 +622,7 @@ tcPatt scope c (PR rs) ty0 = do
                                     scope <- tcPatt scope c1 p ty
                                     go scope c2 rs
   ltys <- mk_ltys rs
-  subsCheckRho scope (EPatt 0 Nothing (PR rs)) (VRecType [(l,ty) | (l,p,ty) <- ltys]) ty0
+  subsCheckRho scope (EPatt 0 Nothing (PR rs)) (VRecType [(l,True,ty) | (l,p,ty) <- ltys]) ty0
   go scope c ltys
 tcPatt scope c (PAlt p1 p2) ty0 = do
   let (c1,c2) = split c
@@ -650,7 +646,7 @@ inferRecFields scope c rs =
 
 checkRecFields scope c []          ltys
   | null ltys                            = return []
-  | otherwise                            = evalError ("Missing fields:" <+> hsep (map fst ltys))
+  | otherwise                            = evalError ("Missing fields:" <+> hsep [l | (l,_,_) <- ltys])
 checkRecFields scope c ((l,t):lts) ltys =
   case takeIt l ltys of
     (Just ty,ltys) -> do let (c1,c2) = split c
@@ -664,7 +660,7 @@ checkRecFields scope c ((l,t):lts) ltys =
                          return lttys     -- ignore the field
   where
     takeIt l1 []  = (Nothing, [])
-    takeIt l1 (lty@(l2,ty):ltys)
+    takeIt l1 (lty@(l2,_,ty):ltys)
       | l1 == l2  = (Just ty,ltys)
       | otherwise = let (mb_ty,ltys') = takeIt l1 ltys
                     in (mb_ty,lty:ltys')
@@ -765,7 +761,7 @@ subsCheckRho scope t (VProd Implicit x ty1 ty2) rho2 = do     -- Rule SPEC
   subsCheckRho scope (App t (ImplArg (Meta i))) ty2' rho2
 subsCheckRho scope t rho1 (VProd Implicit x ty1 ty2) = do     -- Rule SKOL
   let v = newVar scope
-  ty2 <- evalCodomain scope x ty2
+  ty2 <- evalCodomain x (VGen (length scope) []) ty2
   t <- subsCheckRho ((v,ty1):scope) t rho1 ty2
   return (Abs Implicit v t)
 subsCheckRho scope t rho1 (VProd Explicit _ a2 r2) = do       -- Rule FUN
@@ -802,14 +798,14 @@ subsCheckRho scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do      -- Rule REC
                                   ,\l -> mkProj2 l `mplus` mkProj1 l
                                   ,mkWrap1 . mkWrap2
                                   )
-          R rs -> do sequence_ [evalWarn ("Discarded field:" <+> l) | (l,_) <- rs, isNothing (lookup l rs2)]
+          R rs -> do sequence_ [evalWarn ("Discarded field:" <+> l) | (l,_) <- rs, isNothing (lookup3 l rs2)]
                      return (scope
                             ,\l -> lookup l rs
                             ,id
                             )
           Vr x -> do return (scope
                             ,\l -> do VRecType rs <- lookup x scope
-                                      ty <- lookup l rs
+                                      ty <- lookup3 l rs
                                       return (Nothing,P t l)
                             ,id
                             )
@@ -823,9 +819,14 @@ subsCheckRho scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do      -- Rule REC
         t <- subsCheckRho scope t ty1 ty2
         return (l, (mb_ty,t))
 
+      lookup3 l []  = Nothing
+      lookup3 l ((l',_,v):rs)
+        | l == l'   = Just v
+        | otherwise = lookup3 l rs
+
   (scope,mkProj,mkWrap) <- mkAccess scope t
 
-  let fields = [(l,ty2,lookup l rs1) | (l,ty2) <- rs2]
+  let fields = [(l,ty2,lookup3 l rs1) | (l,o2,ty2) <- rs2]
   case [l | (l,_,Nothing) <- fields] of
     []      -> return ()
     missing -> evalError ("In the term" <+> pp t $$
@@ -859,31 +860,35 @@ subsCheckFun scope t a1 r1 a2 r2 = do
 subsCheckTbl :: Scope -> Term -> Sigma -> Rho -> Sigma -> Rho  -> EvalM Term
 subsCheckTbl scope t p1 r1 p2 r2 = do
   let x = newVar scope
-  xt <- subsCheckRho scope (Vr x) p2 p1
-  t  <- subsCheckRho ((x,vtypePType):scope) (S t xt) r1 r2
+  xt <- subsCheckRho ((x,p2):scope) (Vr x) p2 p1
+  t  <- subsCheckRho ((x,p2):scope) (S t xt) r1 r2
   p2 <- value2termM True (scopeVars scope) p2
   return (T (TTyped p2) [(PV x,t)])
 
 subtype scope Nothing (VApp c p [VInt i])
   | p == (cPredef,cInts) = do
-      return (VCInts Nothing (Just i))
-subtype scope (Just (VCInts i j)) (VApp c p [VInt k])
+      return (VInts Nothing (Just i))
+subtype scope (Just (VInts i j)) (VApp c p [VInt k])
   | p == (cPredef,cInts) = do
-      return (VCInts j (Just (maybe k (min k) i)))
+      return (VInts j (Just (maybe k (min k) i)))
 subtype scope Nothing (VRecType ltys) = do
-  lctrs <- mapM (\(l,ty) -> supertype scope Nothing ty >>= \ctr -> return (l,True,ctr)) ltys
-  return (VCRecType lctrs)
-subtype scope (Just (VCRecType lctrs)) (VRecType ltys) = do
-  lctrs <- foldM (\lctrs (l,ty) -> union l ty lctrs) lctrs ltys
-  return (VCRecType lctrs)
+  lctrs <- mapM (\(l,o,ty) -> subtype scope Nothing ty >>= \ctr -> return (l,o,ctr)) ltys
+  return (VRecType lctrs)
+subtype scope (Just (VRecType lctrs1)) (VRecType lctrs2) = do
+  lctrs <- foldM (\lctrs (l,o,ctr) -> union l o ctr lctrs) lctrs1 lctrs2
+  return (VRecType lctrs)
   where
-    union l ty [] = do ctr <- subtype scope Nothing ty
-                       return [(l,True,ctr)]
-    union l ty ((l',o,ctr):lctrs)
-      | l == l'   = do ctr <- subtype scope (Just ctr) ty
-                       return ((l,True,ctr):lctrs)
-      | otherwise = do lctrs <- union l ty lctrs
-                       return ((l',o,ctr):lctrs)
+    union l o1 ctr1 [] = do ctr <- subtype scope Nothing ctr1
+                            return [(l,True,ctr)]
+    union l o1 ctr1 ((l',o2,ctr2):lctrs)
+      | l == l'   = do ctr <- subtype scope (Just ctr1) ctr2
+                       return ((l,o1||o2,ctr):lctrs)
+      | otherwise = do lctrs <- union l o1 ctr1 lctrs
+                       return ((l',o2,ctr2):lctrs)
+subtype scope (Just (VTable a1 r1)) (VTable a2 r2) = do
+  a <- supertype scope (Just a1) a2
+  r <- subtype scope (Just r1) r2
+  return (VTable a r)
 subtype scope Nothing    ty = return ty
 subtype scope (Just ctr) ty = do
   unify scope ctr ty
@@ -891,22 +896,26 @@ subtype scope (Just ctr) ty = do
 
 supertype scope Nothing (VApp c p [VInt i])
   | p == (cPredef,cInts) = do
-      return (VCInts (Just i) Nothing)
-supertype scope (Just (VCInts i j)) (VApp c p [VInt k])
+      return (VInts (Just i) Nothing)
+supertype scope (Just (VInts i j)) (VApp c p [VInt k])
   | p == (cPredef,cInts) = do
-      return (VCInts (Just (maybe k (max k) i)) j)
+      return (VInts (Just (maybe k (max k) i)) j)
 supertype scope Nothing (VRecType ltys) = do
-  lctrs <- mapM (\(l,ty) -> supertype scope Nothing ty >>= \ctr -> return (l,False,ctr)) ltys
-  return (VCRecType lctrs)
-supertype scope (Just (VCRecType lctrs)) (VRecType ltys) = do
-  lctrs <- foldM (\lctrs (l,o,ctr) -> intersect l o ctr lctrs ltys) [] lctrs
-  return (VCRecType lctrs)
+  lctrs <- mapM (\(l,o,ty) -> supertype scope Nothing ty >>= \ctr -> return (l,False,ctr)) ltys
+  return (VRecType lctrs)
+supertype scope (Just (VRecType lctrs1)) (VRecType lctrs2) = do
+  lctrs <- foldM (\lctrs (l,o,ctr) -> intersect l o ctr lctrs lctrs2) [] lctrs1
+  return (VRecType lctrs)
   where
-    intersect l o ctr lctrs [] = return lctrs
-    intersect l o ctr lctrs ((l',ty):ltys2)
-      | l == l'   = do ctr <- supertype scope (Just ctr) ty
-                       return ((l,o,ctr):lctrs)
-      | otherwise = do intersect l o ctr lctrs ltys2
+    intersect l o1 ctr1 lctrs [] = return lctrs
+    intersect l o1 ctr1 lctrs ((l',o2,ctr2):lctrs2)
+      | l == l'   = do ctr <- supertype scope (Just ctr1) ctr2
+                       return ((l,o1 && o2,ctr):lctrs)
+      | otherwise = do intersect l o1 ctr1 lctrs lctrs2
+supertype scope (Just (VTable a1 r1)) (VTable a2 r2) = do
+  a <- subtype scope (Just a1) a2
+  r <- supertype scope (Just r1) r2
+  return (VTable a r)
 supertype scope Nothing    ty = return ty
 supertype scope (Just ctr) ty = do
   unify scope ctr ty
@@ -974,8 +983,8 @@ unify scope (VGen i vs1)       (VGen j vs2)
 unify scope (VProd b x d cod) (VProd b' x' d' cod')
   | b == b'                    = do
       unify scope d d'
-      cod <- evalCodomain scope x cod
-      cod' <- evalCodomain scope x' cod'
+      cod  <- evalCodomain x  (VGen (length scope) []) cod
+      cod' <- evalCodomain x' (VGen (length scope) []) cod'
       unify scope cod cod'
 unify scope (VTable p1 res1) (VTable p2 res2) = do
   unify scope p2   p1
@@ -992,8 +1001,8 @@ unify scope VEmpty VEmpty      = return ()
 unify scope v1 v2 = do
   t1 <- value2termM False (scopeVars scope) v1
   t2 <- value2termM False (scopeVars scope) v2
-  evalError ("Cannot unify terms:" <+> (ppTerm Unqualified 0 t1 $$
-                                        ppTerm Unqualified 0 t2))
+  evalError ("Cannot unify:" <+> show t1 $$
+             "        with:" <+> show t2)
 
 
 -- | Invariant: tv1 is a flexible type variable
@@ -1037,7 +1046,7 @@ occursCheck scope' i0 scope v =
                                check (m+1) (n+1) (eval g ((x,VGen n []):env) c t [])
         _                -> check m n ty2
     check m n (VRecType as) =
-      mapM_ (\(lbl,v) -> check m n v) as
+      mapM_ (\(_,_,v) -> check m n v) as
     check m n (VR as) =
       mapM_ (\(lbl,v) -> check m n v) as
     check m n (VP v l vs) =
@@ -1070,6 +1079,7 @@ occursCheck scope' i0 scope v =
       check m n v >> mapM_ (\(v1,v2) -> check m n v1 >> check m n v2) vs
     check m n (VStrs vs) =
       mapM_ (check m n) vs
+    check m n (VInts _ _) = return ()
 
 -----------------------------------------------------------------------
 -- Instantiation and quantification
@@ -1101,7 +1111,7 @@ skolemise scope ty@(VMeta i vs) = do
                           skolemise scope (apply g ty vs)
 skolemise scope (VProd Implicit x ty1 ty2) = do
   let v = newVar scope
-  ty2 <- evalCodomain scope x ty2
+  ty2 <- evalCodomain x (VGen (length scope) []) ty2
   (scope,f,ty2) <- skolemise ((v,ty1):scope) ty2
   return (scope,Abs Implicit v . f,ty2)
 skolemise scope ty = do
@@ -1144,7 +1154,7 @@ quantify scope t tvs ty = do
         v2               -> do (xs,v2) <- check m (n+1) xs v2
                                return (x:xs,VProd bt x v1 v2)
     check m n xs (VRecType as)     = do
-      (xs,as) <- mapAccumM (\xs (l,v) -> check m n xs v >>= \(xs,v) -> return (xs,(l,v))) xs as
+      (xs,as) <- mapAccumM (\xs (l,o,v) -> check m n xs v >>= \(xs,v) -> return (xs,(l,o,v))) xs as
       return (xs,VRecType as)
     check m n xs (VR as)           = do
       (xs,as) <- mapAccumM (\xs (lbl,tnk) -> check m n xs tnk >>= \(xs,tnk) -> return (xs,(lbl,tnk))) xs as
@@ -1251,7 +1261,7 @@ getMetaVars sc_tys = foldM (\acc (scope,ty) -> go acc ty) [] sc_tys
     go acc (VGen i args)     = foldM go acc args
     go acc (VSort s)         = return acc
     go acc (VInt _)          = return acc
-    go acc (VRecType as)     = foldM (\acc (lbl,v) -> go acc v) acc as
+    go acc (VRecType vs)    = foldM (\acc (lbl,_,v) -> go acc v) acc vs
     go acc (VClosure _ _ _)  = return acc
     go acc (VProd b x v1 v2) = go acc v2 >>= \acc -> go acc v1
     go acc (VTable v1 v2)    = go acc v2 >>= \acc -> go acc v1
@@ -1265,8 +1275,7 @@ getMetaVars sc_tys = foldM (\acc (scope,ty) -> go acc ty) [] sc_tys
                                     _                      -> return acc
     go acc (VApp c f args)   = foldM go acc args
     go acc (VFV c vs)        = foldM go acc (unvariants vs)
-    go acc (VCRecType vs)    = foldM (\acc (lbl,b,v) -> go acc v) acc vs
-    go acc (VCInts _ _)      = return acc
+    go acc (VInts _ _)      = return acc
     go acc v                 = unimplemented ("go "++show (ppValue Unqualified 5 v))
 
 -- | Eliminate any substitutions in a term

From 8b93f80c52d32c942a4f4a173cc47306c5049d20 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 21 May 2025 13:56:19 +0200
Subject: [PATCH 005/144] don't typecheck record fields that are going to be
 discarded

---
 src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
index 94459ba90..fefbe2494 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -654,9 +654,7 @@ checkRecFields scope c ((l,t):lts) ltys =
                          lttys <- checkRecFields scope c2 lts ltys
                          return (ltty : lttys)
     (Nothing,ltys) -> do evalWarn ("Discarded field:" <+> l)
-                         let (c1,c2) = split c
-                         ltty  <- tcRecField scope c1 l t Nothing
-                         lttys <- checkRecFields scope c2 lts ltys
+                         lttys <- checkRecFields scope c lts ltys
                          return lttys     -- ignore the field
   where
     takeIt l1 []  = (Nothing, [])

From 6f8654716e58f9fc90d4bda44531b86d422fe994 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 21 May 2025 13:56:45 +0200
Subject: [PATCH 006/144] ignore the lock field when checking for subsumption

---
 src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
index fefbe2494..0a9be411f 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -825,7 +825,7 @@ subsCheckRho scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do      -- Rule REC
   (scope,mkProj,mkWrap) <- mkAccess scope t
 
   let fields = [(l,ty2,lookup3 l rs1) | (l,o2,ty2) <- rs2]
-  case [l | (l,_,Nothing) <- fields] of
+  case [l | (l,_,Nothing) <- fields, not (isLockLabel l)] of
     []      -> return ()
     missing -> evalError ("In the term" <+> pp t $$
                           "there are no values for fields:" <+> hsep missing)

From 548e4c8549328fb429e4046c0183993a374b89f3 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 21 May 2025 14:32:53 +0200
Subject: [PATCH 007/144] more updates for typechecking the RGL

---
 src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs | 12 ++++++++----
 1 file changed, 8 insertions(+), 4 deletions(-)

diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
index 0a9be411f..df9df7f76 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -551,7 +551,7 @@ resolveOverloads scope c t0 q args mb_ty = do
         join t ty state res = do
           t <- withState state (zonkTerm [] t)
           (ts,ty') <- res
-          unify scope ty ty'
+          ty <- supertype scope (Just ty) ty'
           return (t:ts,ty)
 
 reapply2 :: Scope -> Choice -> Term -> Value -> [(Term,Value,Value)] -> Maybe Rho -> EvalM (Term,Rho)
@@ -830,7 +830,7 @@ subsCheckRho scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do      -- Rule REC
     missing -> evalError ("In the term" <+> pp t $$
                           "there are no values for fields:" <+> hsep missing)
   rs <- sequence [mkField scope l t ty1 ty2 | (l,ty2,Just ty1) <- fields, Just t <- [mkProj l]]
-  return (mkWrap (R rs))
+  return (mkWrap (R (rs++[(l, (Just (RecType []),R [])) | (l,_,Nothing) <- fields, isLockLabel l])))
 subsCheckRho scope t tau1 (VFV c (VarFree vs)) = do
   tau2 <- variants c vs
   subsCheckRho scope t tau1 tau2
@@ -914,6 +914,10 @@ supertype scope (Just (VTable a1 r1)) (VTable a2 r2) = do
   a <- subtype scope (Just a1) a2
   r <- supertype scope (Just r1) r2
   return (VTable a r)
+supertype scope (Just (VProd _ _ a1 r1)) (VProd _ _ a2 r2) = do
+  a <- subtype scope (Just a1) a2
+  r <- supertype scope (Just r1) r2
+  return (VProd Explicit identW a r)
 supertype scope Nothing    ty = return ty
 supertype scope (Just ctr) ty = do
   unify scope ctr ty
@@ -999,8 +1003,8 @@ unify scope VEmpty VEmpty      = return ()
 unify scope v1 v2 = do
   t1 <- value2termM False (scopeVars scope) v1
   t2 <- value2termM False (scopeVars scope) v2
-  evalError ("Cannot unify:" <+> show t1 $$
-             "        with:" <+> show t2)
+  evalError ("Cannot unify:" <+> ppTerm Terse 0 t1 $$
+             "        with:" <+> ppTerm Terse 0 t2)
 
 
 -- | Invariant: tv1 is a flexible type variable

From 054ebf066a2905c64a4bc2f86b4f6edb8ece7bc6 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 21 May 2025 14:35:55 +0200
Subject: [PATCH 008/144] more precise subtype/supertype for nondependent
 functions

---
 .../api/GF/Compile/TypeCheck/ConcreteNew.hs        | 14 ++++++++++----
 1 file changed, 10 insertions(+), 4 deletions(-)

diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
index df9df7f76..9a0452ac1 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -887,6 +887,11 @@ subtype scope (Just (VTable a1 r1)) (VTable a2 r2) = do
   a <- supertype scope (Just a1) a2
   r <- subtype scope (Just r1) r2
   return (VTable a r)
+subtype scope (Just (VProd Explicit x a1 r1)) (VProd Explicit y a2 r2)
+  | x == identW && y == identW = do
+       a <- supertype scope (Just a1) a2
+       r <- subtype scope (Just r1) r2
+       return (VProd Explicit identW a r)
 subtype scope Nothing    ty = return ty
 subtype scope (Just ctr) ty = do
   unify scope ctr ty
@@ -914,10 +919,11 @@ supertype scope (Just (VTable a1 r1)) (VTable a2 r2) = do
   a <- subtype scope (Just a1) a2
   r <- supertype scope (Just r1) r2
   return (VTable a r)
-supertype scope (Just (VProd _ _ a1 r1)) (VProd _ _ a2 r2) = do
-  a <- subtype scope (Just a1) a2
-  r <- supertype scope (Just r1) r2
-  return (VProd Explicit identW a r)
+supertype scope (Just (VProd Explicit x a1 r1)) (VProd Explicit y a2 r2)
+  | x == identW && y == identW = do
+       a <- subtype scope (Just a1) a2
+       r <- supertype scope (Just r1) r2
+       return (VProd Explicit identW a r)
 supertype scope Nothing    ty = return ty
 supertype scope (Just ctr) ty = do
   unify scope ctr ty

From c61315465d0ce247ddc51e8f78afacaef783d203 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 21 May 2025 14:55:13 +0200
Subject: [PATCH 009/144] ditch the old typechecker completely

---
 src/compiler/api/GF/Command/SourceCommands.hs |    2 +-
 src/compiler/api/GF/Compile/CheckGrammar.hs   |    5 +-
 src/compiler/api/GF/Compile/Repl.hs           |    2 +-
 .../api/GF/Compile/TypeCheck/Concrete.hs      | 2098 ++++++++++-------
 .../api/GF/Compile/TypeCheck/ConcreteNew.hs   | 1309 ----------
 src/compiler/api/GF/Interactive.hs            |   11 +-
 src/compiler/api/GF/Term.hs                   |    2 +-
 src/compiler/gf.cabal                         |    1 -
 8 files changed, 1294 insertions(+), 2136 deletions(-)
 delete mode 100644 src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs

diff --git a/src/compiler/api/GF/Command/SourceCommands.hs b/src/compiler/api/GF/Command/SourceCommands.hs
index 2ef833a5c..33badb3ea 100644
--- a/src/compiler/api/GF/Command/SourceCommands.hs
+++ b/src/compiler/api/GF/Command/SourceCommands.hs
@@ -20,7 +20,7 @@ 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.TypeCheck.ConcreteNew as TC(inferLType)
+import GF.Compile.TypeCheck.Concrete as TC(inferLType)
 
 import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
 import GF.Command.CommandInfo
diff --git a/src/compiler/api/GF/Compile/CheckGrammar.hs b/src/compiler/api/GF/Compile/CheckGrammar.hs
index 9003a3485..b366b55d6 100644
--- a/src/compiler/api/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/api/GF/Compile/CheckGrammar.hs
@@ -27,8 +27,7 @@ import GF.Infra.Ident
 import GF.Infra.Option
 
 import GF.Compile.TypeCheck.Abstract
-import GF.Compile.TypeCheck.Concrete(ppType)
-import GF.Compile.TypeCheck.ConcreteNew(checkLType,inferLType)
+import GF.Compile.TypeCheck.Concrete(checkLType,inferLType)
 import GF.Compile.Compute.Concrete2(normalForm,Globals(..),stdPredef)
 
 import GF.Grammar
@@ -265,7 +264,7 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
    checkUniq xss = case xss of
      x:y:xs
       | x == y    -> checkError $ "ambiguous for type" <+>
-                                  ppType (mkFunType (tail x) (head x))
+                                  ppTerm Terse 0 (mkFunType (tail x) (head x))
       | otherwise -> checkUniq $ y:xs
      _ -> return ()
 
diff --git a/src/compiler/api/GF/Compile/Repl.hs b/src/compiler/api/GF/Compile/Repl.hs
index fd06bb8cd..7c952cd9e 100644
--- a/src/compiler/api/GF/Compile/Repl.hs
+++ b/src/compiler/api/GF/Compile/Repl.hs
@@ -32,7 +32,7 @@ import GF.Compile.Compute.Concrete2
   , ppValue
   )
 import GF.Compile.Rename (renameSourceTerm)
-import GF.Compile.TypeCheck.ConcreteNew (inferLType)
+import GF.Compile.TypeCheck.Concrete (inferLType)
 import GF.Data.ErrM (Err(..))
 import GF.Data.Utilities (maybeAt, orLeft)
 import GF.Grammar.Grammar
diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index 9c2f88443..ce9ea1add 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -1,843 +1,1309 @@
-{-# LANGUAGE PatternGuards #-}
-module GF.Compile.TypeCheck.Concrete( checkLType, inferLType, computeLType, ppType ) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+{-# LANGUAGE RankNTypes, CPP, TupleSections, LambdaCase #-}
+module GF.Compile.TypeCheck.Concrete ( checkLType, checkLType', inferLType, inferLType' ) where
 
-import GF.Infra.CheckM
-import GF.Data.Operations
+-- The code here is based on the paper:
+-- Simon Peyton Jones, Dimitrios Vytiniotis, Stephanie Weirich.
+-- Practical type inference for arbitrary-rank types.
+-- 14 September 2011
 
-import GF.Grammar
+import GF.Grammar hiding (Env, VGen, VApp, VRecType, ppValue)
 import GF.Grammar.Lookup
 import GF.Grammar.Predef
-import GF.Grammar.PatternMatch
-import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord)
-import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef)
-
-import Data.List
-import Data.Maybe(fromMaybe,isJust,isNothing)
-import Control.Monad
+import GF.Grammar.Lockfield
+import GF.Compile.Compute.Concrete2
+import GF.Infra.CheckM
+import GF.Data.ErrM ( Err(Ok, Bad) )
+import Control.Applicative(Applicative(..))
+import Control.Monad(ap,liftM,mplus,foldM,zipWithM,forM,filterM,unless)
+import Control.Monad.ST
 import GF.Text.Pretty
-
-computeLType :: SourceGrammar -> Context -> Type -> Check Type
-computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
- where
-  comp g ty = case ty of
-    _ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
-      | isPredefConstant ty     -> return ty ---- shouldn't be needed
-
-    Q (m,ident) -> checkIn ("module" <+> m) $ do
-      ty' <- lookupResDef gr (m,ident)
-      if ty' == ty then return ty else comp g ty' --- is this necessary to test?
-
-    AdHocOverload ts -> do
-     over <- getOverload gr g (Just typeType) t
-     case over of
-       Just (tr,_) -> return tr
-       _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 t)
-
-    Vr ident  -> checkLookup ident g -- never needed to compute!
-
-    App f a -> do
-      f' <- comp g f
-      a' <- comp g a
-      case f' of
-        Abs b x t -> comp ((b,x,a'):g) t
-        _ -> return $ App f' a'
-
-    Prod bt x a b -> do
-      a' <- comp g a
-      b' <- comp ((bt,x,Vr x) : g) b
-      return $ Prod bt x a' b'
-
-    Abs bt x b -> do
-      b' <- comp ((bt,x,Vr x):g) b
-      return $ Abs bt x b'
-
-    Let (x,(_,a)) b -> comp ((Explicit,x,a):g) b
-
-    ExtR r s -> do
-      r' <- comp g r
-      s' <- comp g s
-      case (r',s') of
-        (RecType rs, RecType ss) -> plusRecType r' s' >>= comp g
-        _ -> return $ ExtR r' s'
-
-    RecType fs -> do
-      let fs' = sortRec fs
-      liftM RecType $ mapPairsM (comp g) fs'
-
-    ELincat c t -> do
-      t' <- comp g t
-      lockRecType c t' ---- locking to be removed AR 20/6/2009
-
-    _ | ty == typeTok -> return typeStr
-
-    _ -> composOp (comp g) ty
-
--- the underlying algorithms
-
-inferLType :: SourceGrammar -> Context -> Term -> Check (Term, Type)
-inferLType gr g trm = case trm of
-
-   Q ident -> checks [
-     termWith trm $ lookupResType gr ident >>= computeLType gr g
-     ,
-     lookupResDef gr ident >>= inferLType gr g
-     ,
-     checkError ("cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
-     ]
-
-   QC ident -> checks [
-       termWith trm $ lookupResType gr ident >>= computeLType gr g
-       ,
-       lookupResDef gr ident >>= inferLType gr g
-       ,
-       checkError ("cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
-       ]
-
-   Vr ident -> termWith trm $ checkLookup ident g
-
-   Typed e t -> do
-     t' <- computeLType gr g t
-     checkLType gr g e t'
-
-   AdHocOverload ts -> do
-     over <- getOverload gr g Nothing trm
-     case over of
-       Just trty -> return trty
-       _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
-
-   App f a -> do
-     over <- getOverload gr g Nothing trm
-     case over of
-       Just trty -> return trty
-       _ -> do
-         (f',fty) <- inferLType gr g f
-         fty' <- computeLType gr g fty
-         case fty' of
-           Prod bt z arg val -> do
-             a' <- justCheck g a arg
-             ty <- if z == identW
-                      then return val
-                      else substituteLType [(bt,z,a')] val
-             return (App f' a',ty)
-           _ ->
-             let term = ppTerm Unqualified 0 f
-                 funName = pp . head . words .render $ term
-              in checkError ("A function type is expected for" <+> term <+> "instead of type" <+> ppType fty $$
-                             "\n   ** Maybe you gave too many arguments to" <+> funName <+> "\n")
-
-   S f x -> do
-     (f', fty) <- inferLType gr g f
-     case fty of
-       Table arg val -> do
-         x'<- justCheck g x arg
-         return (S f' x', val)
-       _ -> checkError ("table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
-
-   P t i -> do
-     (t',ty) <- inferLType gr g t   --- ??
-     ty' <- computeLType gr g ty
-     let tr2 = P t' i
-     termWith tr2 $ case ty' of
-       RecType ts -> case lookup i ts of
-                       Nothing -> checkError ("unknown label" <+> i <+> "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
-                       Just x  -> return x
-       _          -> checkError ("record type expected for:" <+> ppTerm Unqualified 0 t $$
-                                 " instead of the inferred:" <+> ppTerm Unqualified 0 ty')
-
-   R r -> do
-     let (ls,fs) = unzip r
-     fsts <- mapM inferM fs
-     let ts = [ty | (Just ty,_) <- fsts]
-     checkCond ("cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
-     return $ (R (zip ls fsts), RecType (zip ls ts))
-
-   T (TTyped arg) pts -> do
-     (_,val) <- checks $ map (inferCase (Just arg)) pts
-     checkLType gr g trm (Table arg val)
-   T (TComp arg) pts -> do
-     (_,val) <- checks $ map (inferCase (Just arg)) pts
-     checkLType gr g trm (Table arg val)
-   T ti pts -> do  -- tries to guess: good in oper type inference
-     let pts' = [pt | pt@(p,_) <- pts, isConstPatt p]
-     case pts' of
-       [] -> checkError ("cannot infer table type of" <+> ppTerm Unqualified 0 trm)
-----       PInt k : _ -> return $ Ints $ max [i | PInt i <- pts']
-       _  -> do
-         (arg,val) <- checks $ map (inferCase Nothing) pts'
-         checkLType gr g trm (Table arg val)
-   V arg pts -> do
-     (_,val) <- checks $ map (inferLType gr g) pts
---   return (trm, Table arg val) -- old, caused issue 68
-     checkLType gr g trm (Table arg val)
-
-   K s  ->
-     let trm' = case words s of
-                  []     -> Empty
-                  [w]    -> K w
-                  (w:ws) -> foldl (\t -> C t . K) (K w) ws
-     in return (trm', typeStr)
-
-   EInt i -> return (trm, typeInt)
-
-   EFloat i -> return (trm, typeFloat)
-
-   Empty -> return (trm, typeStr)
-
-   C s1 s2 ->
-     check2 (flip (justCheck g) typeStr) C s1 s2 typeStr
-
-   Glue s1 s2 ->
-     check2 (flip (justCheck g) typeStr) Glue s1 s2 typeStr ---- typeTok
-
----- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
-   Strs (Cn c : ts) | c == cConflict -> do
-     checkWarn ("unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
-     inferLType gr g (head ts)
-
-   Strs ts -> do
-     ts' <- mapM (\t -> justCheck g t typeStr) ts
-     return (Strs ts', typeStrs)
-
-   Alts t aa -> do
-     t'  <- justCheck g t typeStr
-     aa' <- flip mapM aa (\ (c,v) -> do
-        c' <- justCheck g c typeStr
-        v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr]
-        v' <- case v' of
-                Q q -> do t <- lookupResDef gr q
-                          t <- normalForm (Gl gr stdPredef) t
-                          case t of
-                            EPatt _ _ p -> mkStrs p
-                            _           -> return v'
-                _   -> return v'
-        return (c',v'))
-     return (Alts t' aa', typeStr)
-
-   RecType r -> do
-     let (ls,ts) = unzip r
-     ts' <- mapM (flip (justCheck g) typeType) ts
-     return (RecType (zip ls ts'), typeType)
-
-   ExtR r s -> do
-     (r',rT) <- inferLType gr g r
-     rT'     <- computeLType gr g rT
-
-     (s',sT) <- inferLType gr g s
-     sT'     <- computeLType gr g sT
-
-     let trm' = ExtR r' s'
-     case (rT', sT') of
-       (RecType rs, RecType ss) -> do
-         let rt = RecType ([field | field@(l,_) <- rs, notElem l (map fst ss)] ++ ss) -- select types of later fields
-         checkLType gr g trm' rt ---- return (trm', rt)
-       _ | rT' == typeType && sT' == typeType -> do
-         return (trm', typeType)
-       _ -> checkError ("records or record types expected in" <+> ppTerm Unqualified 0 trm)
-
-   Sort _     ->
-     termWith trm $ return typeType
-
-   Prod bt x a b -> do
-     a' <- justCheck g a typeType
-     b' <- justCheck ((bt,x,a'):g) b typeType
-     return (Prod bt x a' b', typeType)
-
-   Table p t  -> do
-     p' <- justCheck g p typeType --- check p partype!
-     t' <- justCheck g t typeType
-     return $ (Table p' t', typeType)
-
-   FV vs -> do
-     (_,ty) <- checks $ map (inferLType gr g) vs
----     checkIfComplexVariantType trm ty
-     checkLType gr g trm ty
-
-   EPattType ty -> do
-     ty' <- justCheck g ty typeType
-     return (EPattType ty',typeType)
-   EPatt _ _ p -> do
-     ty <- inferPatt p
-     (minp,maxp,p') <- measurePatt gr p
-     return (EPatt minp maxp p', EPattType ty)
-
-   ELin c trm -> do
-     (trm',ty) <- inferLType gr g trm
-     ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
-     return $ (ELin c trm', ty')
-
-   _ -> checkError ("cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
-
- where
-   isPredef m = elem m [cPredef,cPredefAbs]
-
-   justCheck g ty te = checkLType gr g ty te >>= return . fst
-
-   -- for record fields, which may be typed
-   inferM (mty, t) = do
-     (t', ty') <- case mty of
-       Just ty -> checkLType gr g t ty
-       _ -> inferLType gr g t
-     return (Just ty',t')
-
-   inferCase mty (patt,term) = do
-     arg  <- maybe (inferPatt patt) return mty
-     cont <- pattContext gr g arg patt
-     (term',val) <- inferLType gr (reverse cont ++ g) term
-     return (arg,val)
-   isConstPatt p = case p of
-     PC _ ps -> True --- all isConstPatt ps
-     PP _ ps -> True --- all isConstPatt ps
-     PR ps -> all (isConstPatt . snd) ps
-     PT _ p -> isConstPatt p
-     PString _ -> True
-     PInt _ -> True
-     PFloat _ -> True
-     PChar -> True
-     PChars _ -> True
-     PSeq _ _ p _ _ q -> isConstPatt p && isConstPatt q
-     PAlt p q -> isConstPatt p && isConstPatt q
-     PRep _ _ p -> isConstPatt p
-     PNeg p -> isConstPatt p
-     PAs _ p -> isConstPatt p
-     _ -> False
-
-   inferPatt p = case p of
-     PP (q,c) ps | q /= cPredef -> liftM valTypeCnc (lookupResType gr (q,c))
-     PAs _ p  -> inferPatt p
-     PNeg p   -> inferPatt p
-     PAlt p q -> checks [inferPatt p, inferPatt q]
-     PSeq _ _ _ _ _ _ -> return $ typeStr
-     PRep _ _ _ -> return $ typeStr
-     PChar    -> return $ typeStr
-     PChars _ -> return $ typeStr
-     _ -> inferLType gr g (patt2term p) >>= return . snd
-
-measurePatt gr p =
-  case p of
-    PM q       -> do t <- lookupResDef gr q
-                     t <- normalForm (Gl gr stdPredef) t
-                     case t of
-                       EPatt minp maxp _ -> return (minp,maxp,p)
-                       _                 -> checkError ("Expected pattern macro, but found:" $$ nest 2 (pp t))
-    PR ass     -> do ass <- mapM (\(lbl,p) -> measurePatt gr p >>= \(_,_,p') -> return (lbl,p')) ass
-                     return (0,Nothing,PR ass)
-    PString s  -> do let len=length s
-                     return (len,Just len,p)
-    PT t p     -> do (min,max,p') <- measurePatt gr p
-                     return (min,max,PT t p')
-    PAs x p    -> do (min,max,p) <- measurePatt gr p
-                     case p of
-                       PW -> return (0,Nothing,PV x)
-                       _  -> return (min,max,PAs x p)
-    PImplArg p -> do (min,max,p') <- measurePatt gr p
-                     return (min,max,PImplArg p')
-    PNeg p     -> do (_,_,p') <- measurePatt gr p
-                     return (0,Nothing,PNeg p')
-    PAlt p1 p2 -> do (min1,max1,p1) <- measurePatt gr p1
-                     (min2,max2,p2) <- measurePatt gr p2
-                     case (p1,p2) of
-                       (PString [c1],PString [c2]) -> return (1,Just 1,PChars [c1,c2])
-                       (PString [c], PChars cs)    -> return (1,Just 1,PChars ([c]++cs))
-                       (PChars cs,   PString [c])  -> return (1,Just 1,PChars (cs++[c]))
-                       (PChars cs1,  PChars cs2)   -> return (1,Just 1,PChars (cs1++cs2))
-                       _                           -> return (min min1 min2,liftM2 max max1 max2,PAlt p1 p2)
-    PSeq _ _ p1 _ _ p2
-               -> do (min1,max1,p1) <- measurePatt gr p1
-                     (min2,max2,p2) <- measurePatt gr p2
-                     case (p1,p2) of
-                       (PW,        PW        ) -> return (0,Nothing,PW)
-                       (PString s1,PString s2) -> return (min1+min2,liftM2 (+) max1 max2,PString (s1++s2))
-                       _                       -> return (min1+min2,liftM2 (+) max1 max2,PSeq min1 max1 p1 min2 max2 p2)
-    PRep _ _ p -> do (minp,maxp,p) <- measurePatt gr p
-                     case p of
-                       PW    -> return (0,Nothing,PW)
-                       PChar -> return (0,Nothing,PW)
-                       _     -> return (0,Nothing,PRep minp maxp p)
-    PChar      -> return (1,Just 1,p)
-    PChars _   -> return (1,Just 1,p)
-    _          -> return (0,Nothing,p)
-
--- type inference: Nothing, type checking: Just t
--- the latter permits matching with value type
-getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type))
-getOverload gr g mt ot = case appForm ot of
-     (f@(Q c), ts) -> case lookupOverload gr c of
-       Ok typs -> do
-         ttys <- mapM (inferLType gr g) ts
-         v <- matchOverload f typs ttys
-         return $ Just v
-       _ -> return Nothing
-     (AdHocOverload cs@(f:_), ts) -> do     --- the function name f is only used in error messages
-       let typs = concatMap collectOverloads cs
-       ttys <- mapM (inferLType gr g) ts
-       v <- matchOverload f typs ttys
-       return $ Just v
-     _ -> return Nothing
-
- where
-   collectOverloads tr@(Q c) = case lookupOverload gr c of
-     Ok typs -> typs
-     _ -> case lookupResType gr c of
-       Ok ty -> let (args,val) = typeFormCnc ty in [(map (\(b,x,t) -> t) args,(val,tr))]
-       _ -> []
-   collectOverloads _ = [] --- constructors QC
-
-   matchOverload f typs ttys = do
-     let (tts,tys) = unzip ttys
-     let vfs = lookupOverloadInstance tys typs
-     let matches = [vf | vf@((_,v,_),_) <- vfs, matchVal mt v]
-     let showTypes ty = hsep (map ppType ty)
-
-
-     let (stys,styps) = (showTypes tys, [showTypes ty | (ty,_) <- typs])
-
-     -- to avoid strange error msg e.g. in case of unmatch record extension, show whole types if needed AR 28/1/2013
-     let (stysError,stypsError) = if elem (render stys) (map render styps)
-            then (hsep (map (ppTerm Unqualified 0) tys), [hsep (map (ppTerm Unqualified 0) ty) | (ty,_) <- typs])
-            else (stys,styps)
-
-     case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of
-       ([(_,val,fun)],_) -> return (mkApp fun tts, val)
-       ([],[(pre,val,fun)]) -> do
-         checkWarn $  "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
-                      "for" $$
-                      nest 2 (showTypes tys) $$
-                      "using" $$
-                      nest 2 (showTypes pre)
-         return (mkApp fun tts, val)
-       ([],[]) -> do
-         checkError $ "no overload instance of" <+> ppTerm Qualified 0 f $$
-                      maybe empty (\x -> "with value type" <+> ppType x) mt $$
-                      "for argument list" $$
-                      nest 2 stysError $$
-                      "among alternatives" $$
-                      nest 2 (vcat stypsError)
-
-
-       (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
-         ([(val,fun)],_) -> do
-           return (mkApp fun tts, val)
-         ([],[(val,fun)]) -> do
-           checkWarn ("ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot)
-           return (mkApp fun tts, val)
-
------ unsafely exclude irritating warning AR 24/5/2008
------           checkWarn $ "overloading of" +++ prt f +++
------             "resolved by excluding partial applications:" ++++
------             unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)]
-
---- now forgiving ambiguity with a warning AR 1/2/2014
---  This gives ad hoc overloading the same behaviour as the choice of the first match in renaming did before.
---  But it also gives a chance to ambiguous overloadings that were banned before.
-         (nps1,nps2) -> do
-              checkWarn $  "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
-                  ----     "with argument types" <+> hsep (map (ppTerm Qualified 0) tys) $$
-                           "resolved by selecting the first of the alternatives" $$
-                           nest 2 (vcat [ppTerm Qualified 0 fun | (_,ty,fun) <- vfs1 ++ if null vfs1 then vfs2 else []])
-              case [(mkApp fun tts,val) | (val,fun) <- nps1 ++ nps2] of
-                 [] -> checkError $ "no alternatives left when resolving" <+> ppTerm Unqualified 0 f
-                 h:_ -> return h
-
-   matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)]
-
-   unlocked v = case v of
-     RecType fs -> RecType $ filter (not . isLockLabel . fst) (sortRec fs)
-     _ -> v
-   ---- TODO: accept subtypes
-   ---- TODO: use a trie
-   lookupOverloadInstance tys typs =
-     [((pre,mkFunType rest val, t),isExact) |
-       let lt = length tys,
-       (ty,(val,t)) <- typs, length ty >= lt,
-       let (pre,rest) = splitAt lt ty,
-       let isExact = pre == tys,
-       isExact || map unlocked pre == map unlocked tys
-     ]
-
-   noProds vfs = [(v,f) | (_,v,f) <- vfs, noProd v]
-
-   noProd ty = case ty of
-     Prod _ _ _ _ -> False
-     _ -> True
-
-checkLType :: SourceGrammar -> Context -> Term -> Type -> Check (Term, Type)
-checkLType gr g trm typ0 = do
-  typ <- computeLType gr g typ0
-
-  case trm of
-
-    Abs bt x c -> do
-      case typ of
-        Prod bt' z a b -> do
-          (c',b') <- if z == identW
-                       then checkLType gr ((bt,x,a):g) c b
-                       else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b
-                               checkLType gr ((bt,x,a):g) c b'
-          return $ (Abs bt x c', Prod bt' z a b')
-        _ -> checkError $ "function type expected instead of" <+> ppType typ $$
-                          "\n   ** Double-check that the type signature of the operation" $$
-                          "matches the number of arguments given to it.\n"
-
-    App f a -> do
-       over <- getOverload gr g (Just typ) trm
-       case over of
-         Just trty -> return trty
-         _ -> do
-          (trm',ty') <- inferLType gr g trm
-          termWith trm' $ checkEqLType gr g typ ty' trm'
-
-    AdHocOverload ts -> do
-      over <- getOverload gr g Nothing trm
-      case over of
-        Just trty -> return trty
-        _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
-
-    Q _ -> do
-       over <- getOverload gr g (Just typ) trm
-       case over of
-         Just trty -> return trty
-         _ -> do
-          (trm',ty') <- inferLType gr g trm
-          termWith trm' $ checkEqLType gr g typ ty' trm'
-
-    T _ [] ->
-      checkError ("found empty table in type" <+> ppTerm Unqualified 0 typ)
-    T _ cs -> case typ of
-      Table arg val -> do
-        case allParamValues gr arg of
-          Ok vs -> do
-            let ps0 = map fst cs
-            ps <- testOvershadow ps0 vs
-            if null ps
-              then return ()
-              else checkWarn ("patterns never reached:" $$
-                              nest 2 (vcat (map (ppPatt Unqualified 0) ps)))
-          _ -> return () -- happens with variable types
-        cs' <- mapM (checkCase arg val) cs
-        return (T (TTyped arg) cs', typ)
-      _ -> checkError $ "table type expected for table instead of" $$ nest 2 (ppType typ)
-    V arg0 vs ->
-      case typ of
-        Table arg1 val ->
-           do arg' <- checkEqLType gr g arg0 arg1 trm
-              vs1 <- allParamValues gr arg1
-              if length vs1 == length vs
-                 then return ()
-                 else checkError $ "wrong number of values in table" <+> ppTerm Unqualified 0 trm
-              vs' <- map fst `fmap` sequence [checkLType gr g v val|v<-vs]
-              return (V arg' vs',typ)
-
-    R r -> case typ of --- why needed? because inference may be too difficult
-       RecType rr -> do
-       --let (ls,_) = unzip rr        -- labels of expected type
-         fsts <- mapM (checkM r) rr   -- check that they are found in the record
-         return $ (R fsts, typ)       -- normalize record
-
-       _ -> checkError ("record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
-
-    ExtR r s -> case typ of
-       _ | typ == typeType -> do
-         trm' <- computeLType gr g trm
-         case trm' of
-           RecType _ -> termWith trm' $ return typeType
-           ExtR (Vr _) (RecType _) -> termWith trm' $ return typeType
-                                      -- ext t = t ** ...
-           _ -> checkError ("invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))
-
-       RecType rr -> do
-
-         (fields1,fields2) <- case s of
-           R ss -> return (partition (\(l,_) -> isNothing (lookup l ss)) rr)
-           _ -> do
-             (s',typ2) <- inferLType gr g s
-             case typ2 of
-               RecType ss -> return (partition (\(l,_) -> isNothing (lookup l ss)) rr)
-               _ ->  checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2))
-
-         (r',_) <- checkLType gr g r (RecType fields1)
-         (s',_) <- checkLType gr g s (RecType fields2)
-
-         let withProjection t fields g f =
-               case t of
-                 R rs -> f g (\l -> case lookup l rs of
-                                      Just (_,t) -> t
-                                      Nothing    -> error (render ("no value for label" <+> l)))
-                 QC _ -> f g (\l -> P t l)
-                 Vr _ -> f g (\l -> P t l)
-                 _    -> if length fields == 1
-                           then f g (\l -> P t l)
-                           else let x = mkFreshVar (map (\(_,x,_) -> x) g) (identS "x")
-                                in Let (x, (Nothing, t)) (f ((Explicit,x,RecType fields):g) (\l -> P (Vr x) l))
-
-             rec = withProjection r' fields1 g $ \g p_r' ->
-                   withProjection s' fields2 g $ \g p_s' ->
-                     R ([(l,(Nothing,p_r' l)) | (l,_) <- fields1] ++ [(l,(Nothing,p_s' l)) | (l,_) <- fields2])
-         return (rec, typ)
-
-       ExtR ty ex -> do
-         r' <- justCheck g r ty
-         s' <- justCheck g s ex
-         return $ (ExtR r' s', typ) --- is this all? it assumes the same division in trm and typ
-
-       _ -> checkError ("record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
-
-    FV vs -> do
-      ttys <- mapM (flip (checkLType gr g) typ) vs
----      checkIfComplexVariantType trm typ
-      return (FV (map fst ttys), typ) --- typ' ?
-
-    S tab arg -> checks [ do
-      (tab',ty) <- inferLType gr g tab
-      ty'       <- computeLType gr g ty
-      case ty' of
-        Table p t -> do
-          (arg',val) <- checkLType gr g arg p
-          checkEqLType gr g typ t trm
-          return (S tab' arg', t)
-        _ -> checkError ("table type expected for applied table instead of" <+> ppType ty')
-     , do
-      (arg',ty) <- inferLType gr g arg
-      ty'       <- computeLType gr g ty
-      (tab',_)  <- checkLType gr g tab (Table ty' typ)
-      return (S tab' arg', typ)
-      ]
-    Let (x,(mty,def)) body -> case mty of
-      Just ty -> do
-        (ty0,_)    <- checkLType gr g ty typeType
-        (def',ty') <- checkLType gr g def ty0
-        body' <- justCheck ((Explicit,x,ty'):g) body typ
-        return (Let (x,(Just ty',def')) body', typ)
-      _ -> do
-        (def',ty) <- inferLType gr g def  -- tries to infer type of local constant
-        checkLType gr g (Let (x,(Just ty,def')) body) typ
-
-    ELin c tr -> do
-      tr1 <- unlockRecord c tr
-      checkLType gr g tr1 typ
-
-    _ -> do
-      (trm',ty') <- inferLType gr g trm
-      termWith trm' $ checkEqLType gr g typ ty' trm'
- where
-   justCheck g ty te = checkLType gr g ty te >>= return . fst
-{-
-   recParts rr t = (RecType rr1,RecType rr2) where
-     (rr1,rr2) = partition (flip elem (map fst t) . fst) rr
--}
-   checkM rms (l,ty) = case lookup l rms of
-     Just (Just ty0,t) -> do
-       checkEqLType gr g ty ty0 t
-       (t',ty') <- checkLType gr g t ty
-       return (l,(Just ty',t'))
-     Just (_,t) -> do
-       (t',ty') <- checkLType gr g t ty
-       return (l,(Just ty',t'))
-     _ -> checkError $
-            if isLockLabel l
-              then let cat = drop 5 (showIdent (label2ident l))
-                   in ppTerm Unqualified 0 (R rms) <+> "is not in the lincat of" <+> cat <>
-                      "; try wrapping it with lin" <+> cat
-              else "cannot find value for label" <+> l <+> "in" <+> ppTerm Unqualified 0 (R rms)
-
-   checkCase arg val (p,t) = do
-     cont <- pattContext gr g arg p
-     t' <- justCheck (reverse cont ++ g) t val
-     (_,_,p') <- measurePatt gr p
-     return (p',t')
-
-pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context
-pattContext env g typ p = case p of
-  PV x -> return [(Explicit,x,typ)]
-  PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
-    t <- lookupResType env (q,c)
-    let (cont,v) = typeFormCnc t
-    checkCond ("wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
-              (length cont == length ps)
-    checkEqLType env g typ v (patt2term p)
-    mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat
-  PR r -> do
-    typ' <- computeLType env g typ
-    case typ' of
-      RecType t -> do
-        let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]]
-        ----- checkWarn $ prt p ++++ show pts ----- debug
-        mapM (uncurry (pattContext env g)) pts >>= return . concat
-      _ -> checkError ("record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
-  PT t p' -> do
-    checkEqLType env g typ t (patt2term p')
-    pattContext env g typ p'
-
-  PAs x p -> do
-    g' <- pattContext env g typ p
-    return ((Explicit,x,typ):g')
-
-  PAlt p' q -> do
-    g1 <- pattContext env g typ p'
-    g2 <- pattContext env g typ q
-    let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1])
-    checkCond
-      ("incompatible bindings of" <+>
-       fsep pts <+>
-       "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts)
-    return g1 -- must be g1 == g2
-  PSeq _ _ p _ _ q -> do
-    g1 <- pattContext env g typ p
-    g2 <- pattContext env g typ q
-    return $ g1 ++ g2
-  PRep _ _ p' -> noBind typeStr p'
-  PNeg p' -> noBind typ p'
-
-  _ -> return [] ---- check types!
- where
-   noBind typ p' = do
-    co <- pattContext env g typ p'
-    if not (null co)
-      then checkWarn ("no variable bound inside pattern" <+> ppPatt Unqualified 0 p)
-           >> return []
-      else return []
-
-checkEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check Type
-checkEqLType gr g t u trm = do
-  (b,t',u',s) <- checkIfEqLType gr g t u trm
-  case b of
-    True  -> return t'
-    False ->
-      let inferredType = ppTerm Qualified 0 u
-          expectedType = ppTerm Qualified 0 t
-          term = ppTerm Unqualified 0 trm
-          funName = pp . head . words .render $ term
-          helpfulMsg =
-            case (arrows inferredType, arrows expectedType) of
-              (0,0) -> pp "" -- None of the types is a function
-              _ -> "\n   **" <+>
-                  if expectedType `isLessApplied` inferredType
-                    then "Maybe you gave too few arguments to" <+> funName
-                    else pp "Double-check that type signature and number of arguments match."
-      in checkError $ s <+> "type of" <+> term $$
-                            "expected:" <+> expectedType $$ -- ppqType t u $$
-                            "inferred:" <+> inferredType $$ -- ppqType u t
-                            helpfulMsg
+import Data.STRef
+import Data.List (nub, (\\), tails)
+import qualified Data.Map as Map
+import Data.Maybe(fromMaybe,isNothing,mapMaybe)
+import Data.Bifunctor(second)
+import Data.Functor((<&>))
+import qualified Control.Monad.Fail as Fail
+
+checkLType :: Globals -> Term -> Type -> Check (Term, Type)
+checkLType globals t ty = do
+  res <- runEvalM globals $ do
+            let (c1,c2) = split unit
+            (t,vty) <- checkLType' c1 t (eval globals [] c2 ty [])
+            ty <- value2termM True [] vty
+            return (t,ty)
+  case res of
+    [tty] -> return tty
+    _     -> checkError (pp "Encountered variants while type checking")
+
+checkLType' :: Choice -> Term -> Constraint -> EvalM (Term, Constraint)
+checkLType' c t vty = do
+  (t,vty) <- tcRho [] c t (Just vty)
+  t <- zonkTerm [] t
+  return (t,vty)
+
+inferLType :: Globals -> Term -> Check (Term, Type)
+inferLType globals t = do
+  res <- runEvalM globals $ do
+            (t,vty) <- inferLType' t
+            ty <- value2termM True [] vty
+            return (t,ty)
+  case res of
+    [tty] -> return tty
+    _     -> checkError (pp "Encountered variants while type checking")
+
+inferLType' :: Term -> EvalM (Term, Constraint)
+inferLType' t = do
+  (t,vty) <- inferSigma [] unit t
+  t <- zonkTerm [] t
+  return (t,vty)
+
+inferSigma :: Scope -> Choice -> Term -> EvalM (Term,Sigma)
+inferSigma scope s t = do                                      -- GEN1
+  (t,ty) <- tcRho scope s t Nothing
+  env_tvs <- getMetaVars (scopeTypes scope)
+  res_tvs <- getMetaVars [(scope,ty)]
+  let forall_tvs = res_tvs \\ env_tvs
+  quantify scope t forall_tvs ty
+
+vtypeInt   = VApp poison (cPredef,cInt) []
+vtypeFloat = VApp poison (cPredef,cFloat) []
+vtypeInts i= VApp poison (cPredef,cInts) [VInt i]
+vtypeStr   = VSort cStr
+vtypeStrs  = VSort cStrs
+vtypeType  = VSort cType
+vtypePType = VSort cPType
+vtypeMarkup= VApp poison (cPredef,cMarkup) []
+
+tcRho :: Scope -> Choice -> Term -> Maybe Rho -> EvalM (Term, Rho)
+tcRho scope s t@(EInt i)   mb_ty = instSigma scope s t (vtypeInts i) mb_ty -- INT
+tcRho scope s t@(EFloat _) mb_ty = instSigma scope s t vtypeFloat mb_ty    -- FLOAT
+tcRho scope s t@(K _)      mb_ty = instSigma scope s t vtypeStr   mb_ty    -- STR
+tcRho scope s t@(Empty)    mb_ty = instSigma scope s t vtypeStr   mb_ty
+tcRho scope s t@(Vr v)     mb_ty = do                          -- VAR
+  case lookup v scope of
+    Just v_sigma -> instSigma scope s t v_sigma mb_ty
+    Nothing      -> evalError ("Unknown variable" <+> v)
+tcRho scope c t@(Q id)     mb_ty = tcApp scope c t t [] mb_ty
+tcRho scope c t@(QC id)    mb_ty = tcApp scope c t t [] mb_ty
+tcRho scope c t@(App fun arg) mb_ty = tcApp scope c t t [] mb_ty
+tcRho scope c (Abs bt var body) Nothing = do                   -- ABS1
+  i <- newResiduation scope
+  let arg_ty = VMeta i []
+  (body,body_ty) <- tcRho ((var,arg_ty):scope) c body Nothing
+  let m = length scope
+      n = m+1
+  (b,used_bndrs) <- check m n (False,[]) body_ty
+  if b
+    then let v = head (allBinders \\ used_bndrs)
+         in return (Abs bt var body, (VProd bt v arg_ty body_ty))
+    else return (Abs bt var body, (VProd bt identW arg_ty body_ty))
   where
-    -- count the number of arrows in the prettyprinted term
-    arrows :: Doc -> Int
-    arrows = length . filter (=="->") . words . render
+    check m n st (VApp c f vs)     = foldM (check m n) st vs
+    check m n st (VMeta i vs)      = do
+      state <- getMeta i
+      case state of
+        Bound _ v -> do g <- globals
+                        check m n st (apply g v vs)
+        _         -> foldM (check m n) st vs
+    check m n st@(b,xs) (VGen i vs)
+      | i == m                       = return (True, xs)
+      | otherwise                    = return st
+    check m n st (VClosure env c (Abs bt x t)) = do
+      g <- globals
+      check m (n+1) st (eval g ((x,VGen n []):env) c t [])
+    check m n st (VProd _ x v1 v2) = do
+      st@(b,xs) <- check m n st v1
+      case v2 of
+        VClosure env c t -> do g  <- globals
+                               check m (n+1) (b,x:xs) (eval g ((x,VGen n []):env) c t [])
+        v2               -> check m n st v2
+    check m n st (VRecType as)     = foldM (\st (l,_,v) -> check m n st v) st as
+    check m n st (VR as)           =
+      foldM (\st (lbl,tnk) -> check m n st tnk) st as
+    check m n st (VP v l vs)       =
+      check m n st v >>= \st -> foldM (check m n) st vs
+    check m n st (VExtR v1 v2)     =
+      check m n st v1 >>= \st -> check m n st v2
+    check m n st (VTable v1 v2)    =
+      check m n st v1 >>= \st -> check m n st v2
+    check m n st (VT ty env c cs) =
+      check m n st ty    -- Traverse cs as well
+    check m n st (VV ty cs)        =
+      check m n st ty >>= \st -> foldM (check m n) st cs
+    check m n st (VS v1 tnk vs)    = do
+      st <- check m n st v1
+      st <- check m n st tnk
+      foldM (check m n) st vs
+    check m n st (VSort _)         = return st
+    check m n st (VInt _)          = return st
+    check m n st (VFlt _)          = return st
+    check m n st (VStr _)          = return st
+    check m n st VEmpty            = return st
+    check m n st (VC v1 v2)        =
+      check m n st v1 >>= \st -> check m n st v2
+    check m n st (VGlue v1 v2)     =
+      check m n st v1 >>= \st -> check m n st v2
+    check m n st (VPatt _ _ _)     = return st
+    check m n st (VPattType v)     = check m n st v
+    check m n st (VAlts v vs)      = do
+      st <- check m n st v
+      foldM (\st (v1,v2) -> check m n st v1 >>= \st -> check m n st v2) st vs
+    check m n st (VStrs vs)        =
+      foldM (check m n) st vs
+tcRho scope c t@(Abs Implicit var body) (Just ty) = do         -- ABS2
+  (bt, x, var_ty, body_ty) <- unifyFun scope ty
+  if bt == Implicit
+    then return ()
+    else evalError (ppTerm Unqualified 0 t <+> "is an implicit function, but no implicit function is expected")
+  body_ty <- evalCodomain x (VGen (length scope) []) body_ty
+  (body, body_ty) <- tcRho ((var,var_ty):scope) c body (Just body_ty)
+  return (Abs Implicit var body,ty)
+tcRho scope c (Abs Explicit var body) (Just ty) = do           -- ABS3
+  (scope,f,ty') <- skolemise scope ty
+  (_,x,var_ty,body_ty) <- unifyFun scope ty'
+  body_ty <- evalCodomain x (VGen (length scope) []) body_ty
+  (body, body_ty) <- tcRho ((var,var_ty):scope) c body (Just body_ty)
+  return (f (Abs Explicit var body),ty)
+tcRho scope c (Meta _) mb_ty = do
+  i <- newResiduation scope
+  ty <- case mb_ty of
+          Just ty -> return ty
+          Nothing -> do j <- newResiduation scope
+                        return (VMeta j [])
+  return (Meta i, ty)
+tcRho scope c (Let (var, (Nothing, rhs)) body) mb_ty = do      -- LET
+  let (c1,c2) = split c
+  (rhs,var_ty) <- tcRho scope c1 rhs Nothing
+  (body, body_ty) <- tcRho ((var,var_ty):scope) c2 body mb_ty
+  var_ty <- value2termM True (scopeVars scope) var_ty
+  return (Let (var, (Just var_ty, rhs)) body, body_ty)
+tcRho scope c (Let (var, (Just ann_ty, rhs)) body) mb_ty = do  -- LET
+  let (c1,c2,c3,c4) = split4 c
+  (ann_ty, _) <- tcRho scope c1 ann_ty (Just vtypeType)
+  g <- globals
+  let v_ann_ty = eval g (scopeEnv scope) c2 ann_ty []
+  (rhs,_) <- tcRho scope c3 rhs (Just v_ann_ty)
+  (body, body_ty) <- tcRho ((var,v_ann_ty):scope) c4 body mb_ty
+  var_ty <- value2termM True (scopeVars scope) v_ann_ty
+  return (Let (var, (Just var_ty, rhs)) body, body_ty)
+tcRho scope c (Typed body ann_ty) mb_ty = do                   -- ANNOT
+  let (c1,c2,c3,c4) = split4 c
+  (ann_ty, _) <- tcRho scope c1 ann_ty (Just vtypeType)
+  g <- globals
+  let v_ann_ty = eval g (scopeEnv scope) c2 ann_ty []
+  (body,_) <- tcRho scope c3 body (Just v_ann_ty)
+  instSigma scope c4 (Typed body ann_ty) v_ann_ty mb_ty
+tcRho scope c (FV ts) mb_ty = do
+  (ts,ty) <- tcUnifying scope c ts mb_ty
+  return (FV ts, ty)
+tcRho scope s t@(Sort _) mb_ty = do
+  instSigma scope s t vtypeType mb_ty
+tcRho scope c t@(RecType rs) Nothing   = do
+  (rs,mb_ty) <- tcRecTypeFields scope c rs Nothing
+  return (RecType rs,fromMaybe vtypePType mb_ty)
+tcRho scope c t@(RecType rs) (Just ty) = do
+  (scope,f,ty') <- skolemise scope ty
+  case ty' of
+    VSort s
+      | s == cType  -> return ()
+      | s == cPType -> return ()
+    VMeta i vs-> case rs of
+                   [] -> unifyVar scope i vs vtypePType
+                   _  -> return ()
+    ty        -> do ty <- value2termM False (scopeVars scope) ty
+                    evalError ("The record type" <+> ppTerm Unqualified 0 t $$
+                               "cannot be of type" <+> ppTerm Unqualified 0 ty)
+  (rs,mb_ty) <- tcRecTypeFields scope c rs (Just ty')
+  return (f (RecType rs),ty)
+tcRho scope s t@(Table p res) mb_ty = do
+  let (s1,s23) = split s
+      (s2,s3)  = split s23
+  (p,  p_ty)   <- tcRho scope s1 p   (Just vtypePType)
+  (res,res_ty) <- tcRho scope s2 res (Just vtypeType)
+  instSigma scope s3 (Table p res) vtypeType mb_ty
+tcRho scope c (Prod bt x ty1 ty2) mb_ty = do
+  let (c1,c2,c3,c4) = split4 c
+  (ty1,ty1_ty) <- tcRho scope c1 ty1 (Just vtypeType)
+  g <- globals
+  (ty2,ty2_ty) <- tcRho ((x,eval g (scopeEnv scope) c2 ty1 []):scope) c3 ty2 (Just vtypeType)
+  instSigma scope c4 (Prod bt x ty1 ty2) vtypeType mb_ty
+tcRho scope c (S t p) mb_ty = do
+  let (c1,c2) = split c
+  let mk_val i = VMeta i []
+  p_ty   <- fmap mk_val $ newResiduation scope
+  res_ty <- case mb_ty of
+              Nothing -> fmap mk_val $ newResiduation scope
+              Just ty -> return ty
+  let t_ty = VTable p_ty res_ty
+  (t,t_ty) <- tcRho scope c1 t (Just t_ty)
+  (p,_) <- tcRho scope c2 p (Just p_ty)
+  return (S t p, res_ty)
+tcRho scope c (T tt ps) Nothing = do                           -- ABS1/AABS1 for tables
+  let (c1,c2) = split c
+  let mk_val i = VMeta i []
+  p_ty   <- case tt of
+              TRaw      -> fmap mk_val $ newResiduation scope
+              TTyped ty -> do let (c3,c4) = split c1
+                              (ty, _) <- tcRho scope c3 ty (Just vtypeType)
+                              g <- globals
+                              return (eval g (scopeEnv scope) c4 ty [])
+  res_ty <- fmap mk_val $ newResiduation scope
+  ps <- tcCases scope c2 ps p_ty res_ty
+  p_ty_t <- value2termM True [] p_ty
+  return (T (TTyped p_ty_t) ps, VTable p_ty res_ty)
+tcRho scope c (T tt ps) (Just ty) = do                         -- ABS2/AABS2 for tables
+  let (c12,c34) = split c
+      (c3,c4)   = split c34
+  (scope,f,ty') <- skolemise scope ty
+  (p_ty, res_ty) <- unifyTbl scope ty'
+  case tt of
+    TRaw      -> return ()
+    TTyped ty -> do let (c1,c2) = split c12
+                    (ty, _) <- tcRho scope c1 ty (Just vtypeType)
+                    g <- globals
+                    unify scope (eval g (scopeEnv scope) c2 ty []) p_ty
+  ps <- tcCases scope c3 ps p_ty res_ty
+  p_ty_t <- value2termM True (scopeVars scope) p_ty
+  return (f (T (TTyped p_ty_t) ps), VTable p_ty res_ty)
+tcRho scope c (V p_ty ts) Nothing = do
+  let (c1,c2,c3,c4) = split4 c
+  (p_ty, _) <- tcRho scope c1 p_ty (Just vtypeType)
+  i <- newResiduation scope
+  let res_ty = VMeta i []
 
-    -- If prettyprinted type t has fewer arrows then prettyprinted type u,
-    -- then t is "less applied", and we can print out more helpful error msg.
-    isLessApplied :: Doc -> Doc -> Bool
-    isLessApplied t u = arrows t < arrows u
+  let go c t = do (t, ty) <- tcRho scope c t Nothing
+                  subsCheckRho scope t ty res_ty
 
-checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
-checkIfEqLType gr g t u trm = do
-  t' <- computeLType gr g t
-  u' <- computeLType gr g u
-  case t' == u' || alpha [] t' u' of
-    True -> return (True,t',u',[])
-    -- forgive missing lock fields by only generating a warning.
-    --- better: use a flag to forgive? (AR 31/1/2006)
-    _ -> case missingLock [] t' u' of
-      Ok lo -> do
-        checkWarn $ "missing lock field" <+> fsep lo
-        return (True,t',u',[])
-      Bad s -> return (False,t',u',s)
+  ts <- mapCM go c2 ts
+  g <- globals
+  return (V p_ty ts, VTable (eval g (scopeEnv scope) c3 p_ty []) res_ty)
+tcRho scope c (V p_ty0 ts) (Just ty) = do
+  let (c1,c2,c3,c4) = split4 c
+  (scope,f,ty') <- skolemise scope ty
+  (p_ty, res_ty) <- unifyTbl scope ty'
+  (p_ty0, _) <- tcRho scope c1 p_ty0 (Just vtypeType)
+  g <- globals
+  let p_vty0 = eval g (scopeEnv scope) c2 p_ty0 []
+  unify scope p_ty p_vty0
+  ts <- mapCM (\c t -> fmap fst $ tcRho scope c t (Just res_ty)) c3 ts
+  return (V p_ty0 ts, VTable p_ty res_ty)
+tcRho scope c (R rs) Nothing = do
+  lttys <- inferRecFields scope c rs
+  rs <- mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
+  return (R        rs,
+          VRecType [(l,True,ty) | (l,t,ty) <- lttys]
+         )
+tcRho scope c (R rs) (Just ty) = do
+  (scope,f,ty') <- skolemise scope ty
+  case ty' of
+    (VRecType ltys) -> do lttys <- checkRecFields scope c rs ltys
+                          rs <- mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
+                          return ((f . R)  rs,
+                                  VRecType [(l,True,ty) | (l,t,ty) <- lttys]
+                                 )
+    ty              -> do lttys <- inferRecFields scope c rs
+                          t <- liftM (f . R) (mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys)
+                          let ty' = VRecType [(l,True,ty) | (l,t,ty) <- lttys]
+                          t <- subsCheckRho scope t ty' ty
+                          return (t, ty')
+tcRho scope c (P t l) mb_ty = do
+  l_ty   <- case mb_ty of
+              Just ty -> return ty
+              Nothing -> do i <- newResiduation scope
+                            return (VMeta i [])
+  (t,t_ty) <- tcRho scope c t (Just (VRecType [(l,True,l_ty)]))
+  return (P t l,l_ty)
+tcRho scope c (C t1 t2) mb_ty = do
+  let (c1,c2,c3,c4) = split4 c
+  (t1,t1_ty) <- tcRho scope c1 t1 (Just vtypeStr)
+  (t2,t2_ty) <- tcRho scope c2 t2 (Just vtypeStr)
+  instSigma scope c3 (C t1 t2) vtypeStr mb_ty
+tcRho scope c (Glue t1 t2) mb_ty = do
+  let (c1,c2,c3,c4) = split4 c
+  (t1,t1_ty) <- tcRho scope c1 t1 (Just vtypeStr)
+  (t2,t2_ty) <- tcRho scope c2 t2 (Just vtypeStr)
+  instSigma scope c3 (Glue t1 t2) vtypeStr mb_ty
+tcRho scope c t@(ExtR t1 t2) mb_ty = do
+  let (c1,c2,c3,c4) = split4 c
+  (t1,t1_ty) <- tcRho scope c1 t1 Nothing
+  (t2,t2_ty) <- tcRho scope c2 t2 Nothing
+  case (t1_ty,t2_ty) of
+    (VSort s1,VSort s2)
+       | (s1 == cType || s1 == cPType) &&
+         (s2 == cType || s2 == cPType) -> let sort | s1 == cPType && s2 == cPType = cPType
+                                                   | otherwise                    = cType
+                                          in instSigma scope c3 (ExtR t1 t2) (VSort sort) mb_ty
+    (VRecType rs1, VRecType rs2)       -> instSigma scope c3 (ExtR t1 t2) (VRecType (rs2++rs1)) mb_ty
+    _                                  -> evalError ("Cannot type check" <+> ppTerm Unqualified 0 t)
+tcRho scope c (ELin cat t) mb_ty = do  -- this could be done earlier, i.e. in the parser
+  tcRho scope c (ExtR t (R [(lockLabel cat,(Just (RecType []),R []))])) mb_ty
+tcRho scope c (ELincat cat t) mb_ty = do  -- this could be done earlier, i.e. in the parser
+  tcRho scope c (ExtR t (RecType [(lockLabel cat,RecType [])])) mb_ty
+tcRho scope c (Alts t ss) mb_ty = do
+  let (c1,c2,c3,c4) = split4 c
+  (t,_) <- tcRho scope c1 t (Just vtypeStr)
+  ss    <- mapCM (\c (t1,t2) -> do
+                          let (c1,c2) = split c
+                          (t1,_) <- tcRho scope c1 t1 (Just vtypeStr)
+                          (t2,_) <- tcRho scope c2 t2 (Just vtypeStrs)
+                          return (t1,t2))
+                 c2 ss
+  instSigma scope c3 (Alts t ss) vtypeStr mb_ty
+tcRho scope c (Strs ss) mb_ty = do
+  let (c1,c2) = split c
+  ss <- mapCM (\c t -> do (t,_) <- tcRho scope c t (Just vtypeStr)
+                          return t)
+              c1 ss
+  instSigma scope c2 (Strs ss) vtypeStrs mb_ty
+tcRho scope c (EPattType ty) mb_ty = do
+  let (c1,c2) = split c
+  (ty, _) <- tcRho scope c1 ty (Just vtypeType)
+  instSigma scope c2 (EPattType ty) vtypeType mb_ty
+tcRho scope c t@(EPatt min max p) mb_ty = do
+  (scope,f,ty) <- case mb_ty of
+                    Nothing -> do i <- newResiduation scope
+                                  return (scope,id,VMeta i [])
+                    Just ty -> do (scope,f,ty) <- skolemise scope ty
+                                  case ty of
+                                    VPattType ty -> return (scope,f,ty)
+                                    _            -> evalError (ppTerm Unqualified 0 t <+> "must be of pattern type but" <+> ppTerm Unqualified 0 t <+> "is expected")
+  tcPatt scope c p ty
+  return (f (EPatt min max p), ty)
+tcRho scope c (Markup tag attrs children) mb_ty = do
+  let (c1,c2,c3,c4) = split4 c
+  attrs <- mapCM (\c (id,t) -> do
+                       (t,_) <- tcRho scope c t Nothing
+                       return (id,t))
+                 c1 attrs
+  res <- mapCM (\c child -> tcRho scope c child Nothing) c2 children
+  instSigma scope c3 (Markup tag attrs (map fst res)) vtypeMarkup mb_ty
+tcRho scope c (Reset ctl mb_ct t qid) mb_ty
+  | ctl == cConcat = do
+      let (c1,c23) = split c
+          (c2,c3 ) = split c23
+      (t,_) <- tcRho scope c1 t Nothing
+      mb_ct <- case mb_ct of
+                 Just ct -> do (ct,_) <- tcRho scope c2 ct (Just vtypeInt)
+                               return (Just ct)
+                 Nothing -> return Nothing
+      instSigma scope c2 (Reset ctl mb_ct t qid) vtypeMarkup mb_ty
+  | ctl == cOne = do
+      let (c1,c2) = split c
+      (t,ty)     <- tcRho scope c1 t mb_ty
+      (mb_ct,ty) <- case mb_ct of
+                      Just ct -> do (ct,ty) <- tcRho scope c2 ct (Just ty)
+                                    return (Just ct,ty)
+                      Nothing -> return (Nothing,ty)
+      return (Reset ctl mb_ct t qid,ty)
+  | ctl == cDefault = do
+      let (c1,c2) = split c
+      (t,ty)     <- tcRho scope c1 t mb_ty
+      (mb_ct,ty) <- case mb_ct of
+                      Just ct -> do (ct,ty) <- tcRho scope c2 ct (Just ty)
+                                    return (Just ct,ty)
+                      Nothing -> evalError (pp "[list: .. | ..] requires an argument")
+      return (Reset ctl mb_ct t qid,ty)
+  | ctl == cList = do
+      do let (c1,c2) = split c
+         mb_ct  <- case mb_ct of
+                     Just ct -> do (ct,ty) <- tcRho scope c1 ct Nothing
+                                   return (Just ct)
+                     Nothing -> evalError (pp "[list: .. | ..] requires an argument")
+         (t,ty) <- tcRho scope c2 t mb_ty
+         case ty of
+           VApp c qid [] -> return (Reset ctl mb_ct t (Just qid), ty)
+           _             -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty)
+  | otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
+tcRho scope s (Opts n cs) mb_ty = do
+  let (s1,s2,s3) = split3 s
+  (n,_) <- tcRho scope s1 n Nothing
+  (ls,_) <- tcUnifying scope s2 (fst <$> cs) Nothing
+  (ts,ty) <- tcUnifying scope s3 (snd <$> cs) mb_ty
+  return (Opts n (zip ls ts), ty)
+tcRho scope s t _ = unimplemented ("tcRho "++show t)
 
+evalCodomain :: Ident -> Value -> Value -> EvalM Value
+evalCodomain x v (VClosure env c ty) = do
+  g <- globals
+  return (eval g ((x,v):env) c ty [])
+evalCodomain x _ ty = return ty
+
+tcUnifying :: Scope -> Choice -> [Term] -> Maybe Rho -> EvalM ([Term], Constraint)
+tcUnifying scope c ts mb_ty = do
+  (ty,subsume) <-
+    case mb_ty of
+      Just ty -> do return (ty, \t ty' -> return t)
+      Nothing -> do i <- newResiduation scope
+                    let ty = VMeta i []
+                    return (ty, \t ty' -> subsCheckRho scope t ty' ty)
+
+  let go c t = do (t, ty) <- tcRho scope c t mb_ty
+                  subsume t ty
+
+  ts <- mapCM go c ts
+  return (ts,ty)
+
+tcCases scope c []         p_ty res_ty = return []
+tcCases scope c ((p,t):cs) p_ty res_ty = do
+  let (c1,c2,c3,c4) = split4 c
+  scope' <- tcPatt scope c1 p p_ty
+  (t,_)  <- tcRho scope' c2 t (Just res_ty)
+  cs <- tcCases scope c3 cs p_ty res_ty
+  return ((p,t):cs)
+
+tcApp scope c t0 (App fun arg) args mb_ty = tcApp scope c t0 fun (arg:args) mb_ty     -- APP
+tcApp scope c t0 t@(Q id)      args mb_ty = resolveOverloads scope c t0 id args mb_ty -- VAR (global)
+tcApp scope c t0 t@(QC id)     args mb_ty = resolveOverloads scope c t0 id args mb_ty -- VAR (global)
+tcApp scope c t0 t             args mb_ty = do
+  let (c1,c23) = split c
+  let (c2,c3)  = split c23
+  (t,ty) <- tcRho scope c1 t Nothing
+  (t,ty) <- reapply1 scope c2 t ty args
+  instSigma scope c3 t ty mb_ty
+
+reapply1 :: Scope -> Choice -> Term -> Value -> [Term] -> EvalM (Term,Rho)
+reapply1 scope c fun fun_ty []                   = return (fun,fun_ty)
+reapply1 scope c fun fun_ty ((ImplArg arg):args) = do -- Implicit arg case
+  let (c1,c2,c3,c4) = split4 c
+  (bt, x, arg_ty, res_ty) <- unifyFun scope fun_ty
+  unless (bt == Implicit) $
+     evalError (ppTerm Unqualified 0 (App fun (ImplArg arg)) <+>
+                "is an implicit argument application, but no implicit argument is expected")
+  (arg,_) <- tcRho scope c1 arg (Just arg_ty)
+  g <- globals
+  res_ty <- evalCodomain x (eval g (scopeEnv scope) c2 arg []) res_ty
+  reapply1 scope c3 (App fun (ImplArg arg)) res_ty args
+reapply1 scope c fun fun_ty (arg:args) = do -- Explicit arg (fallthrough) case
+  let (c1,c2,c3,c4) = split4 c
+  (fun,fun_ty) <- instantiate scope fun fun_ty
+  (_, x, arg_ty, res_ty) <- unifyFun scope fun_ty
+  (arg,_) <- tcRho scope c1 arg (Just arg_ty)
+  g <- globals
+  res_ty <- evalCodomain x (eval g (scopeEnv scope) c2 arg []) res_ty
+  reapply1 scope c3 (App fun arg) res_ty args
+
+resolveOverloads :: Scope -> Choice -> Term -> QIdent -> [Term] -> Maybe Rho -> EvalM (Term,Rho)
+resolveOverloads scope c t0 q args mb_ty = do
+  g@(Gl gr _) <- globals
+  case lookupOverloadTypes gr q of
+    Bad msg  -> evalError (pp msg)
+    Ok [(t,ty)] -> do let (c1,c23) = split c
+                          (c2,c3)  = split c23
+                      (t,ty) <- reapply1 scope c1 t (eval g [] c2 ty []) args
+                      instSigma scope c3 t ty mb_ty
+    Ok ttys     -> do let (c1,c23) = split c
+                          (c2,c3)  = split c23
+                      arg_tys <- mapCM (checkArg g) c1 args
+                      let v_ttys = mapC (\c (t,ty) -> (t,eval g [] c ty [])) c2 ttys
+                      try (\(fun,fun_ty) -> reapply2 scope c3 fun fun_ty arg_tys mb_ty)
+                          (\ttys -> fmap (\(ts,ty) -> (mkFV ts,ty)) (snd (minimum g ttys)))
+                          v_ttys
   where
+    checkArg g c (ImplArg arg) = do
+      let (c1,c2) = split c
+      (arg,arg_ty) <- tcRho scope c1 arg Nothing
+      let v = eval g (scopeEnv scope) c2 arg []
+      return (ImplArg arg,v,arg_ty)
+    checkArg g c arg = do
+      let (c1,c2) = split c
+      (arg,arg_ty) <- tcRho scope c1 arg Nothing
+      let v = eval g (scopeEnv scope) c2 arg []
+      return (arg,v,arg_ty)
 
-   -- check that u is a subtype of t
-   --- quick hack version of TC.eqVal
-   alpha g t u = case (t,u) of
+    mkFV [t] = t
+    mkFV ts  = FV ts
 
-     -- error (the empty type!) is subtype of any other type
-     (_,u) | u == typeError -> True
+    minimum g []                    = (maxBound,err)
+      where
+        err = evalError (pp "Overload resolution failed")
+    minimum g (tty@((t,ty),state):ttys) =
+      let ty'      = zonk ty
+          a        = arity ty'
+          (a',res) = minimum g ttys
+      in case compare a a' of
+           GT -> (a',res)
+           EQ -> (a',join t ty' state res)
+           LT -> (a ,one  t ty' state)
+      where
+        arity :: Value -> Int
+        arity (VProd _ _ _ ty) = 1 + arity ty
+        arity _                = 0
 
-     -- contravariance
-     (Prod _ x a b, Prod _ y c d) -> alpha g c a && alpha ((x,y):g) b d
+        zonk :: Value -> Value
+        zonk (VProd bt x ty1 ty2) = VProd bt x (zonk ty1) (zonk ty2)
+        zonk (VMeta i vs)         =
+          case Map.lookup i (metaVars state) of
+            Just (Bound _ v)              -> zonk (apply g v vs)
+            Just (Residuation _ (Just v)) -> zonk (apply g v vs)
+            _                             -> VMeta i (map zonk vs)
+        zonk (VSusp i k vs)      =
+          case Map.lookup i (metaVars state) of
+            Just (Bound _ v)              -> zonk (apply g (k v) vs)
+            Just (Residuation _ (Just v)) -> zonk (apply g (k v) vs)
+            _                             -> VSusp i k (map zonk vs)
+        zonk v                   = v
 
-     -- record subtyping
-     (RecType rs, RecType ts) -> all (\ (l,a) ->
-                                   any (\ (k,b) -> l == k && alpha g a b) ts) rs
-     (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s'
-     (ExtR r s, t) -> alpha g r t || alpha g s t
+        one t ty state = do
+          t <- withState state (zonkTerm [] t)
+          return ([t],ty)
 
-     -- the following say that Ints n is a subset of Int and of Ints m >= n
-     -- But why does it also allow Int as a subtype of Ints m? /TH 2014-04-04
-     (t,u) | Just m <- isTypeInts t, Just n <- isTypeInts u -> m >= n
-           | Just _ <- isTypeInts t, u == typeInt           -> True ---- check size!
-           | t == typeInt,           Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005
+        join t ty state res = do
+          t <- withState state (zonkTerm [] t)
+          (ts,ty') <- res
+          ty <- supertype scope (Just ty) ty'
+          return (t:ts,ty)
 
-     ---- this should be made in Rename
-     (Q  (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n)
-                                   || elem n (allExtendsPlus gr m)
-                                   || m == n --- for Predef
-     (QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
-                                   || elem n (allExtendsPlus gr m)
-     (QC (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n)
-                                   || elem n (allExtendsPlus gr m)
-     (Q  (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
-                                   || elem n (allExtendsPlus gr m)
+reapply2 :: Scope -> Choice -> Term -> Value -> [(Term,Value,Value)] -> Maybe Rho -> EvalM (Term,Rho)
+reapply2 scope c fun fun_ty []                                mb_ty = instSigma scope c fun fun_ty mb_ty
+reapply2 scope c fun fun_ty ((ImplArg arg,arg_v,arg_ty):args) mb_ty = do -- Implicit arg case
+  (bt, x, arg_ty', res_ty) <- unifyFun scope fun_ty
+  unless (bt == Implicit) $
+     evalError (ppTerm Unqualified 0 (App fun (ImplArg arg)) <+>
+                "is an implicit argument application, but no implicit argument is expected")
+  arg <- subsCheckRho scope arg arg_ty' arg_ty
+  res_ty <- evalCodomain x arg_v res_ty
+  reapply2 scope c (App fun (ImplArg arg)) res_ty args mb_ty
+reapply2 scope c fun fun_ty ((arg,arg_v,arg_ty):args) mb_ty = do -- Explicit arg (fallthrough) case
+  (fun,fun_ty) <- instantiate scope fun fun_ty
+  (_, x, arg_ty', res_ty) <- unifyFun scope fun_ty
+  arg <- subsCheckRho scope arg arg_ty arg_ty'
+  res_ty <- evalCodomain x arg_v res_ty
+  reapply2 scope c (App fun arg) res_ty args mb_ty
 
-     -- contravariance
-     (Table a b,  Table c d)  -> alpha g c a && alpha g b d
-     (Vr x,       Vr y)       -> x == y || elem (x,y) g || elem (y,x) g
-     _                        -> t == u
-     --- the following should be one-way coercions only. AR 4/1/2001
-                                  || elem t sTypes && elem u sTypes
-                                  || (t == typeType && u == typePType)
-                                  || (u == typeType && t == typePType)
+tcPatt scope c PW        ty0 =
+  return scope
+tcPatt scope c (PV x)    ty0 =
+  return ((x,ty0):scope)
+tcPatt scope c (PP q ps) ty0 = do
+  g@(Gl gr _) <- globals
+  ty <- case lookupResType gr q of
+          Ok ty   -> return ty
+          Bad msg -> evalError (pp msg)
+  let go scope c ty []     = return (scope,ty)
+      go scope c ty (p:ps) = do (_,_,arg_ty,res_ty) <- unifyFun scope ty
+                                let (c1,c2) = split c
+                                scope <- tcPatt scope c1 p arg_ty
+                                go scope c2 res_ty ps
+  let (c1,c2) = split c
+  (scope,ty) <- go scope c1 (eval g [] c2 ty []) ps
+  unify scope ty0 ty
+  return scope
+tcPatt scope c (PInt i) ty0 = do
+  subsCheckRho scope (EInt i) (vtypeInts i) ty0
+  return scope
+tcPatt scope c (PString s) ty0 = do
+  unify scope ty0 vtypeStr
+  return scope
+tcPatt scope c PChar ty0 = do
+  unify scope ty0 vtypeStr
+  return scope
+tcPatt scope c (PChars cs) ty0 = do
+  unify scope ty0 vtypeStr
+  return scope
+tcPatt scope c (PSeq _ _ p1 _ _ p2) ty0 = do
+  unify scope ty0 vtypeStr
+  let (c1,c2) = split c
+  scope <- tcPatt scope c1 p1 vtypeStr
+  scope <- tcPatt scope c2 p2 vtypeStr
+  return scope
+tcPatt scope c (PRep _ _ p) ty0 = do
+  unify scope ty0 vtypeStr
+  tcPatt scope c p vtypeStr
+tcPatt scope c (PAs x p) ty0 = do
+  tcPatt ((x,ty0):scope) c p ty0
+tcPatt scope c (PR rs) ty0 = do
+  let mk_ltys []            = return []
+      mk_ltys ((l,p):rs)    = do i <- newResiduation scope
+                                 ltys <- mk_ltys rs
+                                 return ((l,p,VMeta i []) : ltys)
+      go scope c []            = return scope
+      go scope c ((l,p,ty):rs) = do let (c1,c2) = split c
+                                    scope <- tcPatt scope c1 p ty
+                                    go scope c2 rs
+  ltys <- mk_ltys rs
+  subsCheckRho scope (EPatt 0 Nothing (PR rs)) (VRecType [(l,True,ty) | (l,p,ty) <- ltys]) ty0
+  go scope c ltys
+tcPatt scope c (PAlt p1 p2) ty0 = do
+  let (c1,c2) = split c
+  tcPatt scope c1 p1 ty0
+  tcPatt scope c2 p2 ty0
+  return scope
+tcPatt scope c (PM q) ty0 = do
+  g@(Gl gr _) <- globals
+  ty <- case lookupResType gr q of
+          Ok ty   -> return ty
+          Bad msg -> evalError (pp msg)
+  case ty of
+    EPattType ty
+            -> do unify scope ty0 (eval g [] c ty [])
+                  return scope
+    ty   -> evalError ("Pattern type expected but " <+> pp ty <+> " found.")
+tcPatt scope c p ty = unimplemented ("tcPatt "++show p)
 
-   missingLock g t u = case (t,u) of
-     (RecType rs, RecType ts) ->
-       let
-         ls = [l | (l,a) <- rs,
-                   not (any (\ (k,b) -> alpha g a b && l == k) ts)]
-         (locks,others) = partition isLockLabel ls
-       in case others of
-         _:_ -> Bad $ render ("missing record fields:" <+> fsep (punctuate ',' (others)))
-         _ -> return locks
-     -- contravariance
-     (Prod _ x a b, Prod _ y c d) -> do
-        ls1 <- missingLock g c a
-        ls2 <- missingLock g b d
-        return $ ls1 ++ ls2
+inferRecFields scope c rs =
+  mapCM (\c (l,r) -> tcRecField scope c l r Nothing) c rs
 
-     _ -> Bad ""
+checkRecFields scope c []          ltys
+  | null ltys                            = return []
+  | otherwise                            = evalError ("Missing fields:" <+> hsep [l | (l,_,_) <- ltys])
+checkRecFields scope c ((l,t):lts) ltys =
+  case takeIt l ltys of
+    (Just ty,ltys) -> do let (c1,c2) = split c
+                         ltty  <- tcRecField scope c1 l t (Just ty)
+                         lttys <- checkRecFields scope c2 lts ltys
+                         return (ltty : lttys)
+    (Nothing,ltys) -> do evalWarn ("Discarded field:" <+> l)
+                         lttys <- checkRecFields scope c lts ltys
+                         return lttys     -- ignore the field
+  where
+    takeIt l1 []  = (Nothing, [])
+    takeIt l1 (lty@(l2,_,ty):ltys)
+      | l1 == l2  = (Just ty,ltys)
+      | otherwise = let (mb_ty,ltys') = takeIt l1 ltys
+                    in (mb_ty,lty:ltys')
 
-   sTypes = [typeStr, typeTok, typeString]
+tcRecField scope c l (mb_ann_ty,t) mb_ty = do
+  (t,ty) <- case mb_ann_ty of
+              Just ann_ty -> do let (c1,c2,c3,c4) = split4 c
+                                (ann_ty, _) <- tcRho scope c1 ann_ty (Just vtypeType)
+                                g <- globals
+                                let v_ann_ty = eval g (scopeEnv scope) c2 ann_ty []
+                                (t,_) <- tcRho scope c3 t (Just v_ann_ty)
+                                instSigma scope c4 t v_ann_ty mb_ty
+              Nothing     -> tcRho scope c t mb_ty
+  return (l,t,ty)
 
--- auxiliaries
+tcRecTypeFields scope c []          mb_ty = return ([],mb_ty)
+tcRecTypeFields scope c ((l,ty):rs) mb_ty = do
+  let (c1,c2) = split c
+  (ty,sort) <- tcRho scope c1 ty mb_ty
+  mb_ty <- case sort of
+             VSort s
+               | s == cType  -> return (Just sort)
+               | s == cPType -> return mb_ty
+             VMeta _ _       -> return mb_ty
+             _               -> do sort <- value2termM False (scopeVars scope) sort
+                                   evalError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$
+                                              "cannot be of type" <+> ppTerm Unqualified 0 sort)
+  (rs,mb_ty) <- tcRecTypeFields scope c2 rs mb_ty
+  return ((l,ty):rs,mb_ty)
 
--- | light-weight substitution for dep. types
-substituteLType :: Context -> Type -> Check Type
-substituteLType g t = case t of
-  Vr x -> return $ maybe t id $ lookup x [(x,t) | (_,x,t) <- g]
-  _ -> composOp (substituteLType g) t
+-- | Invariant: if the third argument is (Just rho),
+--              then rho is in weak-prenex form
+instSigma :: Scope -> Choice -> Term -> Sigma -> Maybe Rho -> EvalM (Term, Rho)
+instSigma scope s t ty1 Nothing    = return (t,ty1)           -- INST1
+instSigma scope s t ty1 (Just ty2) = do                       -- INST2
+  t <- subsCheckRho scope t ty1 ty2
+  return (t,ty2)
 
-termWith :: Term -> Check Type -> Check (Term, Type)
-termWith t ct = do
-  ty <- ct
+-- | Invariant: the second argument is in weak-prenex form
+subsCheckRho :: Scope -> Term -> Sigma -> Rho -> EvalM Term
+subsCheckRho scope t (VMeta i vs1) (VMeta j vs2)
+  | i  == j   = do sequence_ (zipWith (unify scope) vs1 vs2)
+                   return t
+  | otherwise = do
+      mv <- getMeta i
+      case mv of
+        Bound _ v1 -> do
+          g <- globals
+          subsCheckRho scope t (apply g v1 vs1) (VMeta j vs2)
+        Residuation scope1 (Just ctr1) -> do
+          g <- globals
+          subsCheckRho scope t (apply g ctr1 vs1) (VMeta j vs2)
+        Residuation scope1 Nothing -> do
+          mv <- getMeta j
+          case mv of
+            Bound _ v2 -> do
+              g <- globals
+              subsCheckRho scope t (VMeta i vs1) (apply g v2 vs2)
+            Residuation scope2 ctr2
+              | m > n     -> do setMeta i (Bound scope1 (VMeta j vs2))
+                                return t
+              | otherwise -> case ctr2 of
+                               Nothing   -> do setMeta j (Bound scope2 (VMeta i vs2))
+                                               return t
+                               Just ctr2 -> do g <- globals
+                                               subsCheckRho scope t (VMeta i vs1) (apply g ctr2 vs2)
+              where
+                m = length scope1
+                n = length scope2
+subsCheckRho scope t ty1@(VMeta i vs) ty2 = do
+  mv <- getMeta i
+  case mv of
+    Bound _ ty1 -> do
+      g <- globals
+      subsCheckRho scope t (apply g ty1 vs) ty2
+    Residuation scope' ctr -> do
+      occursCheck scope' i scope ty2
+      ctr <- subtype scope ctr ty2
+      setMeta i (Residuation scope' (Just ctr))
+      return t
+subsCheckRho scope t ty1 ty2@(VMeta i vs) = do
+  mv <- getMeta i
+  case mv of
+    Bound _ ty2 -> do
+      g <- globals
+      subsCheckRho scope t ty1 (apply g ty2 vs)
+    Residuation scope' ctr -> do
+      occursCheck scope' i scope ty1
+      ctr <- supertype scope ctr ty1
+      setMeta i (Residuation scope' (Just ctr))
+      return t
+subsCheckRho scope t (VProd Implicit x ty1 ty2) rho2 = do     -- Rule SPEC
+  i <- newResiduation scope
+  g <- globals
+  let ty2' = case ty2 of
+               VClosure env c ty2 -> eval g ((x,VMeta i []):env) c ty2 []
+               ty2                -> ty2
+  subsCheckRho scope (App t (ImplArg (Meta i))) ty2' rho2
+subsCheckRho scope t rho1 (VProd Implicit x ty1 ty2) = do     -- Rule SKOL
+  let v = newVar scope
+  ty2 <- evalCodomain x (VGen (length scope) []) ty2
+  t <- subsCheckRho ((v,ty1):scope) t rho1 ty2
+  return (Abs Implicit v t)
+subsCheckRho scope t rho1 (VProd Explicit _ a2 r2) = do       -- Rule FUN
+  (_,_,a1,r1) <- unifyFun scope rho1
+  subsCheckFun scope t a1 r1 a2 r2
+subsCheckRho scope t (VProd Explicit _ a1 r1) rho2 = do       -- Rule FUN
+  (_,_,a2,r2) <- unifyFun scope rho2
+  subsCheckFun scope t a1 r1 a2 r2
+subsCheckRho scope t rho1 (VTable p2 r2) = do                 -- Rule TABLE
+  (p1,r1) <- unifyTbl scope rho1
+  subsCheckTbl scope t p1 r1 p2 r2
+subsCheckRho scope t (VTable p1 r1) rho2 = do                 -- Rule TABLE
+  (p2,r2) <- unifyTbl scope rho2
+  subsCheckTbl scope t p1 r1 p2 r2
+subsCheckRho scope t (VSort s1) (VSort s2)                    -- Rule PTYPE
+  | s1 == cPType && s2 == cType = return t
+subsCheckRho scope t (VApp _ p1 []) rho2                      -- for backwards compatibility
+  | p1 == (cPredef,cErrorType) = return t
+subsCheckRho scope t (VApp _ p1 _) (VApp _ p2 _)              -- This is not correct but there is in the RGL nextPrec relies on it.
+  | p1 == (cPredef,cInt) && p2 == (cPredef,cInts) = return t  -- Should be only a temporary hack.
+subsCheckRho scope t (VApp _ p1 _) (VApp _ p2 _)              -- Rule INT1
+  | p1 == (cPredef,cInts) && p2 == (cPredef,cInt) = return t
+subsCheckRho scope t (VApp _ p1 [VInt i]) (VApp _ p2 [VInt j]) -- Rule INT2
+  | p1 == (cPredef,cInts) && p2 == (cPredef,cInts) = do
+      if i <= j
+        then return t
+        else evalError ("Ints" <+> i <+> "is not a subtype of" <+> "Ints" <+> j)
+subsCheckRho scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do      -- Rule REC
+  let mkAccess scope t =
+        case t of
+          ExtR t1 t2 -> do (scope,mkProj1,mkWrap1) <- mkAccess scope t1
+                           (scope,mkProj2,mkWrap2) <- mkAccess scope t2
+                           return (scope
+                                  ,\l -> mkProj2 l `mplus` mkProj1 l
+                                  ,mkWrap1 . mkWrap2
+                                  )
+          R rs -> do sequence_ [evalWarn ("Discarded field:" <+> l) | (l,_) <- rs, isNothing (lookup3 l rs2)]
+                     return (scope
+                            ,\l -> lookup l rs
+                            ,id
+                            )
+          Vr x -> do return (scope
+                            ,\l -> do VRecType rs <- lookup x scope
+                                      ty <- lookup3 l rs
+                                      return (Nothing,P t l)
+                            ,id
+                            )
+          t    -> let x = newVar scope
+                  in return (((x,ty1):scope)
+                            ,\l  -> return (Nothing,P (Vr x) l)
+                            ,Let (x, (Nothing, t))
+                            )
+
+      mkField scope l (mb_ty,t) ty1 ty2 = do
+        t <- subsCheckRho scope t ty1 ty2
+        return (l, (mb_ty,t))
+
+      lookup3 l []  = Nothing
+      lookup3 l ((l',_,v):rs)
+        | l == l'   = Just v
+        | otherwise = lookup3 l rs
+
+  (scope,mkProj,mkWrap) <- mkAccess scope t
+
+  let fields = [(l,ty2,lookup3 l rs1) | (l,o2,ty2) <- rs2]
+  case [l | (l,_,Nothing) <- fields, not (isLockLabel l)] of
+    []      -> return ()
+    missing -> evalError ("In the term" <+> pp t $$
+                          "there are no values for fields:" <+> hsep missing)
+  rs <- sequence [mkField scope l t ty1 ty2 | (l,ty2,Just ty1) <- fields, Just t <- [mkProj l]]
+  return (mkWrap (R (rs++[(l, (Just (RecType []),R [])) | (l,_,Nothing) <- fields, isLockLabel l])))
+subsCheckRho scope t tau1 (VFV c (VarFree vs)) = do
+  tau2 <- variants c vs
+  subsCheckRho scope t tau1 tau2
+subsCheckRho scope t (VFV c (VarFree vs)) tau2 = do
+  tau1 <- variants c vs
+  subsCheckRho scope t tau1 tau2
+subsCheckRho scope t tau1 tau2 = do                           -- Rule EQ
+  unify scope tau1 tau2                                 -- Revert to ordinary unification
+  return t
+
+subsCheckFun :: Scope -> Term -> Sigma -> Value -> Sigma -> Value -> EvalM Term
+subsCheckFun scope t a1 r1 a2 r2 = do
+  let v   = newVar scope
+  vt <- subsCheckRho ((v,a2):scope) (Vr v) a2 a1
+  g  <- globals
+  let r1' = case r1 of
+              VClosure env c r1 -> eval g ((v,(VGen (length scope) [])):env) c r1 []
+              r1                -> r1
+      r2' = case r2 of
+              VClosure env c r2 -> eval g ((v,(VGen (length scope) [])):env) c r2 []
+              r2                -> r2
+  t  <- subsCheckRho ((v,vtypeType):scope) (App t vt) r1' r2'
+  return (Abs Explicit v t)
+
+subsCheckTbl :: Scope -> Term -> Sigma -> Rho -> Sigma -> Rho  -> EvalM Term
+subsCheckTbl scope t p1 r1 p2 r2 = do
+  let x = newVar scope
+  xt <- subsCheckRho ((x,p2):scope) (Vr x) p2 p1
+  t  <- subsCheckRho ((x,p2):scope) (S t xt) r1 r2
+  p2 <- value2termM True (scopeVars scope) p2
+  return (T (TTyped p2) [(PV x,t)])
+
+subtype scope Nothing (VApp c p [VInt i])
+  | p == (cPredef,cInts) = do
+      return (VInts Nothing (Just i))
+subtype scope (Just (VInts i j)) (VApp c p [VInt k])
+  | p == (cPredef,cInts) = do
+      return (VInts j (Just (maybe k (min k) i)))
+subtype scope Nothing (VRecType ltys) = do
+  lctrs <- mapM (\(l,o,ty) -> subtype scope Nothing ty >>= \ctr -> return (l,o,ctr)) ltys
+  return (VRecType lctrs)
+subtype scope (Just (VRecType lctrs1)) (VRecType lctrs2) = do
+  lctrs <- foldM (\lctrs (l,o,ctr) -> union l o ctr lctrs) lctrs1 lctrs2
+  return (VRecType lctrs)
+  where
+    union l o1 ctr1 [] = do ctr <- subtype scope Nothing ctr1
+                            return [(l,True,ctr)]
+    union l o1 ctr1 ((l',o2,ctr2):lctrs)
+      | l == l'   = do ctr <- subtype scope (Just ctr1) ctr2
+                       return ((l,o1||o2,ctr):lctrs)
+      | otherwise = do lctrs <- union l o1 ctr1 lctrs
+                       return ((l',o2,ctr2):lctrs)
+subtype scope (Just (VTable a1 r1)) (VTable a2 r2) = do
+  a <- supertype scope (Just a1) a2
+  r <- subtype scope (Just r1) r2
+  return (VTable a r)
+subtype scope (Just (VProd Explicit x a1 r1)) (VProd Explicit y a2 r2)
+  | x == identW && y == identW = do
+       a <- supertype scope (Just a1) a2
+       r <- subtype scope (Just r1) r2
+       return (VProd Explicit identW a r)
+subtype scope Nothing    ty = return ty
+subtype scope (Just ctr) ty = do
+  unify scope ctr ty
+  return ty
+
+supertype scope Nothing (VApp c p [VInt i])
+  | p == (cPredef,cInts) = do
+      return (VInts (Just i) Nothing)
+supertype scope (Just (VInts i j)) (VApp c p [VInt k])
+  | p == (cPredef,cInts) = do
+      return (VInts (Just (maybe k (max k) i)) j)
+supertype scope Nothing (VRecType ltys) = do
+  lctrs <- mapM (\(l,o,ty) -> supertype scope Nothing ty >>= \ctr -> return (l,False,ctr)) ltys
+  return (VRecType lctrs)
+supertype scope (Just (VRecType lctrs1)) (VRecType lctrs2) = do
+  lctrs <- foldM (\lctrs (l,o,ctr) -> intersect l o ctr lctrs lctrs2) [] lctrs1
+  return (VRecType lctrs)
+  where
+    intersect l o1 ctr1 lctrs [] = return lctrs
+    intersect l o1 ctr1 lctrs ((l',o2,ctr2):lctrs2)
+      | l == l'   = do ctr <- supertype scope (Just ctr1) ctr2
+                       return ((l,o1 && o2,ctr):lctrs)
+      | otherwise = do intersect l o1 ctr1 lctrs lctrs2
+supertype scope (Just (VTable a1 r1)) (VTable a2 r2) = do
+  a <- subtype scope (Just a1) a2
+  r <- supertype scope (Just r1) r2
+  return (VTable a r)
+supertype scope (Just (VProd Explicit x a1 r1)) (VProd Explicit y a2 r2)
+  | x == identW && y == identW = do
+       a <- subtype scope (Just a1) a2
+       r <- supertype scope (Just r1) r2
+       return (VProd Explicit identW a r)
+supertype scope Nothing    ty = return ty
+supertype scope (Just ctr) ty = do
+  unify scope ctr ty
+  return ty
+
+-----------------------------------------------------------------------
+-- Unification
+-----------------------------------------------------------------------
+
+unifyFun :: Scope -> Rho -> EvalM (BindType, Ident, Sigma, Rho)
+unifyFun scope (VProd bt x arg res) =
+  return (bt,x,arg,res)
+unifyFun scope (VFV c (VarFree vs)) = do
+  res <- mapM (unifyFun scope) vs
+  return
+    ( Explicit
+    , identW
+    , VFV c (VarFree [sigma | (_,_,sigma,rho) <- res])
+    , VFV c (VarFree [rho | (_,_,sigma,rho) <- res])
+    )
+unifyFun scope tau = do
+  let mk_val i = VMeta i []
+  arg <- fmap mk_val $ newResiduation scope
+  res <- fmap mk_val $ newResiduation scope
+  let bt = Explicit
+  unify scope tau (VProd bt identW arg res)
+  return (bt,identW,arg,res)
+
+unifyTbl :: Scope -> Rho -> EvalM (Sigma, Rho)
+unifyTbl scope (VTable arg res) =
+  return (arg,res)
+unifyTbl scope tau = do
+  let mk_val i = VMeta i []
+  arg <- fmap mk_val $ newResiduation scope
+  res <- fmap mk_val $ newResiduation scope
+  unify scope tau (VTable arg res)
+  return (arg,res)
+
+unify scope (VApp c1 f1 vs1) (VApp c2 f2 vs2)
+  | f1 == f2  = sequence_ (zipWith (unify scope) vs1 vs2)
+unify scope (VMeta i vs1) (VMeta j vs2)
+  | i  == j   = sequence_ (zipWith (unify scope) vs1 vs2)
+  | otherwise = do 
+      mv <- getMeta i
+      case mv of
+        Bound _ v1 -> do
+          g <- globals
+          unify scope (apply g v1 vs1) (VMeta j vs2)
+        Residuation scope1 _ -> do
+          mv <- getMeta j
+          case mv of
+            Bound _ v2 -> do
+              g <- globals
+              unify scope (VMeta i vs1) (apply g v2 vs2)
+            Residuation scope2 _
+              | m > n     -> setMeta i (Bound scope1 (VMeta j vs2))
+              | otherwise -> setMeta j (Bound scope2 (VMeta i vs2))
+              where
+                m = length scope1
+                n = length scope2 
+unify scope (VMeta i vs) v = unifyVar scope i vs v
+unify scope v (VMeta i vs) = unifyVar scope i vs v
+unify scope (VGen i vs1)       (VGen j vs2)
+  | i == j                     = sequence_ (zipWith (unify scope) vs1 vs2)
+unify scope (VProd b x d cod) (VProd b' x' d' cod')
+  | b == b'                    = do
+      unify scope d d'
+      cod  <- evalCodomain x  (VGen (length scope) []) cod
+      cod' <- evalCodomain x' (VGen (length scope) []) cod'
+      unify scope cod cod'
+unify scope (VTable p1 res1) (VTable p2 res2) = do
+  unify scope p2   p1
+  unify scope res1 res2
+unify scope (VSort s1) (VSort s2)
+  | s1 == s2                   = return ()
+unify scope (VInt i)  (VInt j)
+  | i == j                     = return ()
+unify scope (VFlt x)  (VFlt y)
+  | x == y                     = return ()
+unify scope (VStr s1) (VStr s2)
+  | s1 == s2                   = return ()
+unify scope VEmpty VEmpty      = return ()
+unify scope v1 v2 = do
+  t1 <- value2termM False (scopeVars scope) v1
+  t2 <- value2termM False (scopeVars scope) v2
+  evalError ("Cannot unify:" <+> ppTerm Terse 0 t1 $$
+             "        with:" <+> ppTerm Terse 0 t2)
+
+
+-- | Invariant: tv1 is a flexible type variable
+unifyVar :: Scope -> MetaId -> [Value] -> Tau -> EvalM ()
+unifyVar scope metaid vs ty2 = do            -- Check whether i is bound
+  mv <- getMeta metaid
+  case mv of
+    Bound _ ty1          -> do g <- globals
+                               unify scope (apply g ty1 vs) ty2
+    Residuation scope' _ -> do occursCheck scope' metaid scope ty2
+                               setMeta metaid (Bound scope' ty2)
+
+occursCheck scope' i0 scope v =
+  let m = length scope'
+      n = length scope
+  in check m n v
+  where
+    check m n (VApp c f vs) = mapM_ (check m n) vs
+    check m n (VMeta i vs)
+      | i0 == i  = do ty1 <- value2termM False (scopeVars scope) (VMeta i vs)
+                      ty2 <- value2termM False (scopeVars scope) v
+                      evalError ("Occurs check for" <+> ppTerm Unqualified 0 ty1 <+> "in:" $$
+                                 nest 2 (ppTerm Unqualified 0 ty2))
+      | otherwise = do
+          s <- getMeta i
+          case s of
+            Bound _ v -> do g <- globals
+                            check m n (apply g v vs)
+            _         -> mapM_ (check m n) vs
+    check m n (VGen i vs)
+      | i > m     = let (v,_) = reverse scope !! i
+                    in evalError ("Variable" <+> pp v <+> "has escaped")
+      | otherwise = mapM_ (check m n) vs
+    check m n (VClosure env c (Abs bt x t)) = do
+      g <- globals
+      check (m+1) (n+1) (eval g ((x,VGen n []):env) c t [])
+    check m n (VProd bt x ty1 ty2) = do
+      check m n ty1
+      case ty2 of
+        VClosure env c t -> do g <- globals
+                               check (m+1) (n+1) (eval g ((x,VGen n []):env) c t [])
+        _                -> check m n ty2
+    check m n (VRecType as) =
+      mapM_ (\(_,_,v) -> check m n v) as
+    check m n (VR as) =
+      mapM_ (\(lbl,v) -> check m n v) as
+    check m n (VP v l vs) =
+      check m n v >> mapM_ (check m n) vs
+    check m n (VExtR v1 v2) =
+      check m n v1 >> check m n v2
+    check m n (VTable v1 v2) =
+      check m n v1 >> check m n v2
+    check m n (VT ty env c cs) =
+      check m n ty      -- Traverse cs as well
+    check m n (VV ty cs) =
+      check m n ty >> mapM_ (check m n) cs
+    check m n (VS v1 v2 vs) =
+      check m n v1 >> check m n v2 >> mapM_ (check m n) vs
+    check m n (VSort _) = return ()
+    check m n (VInt _) = return ()
+    check m n (VFlt _) = return ()
+    check m n (VStr _) = return ()
+    check m n VEmpty   = return ()
+    check m n (VC v1 v2) =
+      check m n v1 >> check m n v2
+    check m n (VGlue v1 v2) =
+      check m n v1 >> check m n v2
+    check m n (VPatt _ _ _) = return ()
+    check m n (VPattType v) =
+      check m n v
+    check m n (VFV c vs) =
+      mapM_ (check m n) (unvariants vs)
+    check m n (VAlts v vs) =
+      check m n v >> mapM_ (\(v1,v2) -> check m n v1 >> check m n v2) vs
+    check m n (VStrs vs) =
+      mapM_ (check m n) vs
+    check m n (VInts _ _) = return ()
+
+-----------------------------------------------------------------------
+-- Instantiation and quantification
+-----------------------------------------------------------------------
+
+-- | Instantiate the topmost implicit arguments with metavariables
+instantiate :: Scope -> Term -> Sigma -> EvalM (Term,Rho)
+instantiate scope t (VProd Implicit x ty1 ty2) = do
+  i <- newResiduation scope
+  ty2 <- case ty2 of
+           VClosure env c ty2 -> do g <- globals
+                                    return (eval g ((x,VMeta i []):env) c ty2 [])
+           ty2                -> return ty2
+  instantiate scope (App t (ImplArg (Meta i))) ty2
+instantiate scope t ty@(VMeta i args) = getMeta i >>= \case
+  Bound _ v              -> instantiate scope t v
+  Residuation _ (Just v) -> instantiate scope t v
+  _                      -> return (t,ty) -- We don't have enough information to try any instantiation
+instantiate scope t ty = do
   return (t,ty)
 
--- | compositional check\/infer of binary operations
-check2 :: (Term -> Check Term) -> (Term -> Term -> Term) ->
-          Term -> Term -> Type -> Check (Term,Type)
-check2 chk con a b t = do
-  a' <- chk a
-  b' <- chk b
-  return (con a' b', t)
+-- | Build fresh lambda abstractions for the topmost implicit arguments
+skolemise :: Scope -> Sigma -> EvalM (Scope, Term->Term, Rho)
+skolemise scope ty@(VMeta i vs) = do
+  mv <- getMeta i
+  case mv of
+    Residuation _ _ -> return (scope,id,ty)                   -- guarded constant?
+    Bound _ ty      -> do g <- globals
+                          skolemise scope (apply g ty vs)
+skolemise scope (VProd Implicit x ty1 ty2) = do
+  let v = newVar scope
+  ty2 <- evalCodomain x (VGen (length scope) []) ty2
+  (scope,f,ty2) <- skolemise ((v,ty1):scope) ty2
+  return (scope,Abs Implicit v . f,ty2)
+skolemise scope ty = do
+  return (scope,id,ty)
 
--- printing a type with a lock field lock_C as C
-ppType :: Type -> Doc
-ppType ty =
-  case ty of
-    RecType fs   -> case filter isLockLabel $ map fst fs of
-                      [lock] -> pp (drop 5 (showIdent (label2ident lock)))
-                      _      -> ppTerm Unqualified 0 ty
-    Prod _ x a b -> ppType a <+> "->" <+> ppType b
-    _            -> ppTerm Unqualified 0 ty
+-- | Quantify over the specified type variables (all flexible)
+quantify :: Scope -> Term -> [MetaId] -> Rho -> EvalM (Term,Sigma)
+quantify scope t tvs ty = do
+  let m = length tvs
+      n = length scope
+  (used_bndrs,ty) <- check m n [] ty
+  let new_bndrs  = take m (allBinders \\ used_bndrs)
+  mapM_ (bind ([(var,VSort cType)|var <- new_bndrs]++scope)) (zip3 [0..] tvs new_bndrs)
+  let ty' = foldr (\ty -> VProd Implicit ty vtypeType) ty new_bndrs
+  return (foldr (Abs Implicit) t new_bndrs,ty')
+  where
+    bind scope (i, meta_id, name) = setMeta meta_id (Bound scope (VGen i []))
 
-checkLookup :: Ident -> Context -> Check Type
-checkLookup x g =
-  case [ty | (b,y,ty) <- g, x == y] of
-    []     -> checkError ("unknown variable" <+> x)
-    (ty:_) -> return ty
+    check m n xs (VApp c f vs)     = do
+      (xs,vs) <- mapAccumM (check m n) xs vs
+      return (xs,VApp c f vs)
+    check m n xs (VMeta i vs)      = do
+      s <- getMeta i
+      case s of
+        Bound _ v -> do g <- globals
+                        check m n xs (apply g v vs)
+        _         -> do (xs,vs) <- mapAccumM (check m n) xs vs
+                        return (xs,VMeta i vs)
+    check m n st (VGen i vs)= do
+      (st,vs) <- mapAccumM (check m n) st vs
+      return (st, VGen (m+i) vs)
+    check m n st (VClosure env c (Abs bt x t)) = do
+      (st,env) <- mapAccumM (\st (x,v) -> check m n st v >>= \(st,v) -> return (st,(x,v))) st env
+      return (st,VClosure env c (Abs bt x t))
+    check m n xs (VProd bt x v1 v2) = do
+      (xs,v1) <- check m n xs v1
+      case v2 of
+        VClosure env c t -> do (st,env) <- mapAccumM (\xs (x,tnk) -> check m n xs tnk >>= \(xs,tnk) -> return (xs,(x,tnk))) xs env
+                               return (x:xs,VProd bt x v1 (VClosure env c t))
+        v2               -> do (xs,v2) <- check m (n+1) xs v2
+                               return (x:xs,VProd bt x v1 v2)
+    check m n xs (VRecType as)     = do
+      (xs,as) <- mapAccumM (\xs (l,o,v) -> check m n xs v >>= \(xs,v) -> return (xs,(l,o,v))) xs as
+      return (xs,VRecType as)
+    check m n xs (VR as)           = do
+      (xs,as) <- mapAccumM (\xs (lbl,tnk) -> check m n xs tnk >>= \(xs,tnk) -> return (xs,(lbl,tnk))) xs as
+      return (xs,VR as)
+    check m n xs (VP v l vs)       = do
+      (xs,v)  <- check m n xs v
+      (xs,vs) <- mapAccumM (check m n) xs vs
+      return (xs,VP v l vs)
+    check m n xs (VExtR v1 v2)     = do
+      (xs,v1) <- check m n xs v1
+      (xs,v2) <- check m n xs v2
+      return (xs,VExtR v1 v2)
+    check m n xs (VTable v1 v2)    = do
+      (xs,v1) <- check m n xs v1
+      (xs,v2) <- check m n xs v2
+      return (xs,VTable v1 v2)
+    check m n xs (VT ty env c cs)    = do
+      (xs,ty) <- check m n xs ty
+      (xs,env) <- mapAccumM (\xs (x,tnk) -> check m n xs tnk >>= \(xs,tnk) -> return (xs,(x,tnk))) xs env
+      return (xs,VT ty env c cs)
+    check m n xs (VV ty cs)        = do
+      (xs,ty) <- check m n xs ty
+      (xs,cs) <- mapAccumM (check m n) xs cs
+      return (xs,VV ty cs)
+    check m n xs (VS v1 tnk vs)    = do
+      (xs,v1)  <- check m n xs v1
+      (xs,tnk) <- check m n xs tnk
+      (xs,vs)  <- mapAccumM (check m n) xs vs
+      return (xs,VS v1 tnk vs)
+    check m n xs v@(VSort _)       = return (xs,v)
+    check m n xs v@(VInt _)        = return (xs,v)
+    check m n xs v@(VFlt _)        = return (xs,v)
+    check m n xs v@(VStr _)        = return (xs,v)
+    check m n xs v@VEmpty          = return (xs,v)
+    check m n xs (VC v1 v2)        = do
+      (xs,v1) <- check m n xs v1
+      (xs,v2) <- check m n xs v2
+      return (xs,VC v1 v2)
+    check m n xs (VGlue v1 v2)        = do
+      (xs,v1) <- check m n xs v1
+      (xs,v2) <- check m n xs v2
+      return (xs,VGlue v1 v2)
+    check m n xs v@(VPatt _ _ _)   = return (xs,v)
+    check m n xs (VPattType v)     = do
+      (xs,v) <- check m n xs v
+      return (xs,VPattType v)
+    check m n xs (VFV c (VarFree vs)) = do
+      (xs,vs) <- mapAccumM (check m n) xs vs
+      return (xs,VFV c (VarFree vs))
+    check m n xs (VFV c (VarOpts name os)) = do
+      (xs,os) <- mapAccumM (\acc (l,v) -> second (l,) <$> check m n acc v) xs os
+      return (xs,VFV c (VarOpts name os))
+    check m n xs (VAlts v vs)      = do
+      (xs,v)  <- check m n xs v
+      (xs,vs) <- mapAccumM (\xs (v1,v2) -> do (xs,v1) <- check m n xs v1
+                                              (xs,v2) <- check m n xs v2
+                                              return (xs,(v1,v2)))
+                           xs vs
+      return (xs,VAlts v vs)
+    check m n xs (VStrs vs)        = do
+      (xs,vs) <- mapAccumM (check m n) xs vs
+      return (xs,VStrs vs)
+    check m n xs v = unimplemented ("check "++show (ppValue Unqualified 5 v))
+
+    mapAccumM :: Monad m => (a -> b -> m (a,c)) -> a -> [b] -> m (a,[c])
+    mapAccumM f s []     = return (s,[])
+    mapAccumM f s (x:xs) = do
+      (s,y)  <- f s x
+      (s,ys) <- mapAccumM f s xs
+      return (s,y:ys)
+
+allBinders :: [Ident]    -- a,b,..z, a1, b1,... z1, a2, b2,...
+allBinders = [ identS [x]          | x <- ['a'..'z'] ] ++
+             [ identS (x : show i) | i <- [1 :: Integer ..], x <- ['a'..'z']]
+
+-----------------------------------------------------------------------
+-- Helpers
+-----------------------------------------------------------------------
+
+type Sigma = Value
+type Rho   = Value -- No top-level ForAll
+type Tau   = Value -- No ForAlls anywhere
+
+unimplemented str = fail ("Unimplemented: "++str)
+
+newVar :: Scope -> Ident
+newVar scope = head [x | i <- [1..],
+                         let x = identS ('v':show i),
+                         isFree scope x]
+  where
+    isFree []            x = True
+    isFree ((y,_):scope) x = x /= y && isFree scope x
+
+scopeEnv   scope = zipWith (\(x,ty) i -> (x,VGen i [])) (reverse scope) [0..]
+scopeVars  scope = map fst scope
+scopeTypes scope = zipWith (\(_,ty) scope -> (scope,ty)) scope (tails scope)
+
+-- | This function takes account of zonking, and returns a set
+-- (no duplicates) of unbound meta-type variables
+getMetaVars :: [(Scope,Sigma)] -> EvalM [MetaId]
+getMetaVars sc_tys = foldM (\acc (scope,ty) -> go acc ty) [] sc_tys
+  where
+    -- Get the MetaIds from a term; no duplicates in result
+    go acc (VGen i args)     = foldM go acc args
+    go acc (VSort s)         = return acc
+    go acc (VInt _)          = return acc
+    go acc (VRecType vs)    = foldM (\acc (lbl,_,v) -> go acc v) acc vs
+    go acc (VClosure _ _ _)  = return acc
+    go acc (VProd b x v1 v2) = go acc v2 >>= \acc -> go acc v1
+    go acc (VTable v1 v2)    = go acc v2 >>= \acc -> go acc v1
+    go acc (VMeta m args)
+      | m `elem` acc         = return acc
+      | otherwise            = do res <- getMeta m
+                                  case res of
+                                    Bound _ v              -> go acc v
+                                    Residuation _ Nothing  -> foldM go (m:acc) args
+                                    Residuation _ (Just v) -> go acc v
+                                    _                      -> return acc
+    go acc (VApp c f args)   = foldM go acc args
+    go acc (VFV c vs)        = foldM go acc (unvariants vs)
+    go acc (VInts _ _)      = return acc
+    go acc v                 = unimplemented ("go "++show (ppValue Unqualified 5 v))
+
+-- | Eliminate any substitutions in a term
+zonkTerm :: [Ident] -> Term -> EvalM Term
+zonkTerm xs (Abs b x t) = do
+  t <- zonkTerm (x:xs) t
+  return (Abs b x t)
+zonkTerm xs (Prod b x t1 t2) = do
+  t1 <- zonkTerm xs  t1
+  t2 <- zonkTerm xs' t2
+  return (Prod b x t1 t2)
+  where
+    xs' | x == identW = xs
+        | otherwise   = x:xs
+zonkTerm xs (Meta i) = do
+  st <- getMeta i
+  case st of
+    Bound _ v           -> zonkTerm xs =<< value2termM False xs v
+    Residuation scope v -> case v of
+                            Just v  -> zonkTerm xs =<< value2termM False (map fst scope) v
+                            Nothing -> return (Meta i)
+    Narrowing _         -> return (Meta i)
+zonkTerm xs t = composOp (zonkTerm xs) t
diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
deleted file mode 100644
index 9a0452ac1..000000000
--- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
+++ /dev/null
@@ -1,1309 +0,0 @@
-{-# LANGUAGE RankNTypes, CPP, TupleSections, LambdaCase #-}
-module GF.Compile.TypeCheck.ConcreteNew ( checkLType, checkLType', inferLType, inferLType' ) where
-
--- The code here is based on the paper:
--- Simon Peyton Jones, Dimitrios Vytiniotis, Stephanie Weirich.
--- Practical type inference for arbitrary-rank types.
--- 14 September 2011
-
-import GF.Grammar hiding (Env, VGen, VApp, VRecType, ppValue)
-import GF.Grammar.Lookup
-import GF.Grammar.Predef
-import GF.Grammar.Lockfield
-import GF.Compile.Compute.Concrete2
-import GF.Infra.CheckM
-import GF.Data.ErrM ( Err(Ok, Bad) )
-import Control.Applicative(Applicative(..))
-import Control.Monad(ap,liftM,mplus,foldM,zipWithM,forM,filterM,unless)
-import Control.Monad.ST
-import GF.Text.Pretty
-import Data.STRef
-import Data.List (nub, (\\), tails)
-import qualified Data.Map as Map
-import Data.Maybe(fromMaybe,isNothing,mapMaybe)
-import Data.Bifunctor(second)
-import Data.Functor((<&>))
-import qualified Control.Monad.Fail as Fail
-
-checkLType :: Globals -> Term -> Type -> Check (Term, Type)
-checkLType globals t ty = do
-  res <- runEvalM globals $ do
-            let (c1,c2) = split unit
-            (t,vty) <- checkLType' c1 t (eval globals [] c2 ty [])
-            ty <- value2termM True [] vty
-            return (t,ty)
-  case res of
-    [tty] -> return tty
-    _     -> checkError (pp "Encountered variants while type checking")
-
-checkLType' :: Choice -> Term -> Constraint -> EvalM (Term, Constraint)
-checkLType' c t vty = do
-  (t,vty) <- tcRho [] c t (Just vty)
-  t <- zonkTerm [] t
-  return (t,vty)
-
-inferLType :: Globals -> Term -> Check (Term, Type)
-inferLType globals t = do
-  res <- runEvalM globals $ do
-            (t,vty) <- inferLType' t
-            ty <- value2termM True [] vty
-            return (t,ty)
-  case res of
-    [tty] -> return tty
-    _     -> checkError (pp "Encountered variants while type checking")
-
-inferLType' :: Term -> EvalM (Term, Constraint)
-inferLType' t = do
-  (t,vty) <- inferSigma [] unit t
-  t <- zonkTerm [] t
-  return (t,vty)
-
-inferSigma :: Scope -> Choice -> Term -> EvalM (Term,Sigma)
-inferSigma scope s t = do                                      -- GEN1
-  (t,ty) <- tcRho scope s t Nothing
-  env_tvs <- getMetaVars (scopeTypes scope)
-  res_tvs <- getMetaVars [(scope,ty)]
-  let forall_tvs = res_tvs \\ env_tvs
-  quantify scope t forall_tvs ty
-
-vtypeInt   = VApp poison (cPredef,cInt) []
-vtypeFloat = VApp poison (cPredef,cFloat) []
-vtypeInts i= VApp poison (cPredef,cInts) [VInt i]
-vtypeStr   = VSort cStr
-vtypeStrs  = VSort cStrs
-vtypeType  = VSort cType
-vtypePType = VSort cPType
-vtypeMarkup= VApp poison (cPredef,cMarkup) []
-
-tcRho :: Scope -> Choice -> Term -> Maybe Rho -> EvalM (Term, Rho)
-tcRho scope s t@(EInt i)   mb_ty = instSigma scope s t (vtypeInts i) mb_ty -- INT
-tcRho scope s t@(EFloat _) mb_ty = instSigma scope s t vtypeFloat mb_ty    -- FLOAT
-tcRho scope s t@(K _)      mb_ty = instSigma scope s t vtypeStr   mb_ty    -- STR
-tcRho scope s t@(Empty)    mb_ty = instSigma scope s t vtypeStr   mb_ty
-tcRho scope s t@(Vr v)     mb_ty = do                          -- VAR
-  case lookup v scope of
-    Just v_sigma -> instSigma scope s t v_sigma mb_ty
-    Nothing      -> evalError ("Unknown variable" <+> v)
-tcRho scope c t@(Q id)     mb_ty = tcApp scope c t t [] mb_ty
-tcRho scope c t@(QC id)    mb_ty = tcApp scope c t t [] mb_ty
-tcRho scope c t@(App fun arg) mb_ty = tcApp scope c t t [] mb_ty
-tcRho scope c (Abs bt var body) Nothing = do                   -- ABS1
-  i <- newResiduation scope
-  let arg_ty = VMeta i []
-  (body,body_ty) <- tcRho ((var,arg_ty):scope) c body Nothing
-  let m = length scope
-      n = m+1
-  (b,used_bndrs) <- check m n (False,[]) body_ty
-  if b
-    then let v = head (allBinders \\ used_bndrs)
-         in return (Abs bt var body, (VProd bt v arg_ty body_ty))
-    else return (Abs bt var body, (VProd bt identW arg_ty body_ty))
-  where
-    check m n st (VApp c f vs)     = foldM (check m n) st vs
-    check m n st (VMeta i vs)      = do
-      state <- getMeta i
-      case state of
-        Bound _ v -> do g <- globals
-                        check m n st (apply g v vs)
-        _         -> foldM (check m n) st vs
-    check m n st@(b,xs) (VGen i vs)
-      | i == m                       = return (True, xs)
-      | otherwise                    = return st
-    check m n st (VClosure env c (Abs bt x t)) = do
-      g <- globals
-      check m (n+1) st (eval g ((x,VGen n []):env) c t [])
-    check m n st (VProd _ x v1 v2) = do
-      st@(b,xs) <- check m n st v1
-      case v2 of
-        VClosure env c t -> do g  <- globals
-                               check m (n+1) (b,x:xs) (eval g ((x,VGen n []):env) c t [])
-        v2               -> check m n st v2
-    check m n st (VRecType as)     = foldM (\st (l,_,v) -> check m n st v) st as
-    check m n st (VR as)           =
-      foldM (\st (lbl,tnk) -> check m n st tnk) st as
-    check m n st (VP v l vs)       =
-      check m n st v >>= \st -> foldM (check m n) st vs
-    check m n st (VExtR v1 v2)     =
-      check m n st v1 >>= \st -> check m n st v2
-    check m n st (VTable v1 v2)    =
-      check m n st v1 >>= \st -> check m n st v2
-    check m n st (VT ty env c cs) =
-      check m n st ty    -- Traverse cs as well
-    check m n st (VV ty cs)        =
-      check m n st ty >>= \st -> foldM (check m n) st cs
-    check m n st (VS v1 tnk vs)    = do
-      st <- check m n st v1
-      st <- check m n st tnk
-      foldM (check m n) st vs
-    check m n st (VSort _)         = return st
-    check m n st (VInt _)          = return st
-    check m n st (VFlt _)          = return st
-    check m n st (VStr _)          = return st
-    check m n st VEmpty            = return st
-    check m n st (VC v1 v2)        =
-      check m n st v1 >>= \st -> check m n st v2
-    check m n st (VGlue v1 v2)     =
-      check m n st v1 >>= \st -> check m n st v2
-    check m n st (VPatt _ _ _)     = return st
-    check m n st (VPattType v)     = check m n st v
-    check m n st (VAlts v vs)      = do
-      st <- check m n st v
-      foldM (\st (v1,v2) -> check m n st v1 >>= \st -> check m n st v2) st vs
-    check m n st (VStrs vs)        =
-      foldM (check m n) st vs
-tcRho scope c t@(Abs Implicit var body) (Just ty) = do         -- ABS2
-  (bt, x, var_ty, body_ty) <- unifyFun scope ty
-  if bt == Implicit
-    then return ()
-    else evalError (ppTerm Unqualified 0 t <+> "is an implicit function, but no implicit function is expected")
-  body_ty <- evalCodomain x (VGen (length scope) []) body_ty
-  (body, body_ty) <- tcRho ((var,var_ty):scope) c body (Just body_ty)
-  return (Abs Implicit var body,ty)
-tcRho scope c (Abs Explicit var body) (Just ty) = do           -- ABS3
-  (scope,f,ty') <- skolemise scope ty
-  (_,x,var_ty,body_ty) <- unifyFun scope ty'
-  body_ty <- evalCodomain x (VGen (length scope) []) body_ty
-  (body, body_ty) <- tcRho ((var,var_ty):scope) c body (Just body_ty)
-  return (f (Abs Explicit var body),ty)
-tcRho scope c (Meta _) mb_ty = do
-  i <- newResiduation scope
-  ty <- case mb_ty of
-          Just ty -> return ty
-          Nothing -> do j <- newResiduation scope
-                        return (VMeta j [])
-  return (Meta i, ty)
-tcRho scope c (Let (var, (Nothing, rhs)) body) mb_ty = do      -- LET
-  let (c1,c2) = split c
-  (rhs,var_ty) <- tcRho scope c1 rhs Nothing
-  (body, body_ty) <- tcRho ((var,var_ty):scope) c2 body mb_ty
-  var_ty <- value2termM True (scopeVars scope) var_ty
-  return (Let (var, (Just var_ty, rhs)) body, body_ty)
-tcRho scope c (Let (var, (Just ann_ty, rhs)) body) mb_ty = do  -- LET
-  let (c1,c2,c3,c4) = split4 c
-  (ann_ty, _) <- tcRho scope c1 ann_ty (Just vtypeType)
-  g <- globals
-  let v_ann_ty = eval g (scopeEnv scope) c2 ann_ty []
-  (rhs,_) <- tcRho scope c3 rhs (Just v_ann_ty)
-  (body, body_ty) <- tcRho ((var,v_ann_ty):scope) c4 body mb_ty
-  var_ty <- value2termM True (scopeVars scope) v_ann_ty
-  return (Let (var, (Just var_ty, rhs)) body, body_ty)
-tcRho scope c (Typed body ann_ty) mb_ty = do                   -- ANNOT
-  let (c1,c2,c3,c4) = split4 c
-  (ann_ty, _) <- tcRho scope c1 ann_ty (Just vtypeType)
-  g <- globals
-  let v_ann_ty = eval g (scopeEnv scope) c2 ann_ty []
-  (body,_) <- tcRho scope c3 body (Just v_ann_ty)
-  instSigma scope c4 (Typed body ann_ty) v_ann_ty mb_ty
-tcRho scope c (FV ts) mb_ty = do
-  (ts,ty) <- tcUnifying scope c ts mb_ty
-  return (FV ts, ty)
-tcRho scope s t@(Sort _) mb_ty = do
-  instSigma scope s t vtypeType mb_ty
-tcRho scope c t@(RecType rs) Nothing   = do
-  (rs,mb_ty) <- tcRecTypeFields scope c rs Nothing
-  return (RecType rs,fromMaybe vtypePType mb_ty)
-tcRho scope c t@(RecType rs) (Just ty) = do
-  (scope,f,ty') <- skolemise scope ty
-  case ty' of
-    VSort s
-      | s == cType  -> return ()
-      | s == cPType -> return ()
-    VMeta i vs-> case rs of
-                   [] -> unifyVar scope i vs vtypePType
-                   _  -> return ()
-    ty        -> do ty <- value2termM False (scopeVars scope) ty
-                    evalError ("The record type" <+> ppTerm Unqualified 0 t $$
-                               "cannot be of type" <+> ppTerm Unqualified 0 ty)
-  (rs,mb_ty) <- tcRecTypeFields scope c rs (Just ty')
-  return (f (RecType rs),ty)
-tcRho scope s t@(Table p res) mb_ty = do
-  let (s1,s23) = split s
-      (s2,s3)  = split s23
-  (p,  p_ty)   <- tcRho scope s1 p   (Just vtypePType)
-  (res,res_ty) <- tcRho scope s2 res (Just vtypeType)
-  instSigma scope s3 (Table p res) vtypeType mb_ty
-tcRho scope c (Prod bt x ty1 ty2) mb_ty = do
-  let (c1,c2,c3,c4) = split4 c
-  (ty1,ty1_ty) <- tcRho scope c1 ty1 (Just vtypeType)
-  g <- globals
-  (ty2,ty2_ty) <- tcRho ((x,eval g (scopeEnv scope) c2 ty1 []):scope) c3 ty2 (Just vtypeType)
-  instSigma scope c4 (Prod bt x ty1 ty2) vtypeType mb_ty
-tcRho scope c (S t p) mb_ty = do
-  let (c1,c2) = split c
-  let mk_val i = VMeta i []
-  p_ty   <- fmap mk_val $ newResiduation scope
-  res_ty <- case mb_ty of
-              Nothing -> fmap mk_val $ newResiduation scope
-              Just ty -> return ty
-  let t_ty = VTable p_ty res_ty
-  (t,t_ty) <- tcRho scope c1 t (Just t_ty)
-  (p,_) <- tcRho scope c2 p (Just p_ty)
-  return (S t p, res_ty)
-tcRho scope c (T tt ps) Nothing = do                           -- ABS1/AABS1 for tables
-  let (c1,c2) = split c
-  let mk_val i = VMeta i []
-  p_ty   <- case tt of
-              TRaw      -> fmap mk_val $ newResiduation scope
-              TTyped ty -> do let (c3,c4) = split c1
-                              (ty, _) <- tcRho scope c3 ty (Just vtypeType)
-                              g <- globals
-                              return (eval g (scopeEnv scope) c4 ty [])
-  res_ty <- fmap mk_val $ newResiduation scope
-  ps <- tcCases scope c2 ps p_ty res_ty
-  p_ty_t <- value2termM True [] p_ty
-  return (T (TTyped p_ty_t) ps, VTable p_ty res_ty)
-tcRho scope c (T tt ps) (Just ty) = do                         -- ABS2/AABS2 for tables
-  let (c12,c34) = split c
-      (c3,c4)   = split c34
-  (scope,f,ty') <- skolemise scope ty
-  (p_ty, res_ty) <- unifyTbl scope ty'
-  case tt of
-    TRaw      -> return ()
-    TTyped ty -> do let (c1,c2) = split c12
-                    (ty, _) <- tcRho scope c1 ty (Just vtypeType)
-                    g <- globals
-                    unify scope (eval g (scopeEnv scope) c2 ty []) p_ty
-  ps <- tcCases scope c3 ps p_ty res_ty
-  p_ty_t <- value2termM True (scopeVars scope) p_ty
-  return (f (T (TTyped p_ty_t) ps), VTable p_ty res_ty)
-tcRho scope c (V p_ty ts) Nothing = do
-  let (c1,c2,c3,c4) = split4 c
-  (p_ty, _) <- tcRho scope c1 p_ty (Just vtypeType)
-  i <- newResiduation scope
-  let res_ty = VMeta i []
-
-  let go c t = do (t, ty) <- tcRho scope c t Nothing
-                  subsCheckRho scope t ty res_ty
-
-  ts <- mapCM go c2 ts
-  g <- globals
-  return (V p_ty ts, VTable (eval g (scopeEnv scope) c3 p_ty []) res_ty)
-tcRho scope c (V p_ty0 ts) (Just ty) = do
-  let (c1,c2,c3,c4) = split4 c
-  (scope,f,ty') <- skolemise scope ty
-  (p_ty, res_ty) <- unifyTbl scope ty'
-  (p_ty0, _) <- tcRho scope c1 p_ty0 (Just vtypeType)
-  g <- globals
-  let p_vty0 = eval g (scopeEnv scope) c2 p_ty0 []
-  unify scope p_ty p_vty0
-  ts <- mapCM (\c t -> fmap fst $ tcRho scope c t (Just res_ty)) c3 ts
-  return (V p_ty0 ts, VTable p_ty res_ty)
-tcRho scope c (R rs) Nothing = do
-  lttys <- inferRecFields scope c rs
-  rs <- mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
-  return (R        rs,
-          VRecType [(l,True,ty) | (l,t,ty) <- lttys]
-         )
-tcRho scope c (R rs) (Just ty) = do
-  (scope,f,ty') <- skolemise scope ty
-  case ty' of
-    (VRecType ltys) -> do lttys <- checkRecFields scope c rs ltys
-                          rs <- mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
-                          return ((f . R)  rs,
-                                  VRecType [(l,True,ty) | (l,t,ty) <- lttys]
-                                 )
-    ty              -> do lttys <- inferRecFields scope c rs
-                          t <- liftM (f . R) (mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys)
-                          let ty' = VRecType [(l,True,ty) | (l,t,ty) <- lttys]
-                          t <- subsCheckRho scope t ty' ty
-                          return (t, ty')
-tcRho scope c (P t l) mb_ty = do
-  l_ty   <- case mb_ty of
-              Just ty -> return ty
-              Nothing -> do i <- newResiduation scope
-                            return (VMeta i [])
-  (t,t_ty) <- tcRho scope c t (Just (VRecType [(l,True,l_ty)]))
-  return (P t l,l_ty)
-tcRho scope c (C t1 t2) mb_ty = do
-  let (c1,c2,c3,c4) = split4 c
-  (t1,t1_ty) <- tcRho scope c1 t1 (Just vtypeStr)
-  (t2,t2_ty) <- tcRho scope c2 t2 (Just vtypeStr)
-  instSigma scope c3 (C t1 t2) vtypeStr mb_ty
-tcRho scope c (Glue t1 t2) mb_ty = do
-  let (c1,c2,c3,c4) = split4 c
-  (t1,t1_ty) <- tcRho scope c1 t1 (Just vtypeStr)
-  (t2,t2_ty) <- tcRho scope c2 t2 (Just vtypeStr)
-  instSigma scope c3 (Glue t1 t2) vtypeStr mb_ty
-tcRho scope c t@(ExtR t1 t2) mb_ty = do
-  let (c1,c2,c3,c4) = split4 c
-  (t1,t1_ty) <- tcRho scope c1 t1 Nothing
-  (t2,t2_ty) <- tcRho scope c2 t2 Nothing
-  case (t1_ty,t2_ty) of
-    (VSort s1,VSort s2)
-       | (s1 == cType || s1 == cPType) &&
-         (s2 == cType || s2 == cPType) -> let sort | s1 == cPType && s2 == cPType = cPType
-                                                   | otherwise                    = cType
-                                          in instSigma scope c3 (ExtR t1 t2) (VSort sort) mb_ty
-    (VRecType rs1, VRecType rs2)       -> instSigma scope c3 (ExtR t1 t2) (VRecType (rs2++rs1)) mb_ty
-    _                                  -> evalError ("Cannot type check" <+> ppTerm Unqualified 0 t)
-tcRho scope c (ELin cat t) mb_ty = do  -- this could be done earlier, i.e. in the parser
-  tcRho scope c (ExtR t (R [(lockLabel cat,(Just (RecType []),R []))])) mb_ty
-tcRho scope c (ELincat cat t) mb_ty = do  -- this could be done earlier, i.e. in the parser
-  tcRho scope c (ExtR t (RecType [(lockLabel cat,RecType [])])) mb_ty
-tcRho scope c (Alts t ss) mb_ty = do
-  let (c1,c2,c3,c4) = split4 c
-  (t,_) <- tcRho scope c1 t (Just vtypeStr)
-  ss    <- mapCM (\c (t1,t2) -> do
-                          let (c1,c2) = split c
-                          (t1,_) <- tcRho scope c1 t1 (Just vtypeStr)
-                          (t2,_) <- tcRho scope c2 t2 (Just vtypeStrs)
-                          return (t1,t2))
-                 c2 ss
-  instSigma scope c3 (Alts t ss) vtypeStr mb_ty
-tcRho scope c (Strs ss) mb_ty = do
-  let (c1,c2) = split c
-  ss <- mapCM (\c t -> do (t,_) <- tcRho scope c t (Just vtypeStr)
-                          return t)
-              c1 ss
-  instSigma scope c2 (Strs ss) vtypeStrs mb_ty
-tcRho scope c (EPattType ty) mb_ty = do
-  let (c1,c2) = split c
-  (ty, _) <- tcRho scope c1 ty (Just vtypeType)
-  instSigma scope c2 (EPattType ty) vtypeType mb_ty
-tcRho scope c t@(EPatt min max p) mb_ty = do
-  (scope,f,ty) <- case mb_ty of
-                    Nothing -> do i <- newResiduation scope
-                                  return (scope,id,VMeta i [])
-                    Just ty -> do (scope,f,ty) <- skolemise scope ty
-                                  case ty of
-                                    VPattType ty -> return (scope,f,ty)
-                                    _            -> evalError (ppTerm Unqualified 0 t <+> "must be of pattern type but" <+> ppTerm Unqualified 0 t <+> "is expected")
-  tcPatt scope c p ty
-  return (f (EPatt min max p), ty)
-tcRho scope c (Markup tag attrs children) mb_ty = do
-  let (c1,c2,c3,c4) = split4 c
-  attrs <- mapCM (\c (id,t) -> do
-                       (t,_) <- tcRho scope c t Nothing
-                       return (id,t))
-                 c1 attrs
-  res <- mapCM (\c child -> tcRho scope c child Nothing) c2 children
-  instSigma scope c3 (Markup tag attrs (map fst res)) vtypeMarkup mb_ty
-tcRho scope c (Reset ctl mb_ct t qid) mb_ty
-  | ctl == cConcat = do
-      let (c1,c23) = split c
-          (c2,c3 ) = split c23
-      (t,_) <- tcRho scope c1 t Nothing
-      mb_ct <- case mb_ct of
-                 Just ct -> do (ct,_) <- tcRho scope c2 ct (Just vtypeInt)
-                               return (Just ct)
-                 Nothing -> return Nothing
-      instSigma scope c2 (Reset ctl mb_ct t qid) vtypeMarkup mb_ty
-  | ctl == cOne = do
-      let (c1,c2) = split c
-      (t,ty)     <- tcRho scope c1 t mb_ty
-      (mb_ct,ty) <- case mb_ct of
-                      Just ct -> do (ct,ty) <- tcRho scope c2 ct (Just ty)
-                                    return (Just ct,ty)
-                      Nothing -> return (Nothing,ty)
-      return (Reset ctl mb_ct t qid,ty)
-  | ctl == cDefault = do
-      let (c1,c2) = split c
-      (t,ty)     <- tcRho scope c1 t mb_ty
-      (mb_ct,ty) <- case mb_ct of
-                      Just ct -> do (ct,ty) <- tcRho scope c2 ct (Just ty)
-                                    return (Just ct,ty)
-                      Nothing -> evalError (pp "[list: .. | ..] requires an argument")
-      return (Reset ctl mb_ct t qid,ty)
-  | ctl == cList = do
-      do let (c1,c2) = split c
-         mb_ct  <- case mb_ct of
-                     Just ct -> do (ct,ty) <- tcRho scope c1 ct Nothing
-                                   return (Just ct)
-                     Nothing -> evalError (pp "[list: .. | ..] requires an argument")
-         (t,ty) <- tcRho scope c2 t mb_ty
-         case ty of
-           VApp c qid [] -> return (Reset ctl mb_ct t (Just qid), ty)
-           _             -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty)
-  | otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
-tcRho scope s (Opts n cs) mb_ty = do
-  let (s1,s2,s3) = split3 s
-  (n,_) <- tcRho scope s1 n Nothing
-  (ls,_) <- tcUnifying scope s2 (fst <$> cs) Nothing
-  (ts,ty) <- tcUnifying scope s3 (snd <$> cs) mb_ty
-  return (Opts n (zip ls ts), ty)
-tcRho scope s t _ = unimplemented ("tcRho "++show t)
-
-evalCodomain :: Ident -> Value -> Value -> EvalM Value
-evalCodomain x v (VClosure env c ty) = do
-  g <- globals
-  return (eval g ((x,v):env) c ty [])
-evalCodomain x _ ty = return ty
-
-tcUnifying :: Scope -> Choice -> [Term] -> Maybe Rho -> EvalM ([Term], Constraint)
-tcUnifying scope c ts mb_ty = do
-  (ty,subsume) <-
-    case mb_ty of
-      Just ty -> do return (ty, \t ty' -> return t)
-      Nothing -> do i <- newResiduation scope
-                    let ty = VMeta i []
-                    return (ty, \t ty' -> subsCheckRho scope t ty' ty)
-
-  let go c t = do (t, ty) <- tcRho scope c t mb_ty
-                  subsume t ty
-
-  ts <- mapCM go c ts
-  return (ts,ty)
-
-tcCases scope c []         p_ty res_ty = return []
-tcCases scope c ((p,t):cs) p_ty res_ty = do
-  let (c1,c2,c3,c4) = split4 c
-  scope' <- tcPatt scope c1 p p_ty
-  (t,_)  <- tcRho scope' c2 t (Just res_ty)
-  cs <- tcCases scope c3 cs p_ty res_ty
-  return ((p,t):cs)
-
-tcApp scope c t0 (App fun arg) args mb_ty = tcApp scope c t0 fun (arg:args) mb_ty     -- APP
-tcApp scope c t0 t@(Q id)      args mb_ty = resolveOverloads scope c t0 id args mb_ty -- VAR (global)
-tcApp scope c t0 t@(QC id)     args mb_ty = resolveOverloads scope c t0 id args mb_ty -- VAR (global)
-tcApp scope c t0 t             args mb_ty = do
-  let (c1,c23) = split c
-  let (c2,c3)  = split c23
-  (t,ty) <- tcRho scope c1 t Nothing
-  (t,ty) <- reapply1 scope c2 t ty args
-  instSigma scope c3 t ty mb_ty
-
-reapply1 :: Scope -> Choice -> Term -> Value -> [Term] -> EvalM (Term,Rho)
-reapply1 scope c fun fun_ty []                   = return (fun,fun_ty)
-reapply1 scope c fun fun_ty ((ImplArg arg):args) = do -- Implicit arg case
-  let (c1,c2,c3,c4) = split4 c
-  (bt, x, arg_ty, res_ty) <- unifyFun scope fun_ty
-  unless (bt == Implicit) $
-     evalError (ppTerm Unqualified 0 (App fun (ImplArg arg)) <+>
-                "is an implicit argument application, but no implicit argument is expected")
-  (arg,_) <- tcRho scope c1 arg (Just arg_ty)
-  g <- globals
-  res_ty <- evalCodomain x (eval g (scopeEnv scope) c2 arg []) res_ty
-  reapply1 scope c3 (App fun (ImplArg arg)) res_ty args
-reapply1 scope c fun fun_ty (arg:args) = do -- Explicit arg (fallthrough) case
-  let (c1,c2,c3,c4) = split4 c
-  (fun,fun_ty) <- instantiate scope fun fun_ty
-  (_, x, arg_ty, res_ty) <- unifyFun scope fun_ty
-  (arg,_) <- tcRho scope c1 arg (Just arg_ty)
-  g <- globals
-  res_ty <- evalCodomain x (eval g (scopeEnv scope) c2 arg []) res_ty
-  reapply1 scope c3 (App fun arg) res_ty args
-
-resolveOverloads :: Scope -> Choice -> Term -> QIdent -> [Term] -> Maybe Rho -> EvalM (Term,Rho)
-resolveOverloads scope c t0 q args mb_ty = do
-  g@(Gl gr _) <- globals
-  case lookupOverloadTypes gr q of
-    Bad msg  -> evalError (pp msg)
-    Ok [(t,ty)] -> do let (c1,c23) = split c
-                          (c2,c3)  = split c23
-                      (t,ty) <- reapply1 scope c1 t (eval g [] c2 ty []) args
-                      instSigma scope c3 t ty mb_ty
-    Ok ttys     -> do let (c1,c23) = split c
-                          (c2,c3)  = split c23
-                      arg_tys <- mapCM (checkArg g) c1 args
-                      let v_ttys = mapC (\c (t,ty) -> (t,eval g [] c ty [])) c2 ttys
-                      try (\(fun,fun_ty) -> reapply2 scope c3 fun fun_ty arg_tys mb_ty)
-                          (\ttys -> fmap (\(ts,ty) -> (mkFV ts,ty)) (snd (minimum g ttys)))
-                          v_ttys
-  where
-    checkArg g c (ImplArg arg) = do
-      let (c1,c2) = split c
-      (arg,arg_ty) <- tcRho scope c1 arg Nothing
-      let v = eval g (scopeEnv scope) c2 arg []
-      return (ImplArg arg,v,arg_ty)
-    checkArg g c arg = do
-      let (c1,c2) = split c
-      (arg,arg_ty) <- tcRho scope c1 arg Nothing
-      let v = eval g (scopeEnv scope) c2 arg []
-      return (arg,v,arg_ty)
-
-    mkFV [t] = t
-    mkFV ts  = FV ts
-
-    minimum g []                    = (maxBound,err)
-      where
-        err = evalError (pp "Overload resolution failed")
-    minimum g (tty@((t,ty),state):ttys) =
-      let ty'      = zonk ty
-          a        = arity ty'
-          (a',res) = minimum g ttys
-      in case compare a a' of
-           GT -> (a',res)
-           EQ -> (a',join t ty' state res)
-           LT -> (a ,one  t ty' state)
-      where
-        arity :: Value -> Int
-        arity (VProd _ _ _ ty) = 1 + arity ty
-        arity _                = 0
-
-        zonk :: Value -> Value
-        zonk (VProd bt x ty1 ty2) = VProd bt x (zonk ty1) (zonk ty2)
-        zonk (VMeta i vs)         =
-          case Map.lookup i (metaVars state) of
-            Just (Bound _ v)              -> zonk (apply g v vs)
-            Just (Residuation _ (Just v)) -> zonk (apply g v vs)
-            _                             -> VMeta i (map zonk vs)
-        zonk (VSusp i k vs)      =
-          case Map.lookup i (metaVars state) of
-            Just (Bound _ v)              -> zonk (apply g (k v) vs)
-            Just (Residuation _ (Just v)) -> zonk (apply g (k v) vs)
-            _                             -> VSusp i k (map zonk vs)
-        zonk v                   = v
-
-        one t ty state = do
-          t <- withState state (zonkTerm [] t)
-          return ([t],ty)
-
-        join t ty state res = do
-          t <- withState state (zonkTerm [] t)
-          (ts,ty') <- res
-          ty <- supertype scope (Just ty) ty'
-          return (t:ts,ty)
-
-reapply2 :: Scope -> Choice -> Term -> Value -> [(Term,Value,Value)] -> Maybe Rho -> EvalM (Term,Rho)
-reapply2 scope c fun fun_ty []                                mb_ty = instSigma scope c fun fun_ty mb_ty
-reapply2 scope c fun fun_ty ((ImplArg arg,arg_v,arg_ty):args) mb_ty = do -- Implicit arg case
-  (bt, x, arg_ty', res_ty) <- unifyFun scope fun_ty
-  unless (bt == Implicit) $
-     evalError (ppTerm Unqualified 0 (App fun (ImplArg arg)) <+>
-                "is an implicit argument application, but no implicit argument is expected")
-  arg <- subsCheckRho scope arg arg_ty' arg_ty
-  res_ty <- evalCodomain x arg_v res_ty
-  reapply2 scope c (App fun (ImplArg arg)) res_ty args mb_ty
-reapply2 scope c fun fun_ty ((arg,arg_v,arg_ty):args) mb_ty = do -- Explicit arg (fallthrough) case
-  (fun,fun_ty) <- instantiate scope fun fun_ty
-  (_, x, arg_ty', res_ty) <- unifyFun scope fun_ty
-  arg <- subsCheckRho scope arg arg_ty arg_ty'
-  res_ty <- evalCodomain x arg_v res_ty
-  reapply2 scope c (App fun arg) res_ty args mb_ty
-
-tcPatt scope c PW        ty0 =
-  return scope
-tcPatt scope c (PV x)    ty0 =
-  return ((x,ty0):scope)
-tcPatt scope c (PP q ps) ty0 = do
-  g@(Gl gr _) <- globals
-  ty <- case lookupResType gr q of
-          Ok ty   -> return ty
-          Bad msg -> evalError (pp msg)
-  let go scope c ty []     = return (scope,ty)
-      go scope c ty (p:ps) = do (_,_,arg_ty,res_ty) <- unifyFun scope ty
-                                let (c1,c2) = split c
-                                scope <- tcPatt scope c1 p arg_ty
-                                go scope c2 res_ty ps
-  let (c1,c2) = split c
-  (scope,ty) <- go scope c1 (eval g [] c2 ty []) ps
-  unify scope ty0 ty
-  return scope
-tcPatt scope c (PInt i) ty0 = do
-  subsCheckRho scope (EInt i) (vtypeInts i) ty0
-  return scope
-tcPatt scope c (PString s) ty0 = do
-  unify scope ty0 vtypeStr
-  return scope
-tcPatt scope c PChar ty0 = do
-  unify scope ty0 vtypeStr
-  return scope
-tcPatt scope c (PChars cs) ty0 = do
-  unify scope ty0 vtypeStr
-  return scope
-tcPatt scope c (PSeq _ _ p1 _ _ p2) ty0 = do
-  unify scope ty0 vtypeStr
-  let (c1,c2) = split c
-  scope <- tcPatt scope c1 p1 vtypeStr
-  scope <- tcPatt scope c2 p2 vtypeStr
-  return scope
-tcPatt scope c (PRep _ _ p) ty0 = do
-  unify scope ty0 vtypeStr
-  tcPatt scope c p vtypeStr
-tcPatt scope c (PAs x p) ty0 = do
-  tcPatt ((x,ty0):scope) c p ty0
-tcPatt scope c (PR rs) ty0 = do
-  let mk_ltys []            = return []
-      mk_ltys ((l,p):rs)    = do i <- newResiduation scope
-                                 ltys <- mk_ltys rs
-                                 return ((l,p,VMeta i []) : ltys)
-      go scope c []            = return scope
-      go scope c ((l,p,ty):rs) = do let (c1,c2) = split c
-                                    scope <- tcPatt scope c1 p ty
-                                    go scope c2 rs
-  ltys <- mk_ltys rs
-  subsCheckRho scope (EPatt 0 Nothing (PR rs)) (VRecType [(l,True,ty) | (l,p,ty) <- ltys]) ty0
-  go scope c ltys
-tcPatt scope c (PAlt p1 p2) ty0 = do
-  let (c1,c2) = split c
-  tcPatt scope c1 p1 ty0
-  tcPatt scope c2 p2 ty0
-  return scope
-tcPatt scope c (PM q) ty0 = do
-  g@(Gl gr _) <- globals
-  ty <- case lookupResType gr q of
-          Ok ty   -> return ty
-          Bad msg -> evalError (pp msg)
-  case ty of
-    EPattType ty
-            -> do unify scope ty0 (eval g [] c ty [])
-                  return scope
-    ty   -> evalError ("Pattern type expected but " <+> pp ty <+> " found.")
-tcPatt scope c p ty = unimplemented ("tcPatt "++show p)
-
-inferRecFields scope c rs =
-  mapCM (\c (l,r) -> tcRecField scope c l r Nothing) c rs
-
-checkRecFields scope c []          ltys
-  | null ltys                            = return []
-  | otherwise                            = evalError ("Missing fields:" <+> hsep [l | (l,_,_) <- ltys])
-checkRecFields scope c ((l,t):lts) ltys =
-  case takeIt l ltys of
-    (Just ty,ltys) -> do let (c1,c2) = split c
-                         ltty  <- tcRecField scope c1 l t (Just ty)
-                         lttys <- checkRecFields scope c2 lts ltys
-                         return (ltty : lttys)
-    (Nothing,ltys) -> do evalWarn ("Discarded field:" <+> l)
-                         lttys <- checkRecFields scope c lts ltys
-                         return lttys     -- ignore the field
-  where
-    takeIt l1 []  = (Nothing, [])
-    takeIt l1 (lty@(l2,_,ty):ltys)
-      | l1 == l2  = (Just ty,ltys)
-      | otherwise = let (mb_ty,ltys') = takeIt l1 ltys
-                    in (mb_ty,lty:ltys')
-
-tcRecField scope c l (mb_ann_ty,t) mb_ty = do
-  (t,ty) <- case mb_ann_ty of
-              Just ann_ty -> do let (c1,c2,c3,c4) = split4 c
-                                (ann_ty, _) <- tcRho scope c1 ann_ty (Just vtypeType)
-                                g <- globals
-                                let v_ann_ty = eval g (scopeEnv scope) c2 ann_ty []
-                                (t,_) <- tcRho scope c3 t (Just v_ann_ty)
-                                instSigma scope c4 t v_ann_ty mb_ty
-              Nothing     -> tcRho scope c t mb_ty
-  return (l,t,ty)
-
-tcRecTypeFields scope c []          mb_ty = return ([],mb_ty)
-tcRecTypeFields scope c ((l,ty):rs) mb_ty = do
-  let (c1,c2) = split c
-  (ty,sort) <- tcRho scope c1 ty mb_ty
-  mb_ty <- case sort of
-             VSort s
-               | s == cType  -> return (Just sort)
-               | s == cPType -> return mb_ty
-             VMeta _ _       -> return mb_ty
-             _               -> do sort <- value2termM False (scopeVars scope) sort
-                                   evalError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$
-                                              "cannot be of type" <+> ppTerm Unqualified 0 sort)
-  (rs,mb_ty) <- tcRecTypeFields scope c2 rs mb_ty
-  return ((l,ty):rs,mb_ty)
-
--- | Invariant: if the third argument is (Just rho),
---              then rho is in weak-prenex form
-instSigma :: Scope -> Choice -> Term -> Sigma -> Maybe Rho -> EvalM (Term, Rho)
-instSigma scope s t ty1 Nothing    = return (t,ty1)           -- INST1
-instSigma scope s t ty1 (Just ty2) = do                       -- INST2
-  t <- subsCheckRho scope t ty1 ty2
-  return (t,ty2)
-
--- | Invariant: the second argument is in weak-prenex form
-subsCheckRho :: Scope -> Term -> Sigma -> Rho -> EvalM Term
-subsCheckRho scope t (VMeta i vs1) (VMeta j vs2)
-  | i  == j   = do sequence_ (zipWith (unify scope) vs1 vs2)
-                   return t
-  | otherwise = do
-      mv <- getMeta i
-      case mv of
-        Bound _ v1 -> do
-          g <- globals
-          subsCheckRho scope t (apply g v1 vs1) (VMeta j vs2)
-        Residuation scope1 (Just ctr1) -> do
-          g <- globals
-          subsCheckRho scope t (apply g ctr1 vs1) (VMeta j vs2)
-        Residuation scope1 Nothing -> do
-          mv <- getMeta j
-          case mv of
-            Bound _ v2 -> do
-              g <- globals
-              subsCheckRho scope t (VMeta i vs1) (apply g v2 vs2)
-            Residuation scope2 ctr2
-              | m > n     -> do setMeta i (Bound scope1 (VMeta j vs2))
-                                return t
-              | otherwise -> case ctr2 of
-                               Nothing   -> do setMeta j (Bound scope2 (VMeta i vs2))
-                                               return t
-                               Just ctr2 -> do g <- globals
-                                               subsCheckRho scope t (VMeta i vs1) (apply g ctr2 vs2)
-              where
-                m = length scope1
-                n = length scope2
-subsCheckRho scope t ty1@(VMeta i vs) ty2 = do
-  mv <- getMeta i
-  case mv of
-    Bound _ ty1 -> do
-      g <- globals
-      subsCheckRho scope t (apply g ty1 vs) ty2
-    Residuation scope' ctr -> do
-      occursCheck scope' i scope ty2
-      ctr <- subtype scope ctr ty2
-      setMeta i (Residuation scope' (Just ctr))
-      return t
-subsCheckRho scope t ty1 ty2@(VMeta i vs) = do
-  mv <- getMeta i
-  case mv of
-    Bound _ ty2 -> do
-      g <- globals
-      subsCheckRho scope t ty1 (apply g ty2 vs)
-    Residuation scope' ctr -> do
-      occursCheck scope' i scope ty1
-      ctr <- supertype scope ctr ty1
-      setMeta i (Residuation scope' (Just ctr))
-      return t
-subsCheckRho scope t (VProd Implicit x ty1 ty2) rho2 = do     -- Rule SPEC
-  i <- newResiduation scope
-  g <- globals
-  let ty2' = case ty2 of
-               VClosure env c ty2 -> eval g ((x,VMeta i []):env) c ty2 []
-               ty2                -> ty2
-  subsCheckRho scope (App t (ImplArg (Meta i))) ty2' rho2
-subsCheckRho scope t rho1 (VProd Implicit x ty1 ty2) = do     -- Rule SKOL
-  let v = newVar scope
-  ty2 <- evalCodomain x (VGen (length scope) []) ty2
-  t <- subsCheckRho ((v,ty1):scope) t rho1 ty2
-  return (Abs Implicit v t)
-subsCheckRho scope t rho1 (VProd Explicit _ a2 r2) = do       -- Rule FUN
-  (_,_,a1,r1) <- unifyFun scope rho1
-  subsCheckFun scope t a1 r1 a2 r2
-subsCheckRho scope t (VProd Explicit _ a1 r1) rho2 = do       -- Rule FUN
-  (_,_,a2,r2) <- unifyFun scope rho2
-  subsCheckFun scope t a1 r1 a2 r2
-subsCheckRho scope t rho1 (VTable p2 r2) = do                 -- Rule TABLE
-  (p1,r1) <- unifyTbl scope rho1
-  subsCheckTbl scope t p1 r1 p2 r2
-subsCheckRho scope t (VTable p1 r1) rho2 = do                 -- Rule TABLE
-  (p2,r2) <- unifyTbl scope rho2
-  subsCheckTbl scope t p1 r1 p2 r2
-subsCheckRho scope t (VSort s1) (VSort s2)                    -- Rule PTYPE
-  | s1 == cPType && s2 == cType = return t
-subsCheckRho scope t (VApp _ p1 []) rho2                      -- for backwards compatibility
-  | p1 == (cPredef,cErrorType) = return t
-subsCheckRho scope t (VApp _ p1 _) (VApp _ p2 _)              -- This is not correct but there is in the RGL nextPrec relies on it.
-  | p1 == (cPredef,cInt) && p2 == (cPredef,cInts) = return t  -- Should be only a temporary hack.
-subsCheckRho scope t (VApp _ p1 _) (VApp _ p2 _)              -- Rule INT1
-  | p1 == (cPredef,cInts) && p2 == (cPredef,cInt) = return t
-subsCheckRho scope t (VApp _ p1 [VInt i]) (VApp _ p2 [VInt j]) -- Rule INT2
-  | p1 == (cPredef,cInts) && p2 == (cPredef,cInts) = do
-      if i <= j
-        then return t
-        else evalError ("Ints" <+> i <+> "is not a subtype of" <+> "Ints" <+> j)
-subsCheckRho scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do      -- Rule REC
-  let mkAccess scope t =
-        case t of
-          ExtR t1 t2 -> do (scope,mkProj1,mkWrap1) <- mkAccess scope t1
-                           (scope,mkProj2,mkWrap2) <- mkAccess scope t2
-                           return (scope
-                                  ,\l -> mkProj2 l `mplus` mkProj1 l
-                                  ,mkWrap1 . mkWrap2
-                                  )
-          R rs -> do sequence_ [evalWarn ("Discarded field:" <+> l) | (l,_) <- rs, isNothing (lookup3 l rs2)]
-                     return (scope
-                            ,\l -> lookup l rs
-                            ,id
-                            )
-          Vr x -> do return (scope
-                            ,\l -> do VRecType rs <- lookup x scope
-                                      ty <- lookup3 l rs
-                                      return (Nothing,P t l)
-                            ,id
-                            )
-          t    -> let x = newVar scope
-                  in return (((x,ty1):scope)
-                            ,\l  -> return (Nothing,P (Vr x) l)
-                            ,Let (x, (Nothing, t))
-                            )
-
-      mkField scope l (mb_ty,t) ty1 ty2 = do
-        t <- subsCheckRho scope t ty1 ty2
-        return (l, (mb_ty,t))
-
-      lookup3 l []  = Nothing
-      lookup3 l ((l',_,v):rs)
-        | l == l'   = Just v
-        | otherwise = lookup3 l rs
-
-  (scope,mkProj,mkWrap) <- mkAccess scope t
-
-  let fields = [(l,ty2,lookup3 l rs1) | (l,o2,ty2) <- rs2]
-  case [l | (l,_,Nothing) <- fields, not (isLockLabel l)] of
-    []      -> return ()
-    missing -> evalError ("In the term" <+> pp t $$
-                          "there are no values for fields:" <+> hsep missing)
-  rs <- sequence [mkField scope l t ty1 ty2 | (l,ty2,Just ty1) <- fields, Just t <- [mkProj l]]
-  return (mkWrap (R (rs++[(l, (Just (RecType []),R [])) | (l,_,Nothing) <- fields, isLockLabel l])))
-subsCheckRho scope t tau1 (VFV c (VarFree vs)) = do
-  tau2 <- variants c vs
-  subsCheckRho scope t tau1 tau2
-subsCheckRho scope t (VFV c (VarFree vs)) tau2 = do
-  tau1 <- variants c vs
-  subsCheckRho scope t tau1 tau2
-subsCheckRho scope t tau1 tau2 = do                           -- Rule EQ
-  unify scope tau1 tau2                                 -- Revert to ordinary unification
-  return t
-
-subsCheckFun :: Scope -> Term -> Sigma -> Value -> Sigma -> Value -> EvalM Term
-subsCheckFun scope t a1 r1 a2 r2 = do
-  let v   = newVar scope
-  vt <- subsCheckRho ((v,a2):scope) (Vr v) a2 a1
-  g  <- globals
-  let r1' = case r1 of
-              VClosure env c r1 -> eval g ((v,(VGen (length scope) [])):env) c r1 []
-              r1                -> r1
-      r2' = case r2 of
-              VClosure env c r2 -> eval g ((v,(VGen (length scope) [])):env) c r2 []
-              r2                -> r2
-  t  <- subsCheckRho ((v,vtypeType):scope) (App t vt) r1' r2'
-  return (Abs Explicit v t)
-
-subsCheckTbl :: Scope -> Term -> Sigma -> Rho -> Sigma -> Rho  -> EvalM Term
-subsCheckTbl scope t p1 r1 p2 r2 = do
-  let x = newVar scope
-  xt <- subsCheckRho ((x,p2):scope) (Vr x) p2 p1
-  t  <- subsCheckRho ((x,p2):scope) (S t xt) r1 r2
-  p2 <- value2termM True (scopeVars scope) p2
-  return (T (TTyped p2) [(PV x,t)])
-
-subtype scope Nothing (VApp c p [VInt i])
-  | p == (cPredef,cInts) = do
-      return (VInts Nothing (Just i))
-subtype scope (Just (VInts i j)) (VApp c p [VInt k])
-  | p == (cPredef,cInts) = do
-      return (VInts j (Just (maybe k (min k) i)))
-subtype scope Nothing (VRecType ltys) = do
-  lctrs <- mapM (\(l,o,ty) -> subtype scope Nothing ty >>= \ctr -> return (l,o,ctr)) ltys
-  return (VRecType lctrs)
-subtype scope (Just (VRecType lctrs1)) (VRecType lctrs2) = do
-  lctrs <- foldM (\lctrs (l,o,ctr) -> union l o ctr lctrs) lctrs1 lctrs2
-  return (VRecType lctrs)
-  where
-    union l o1 ctr1 [] = do ctr <- subtype scope Nothing ctr1
-                            return [(l,True,ctr)]
-    union l o1 ctr1 ((l',o2,ctr2):lctrs)
-      | l == l'   = do ctr <- subtype scope (Just ctr1) ctr2
-                       return ((l,o1||o2,ctr):lctrs)
-      | otherwise = do lctrs <- union l o1 ctr1 lctrs
-                       return ((l',o2,ctr2):lctrs)
-subtype scope (Just (VTable a1 r1)) (VTable a2 r2) = do
-  a <- supertype scope (Just a1) a2
-  r <- subtype scope (Just r1) r2
-  return (VTable a r)
-subtype scope (Just (VProd Explicit x a1 r1)) (VProd Explicit y a2 r2)
-  | x == identW && y == identW = do
-       a <- supertype scope (Just a1) a2
-       r <- subtype scope (Just r1) r2
-       return (VProd Explicit identW a r)
-subtype scope Nothing    ty = return ty
-subtype scope (Just ctr) ty = do
-  unify scope ctr ty
-  return ty
-
-supertype scope Nothing (VApp c p [VInt i])
-  | p == (cPredef,cInts) = do
-      return (VInts (Just i) Nothing)
-supertype scope (Just (VInts i j)) (VApp c p [VInt k])
-  | p == (cPredef,cInts) = do
-      return (VInts (Just (maybe k (max k) i)) j)
-supertype scope Nothing (VRecType ltys) = do
-  lctrs <- mapM (\(l,o,ty) -> supertype scope Nothing ty >>= \ctr -> return (l,False,ctr)) ltys
-  return (VRecType lctrs)
-supertype scope (Just (VRecType lctrs1)) (VRecType lctrs2) = do
-  lctrs <- foldM (\lctrs (l,o,ctr) -> intersect l o ctr lctrs lctrs2) [] lctrs1
-  return (VRecType lctrs)
-  where
-    intersect l o1 ctr1 lctrs [] = return lctrs
-    intersect l o1 ctr1 lctrs ((l',o2,ctr2):lctrs2)
-      | l == l'   = do ctr <- supertype scope (Just ctr1) ctr2
-                       return ((l,o1 && o2,ctr):lctrs)
-      | otherwise = do intersect l o1 ctr1 lctrs lctrs2
-supertype scope (Just (VTable a1 r1)) (VTable a2 r2) = do
-  a <- subtype scope (Just a1) a2
-  r <- supertype scope (Just r1) r2
-  return (VTable a r)
-supertype scope (Just (VProd Explicit x a1 r1)) (VProd Explicit y a2 r2)
-  | x == identW && y == identW = do
-       a <- subtype scope (Just a1) a2
-       r <- supertype scope (Just r1) r2
-       return (VProd Explicit identW a r)
-supertype scope Nothing    ty = return ty
-supertype scope (Just ctr) ty = do
-  unify scope ctr ty
-  return ty
-
------------------------------------------------------------------------
--- Unification
------------------------------------------------------------------------
-
-unifyFun :: Scope -> Rho -> EvalM (BindType, Ident, Sigma, Rho)
-unifyFun scope (VProd bt x arg res) =
-  return (bt,x,arg,res)
-unifyFun scope (VFV c (VarFree vs)) = do
-  res <- mapM (unifyFun scope) vs
-  return
-    ( Explicit
-    , identW
-    , VFV c (VarFree [sigma | (_,_,sigma,rho) <- res])
-    , VFV c (VarFree [rho | (_,_,sigma,rho) <- res])
-    )
-unifyFun scope tau = do
-  let mk_val i = VMeta i []
-  arg <- fmap mk_val $ newResiduation scope
-  res <- fmap mk_val $ newResiduation scope
-  let bt = Explicit
-  unify scope tau (VProd bt identW arg res)
-  return (bt,identW,arg,res)
-
-unifyTbl :: Scope -> Rho -> EvalM (Sigma, Rho)
-unifyTbl scope (VTable arg res) =
-  return (arg,res)
-unifyTbl scope tau = do
-  let mk_val i = VMeta i []
-  arg <- fmap mk_val $ newResiduation scope
-  res <- fmap mk_val $ newResiduation scope
-  unify scope tau (VTable arg res)
-  return (arg,res)
-
-unify scope (VApp c1 f1 vs1) (VApp c2 f2 vs2)
-  | f1 == f2  = sequence_ (zipWith (unify scope) vs1 vs2)
-unify scope (VMeta i vs1) (VMeta j vs2)
-  | i  == j   = sequence_ (zipWith (unify scope) vs1 vs2)
-  | otherwise = do 
-      mv <- getMeta i
-      case mv of
-        Bound _ v1 -> do
-          g <- globals
-          unify scope (apply g v1 vs1) (VMeta j vs2)
-        Residuation scope1 _ -> do
-          mv <- getMeta j
-          case mv of
-            Bound _ v2 -> do
-              g <- globals
-              unify scope (VMeta i vs1) (apply g v2 vs2)
-            Residuation scope2 _
-              | m > n     -> setMeta i (Bound scope1 (VMeta j vs2))
-              | otherwise -> setMeta j (Bound scope2 (VMeta i vs2))
-              where
-                m = length scope1
-                n = length scope2 
-unify scope (VMeta i vs) v = unifyVar scope i vs v
-unify scope v (VMeta i vs) = unifyVar scope i vs v
-unify scope (VGen i vs1)       (VGen j vs2)
-  | i == j                     = sequence_ (zipWith (unify scope) vs1 vs2)
-unify scope (VProd b x d cod) (VProd b' x' d' cod')
-  | b == b'                    = do
-      unify scope d d'
-      cod  <- evalCodomain x  (VGen (length scope) []) cod
-      cod' <- evalCodomain x' (VGen (length scope) []) cod'
-      unify scope cod cod'
-unify scope (VTable p1 res1) (VTable p2 res2) = do
-  unify scope p2   p1
-  unify scope res1 res2
-unify scope (VSort s1) (VSort s2)
-  | s1 == s2                   = return ()
-unify scope (VInt i)  (VInt j)
-  | i == j                     = return ()
-unify scope (VFlt x)  (VFlt y)
-  | x == y                     = return ()
-unify scope (VStr s1) (VStr s2)
-  | s1 == s2                   = return ()
-unify scope VEmpty VEmpty      = return ()
-unify scope v1 v2 = do
-  t1 <- value2termM False (scopeVars scope) v1
-  t2 <- value2termM False (scopeVars scope) v2
-  evalError ("Cannot unify:" <+> ppTerm Terse 0 t1 $$
-             "        with:" <+> ppTerm Terse 0 t2)
-
-
--- | Invariant: tv1 is a flexible type variable
-unifyVar :: Scope -> MetaId -> [Value] -> Tau -> EvalM ()
-unifyVar scope metaid vs ty2 = do            -- Check whether i is bound
-  mv <- getMeta metaid
-  case mv of
-    Bound _ ty1          -> do g <- globals
-                               unify scope (apply g ty1 vs) ty2
-    Residuation scope' _ -> do occursCheck scope' metaid scope ty2
-                               setMeta metaid (Bound scope' ty2)
-
-occursCheck scope' i0 scope v =
-  let m = length scope'
-      n = length scope
-  in check m n v
-  where
-    check m n (VApp c f vs) = mapM_ (check m n) vs
-    check m n (VMeta i vs)
-      | i0 == i  = do ty1 <- value2termM False (scopeVars scope) (VMeta i vs)
-                      ty2 <- value2termM False (scopeVars scope) v
-                      evalError ("Occurs check for" <+> ppTerm Unqualified 0 ty1 <+> "in:" $$
-                                 nest 2 (ppTerm Unqualified 0 ty2))
-      | otherwise = do
-          s <- getMeta i
-          case s of
-            Bound _ v -> do g <- globals
-                            check m n (apply g v vs)
-            _         -> mapM_ (check m n) vs
-    check m n (VGen i vs)
-      | i > m     = let (v,_) = reverse scope !! i
-                    in evalError ("Variable" <+> pp v <+> "has escaped")
-      | otherwise = mapM_ (check m n) vs
-    check m n (VClosure env c (Abs bt x t)) = do
-      g <- globals
-      check (m+1) (n+1) (eval g ((x,VGen n []):env) c t [])
-    check m n (VProd bt x ty1 ty2) = do
-      check m n ty1
-      case ty2 of
-        VClosure env c t -> do g <- globals
-                               check (m+1) (n+1) (eval g ((x,VGen n []):env) c t [])
-        _                -> check m n ty2
-    check m n (VRecType as) =
-      mapM_ (\(_,_,v) -> check m n v) as
-    check m n (VR as) =
-      mapM_ (\(lbl,v) -> check m n v) as
-    check m n (VP v l vs) =
-      check m n v >> mapM_ (check m n) vs
-    check m n (VExtR v1 v2) =
-      check m n v1 >> check m n v2
-    check m n (VTable v1 v2) =
-      check m n v1 >> check m n v2
-    check m n (VT ty env c cs) =
-      check m n ty      -- Traverse cs as well
-    check m n (VV ty cs) =
-      check m n ty >> mapM_ (check m n) cs
-    check m n (VS v1 v2 vs) =
-      check m n v1 >> check m n v2 >> mapM_ (check m n) vs
-    check m n (VSort _) = return ()
-    check m n (VInt _) = return ()
-    check m n (VFlt _) = return ()
-    check m n (VStr _) = return ()
-    check m n VEmpty   = return ()
-    check m n (VC v1 v2) =
-      check m n v1 >> check m n v2
-    check m n (VGlue v1 v2) =
-      check m n v1 >> check m n v2
-    check m n (VPatt _ _ _) = return ()
-    check m n (VPattType v) =
-      check m n v
-    check m n (VFV c vs) =
-      mapM_ (check m n) (unvariants vs)
-    check m n (VAlts v vs) =
-      check m n v >> mapM_ (\(v1,v2) -> check m n v1 >> check m n v2) vs
-    check m n (VStrs vs) =
-      mapM_ (check m n) vs
-    check m n (VInts _ _) = return ()
-
------------------------------------------------------------------------
--- Instantiation and quantification
------------------------------------------------------------------------
-
--- | Instantiate the topmost implicit arguments with metavariables
-instantiate :: Scope -> Term -> Sigma -> EvalM (Term,Rho)
-instantiate scope t (VProd Implicit x ty1 ty2) = do
-  i <- newResiduation scope
-  ty2 <- case ty2 of
-           VClosure env c ty2 -> do g <- globals
-                                    return (eval g ((x,VMeta i []):env) c ty2 [])
-           ty2                -> return ty2
-  instantiate scope (App t (ImplArg (Meta i))) ty2
-instantiate scope t ty@(VMeta i args) = getMeta i >>= \case
-  Bound _ v              -> instantiate scope t v
-  Residuation _ (Just v) -> instantiate scope t v
-  _                      -> return (t,ty) -- We don't have enough information to try any instantiation
-instantiate scope t ty = do
-  return (t,ty)
-
--- | Build fresh lambda abstractions for the topmost implicit arguments
-skolemise :: Scope -> Sigma -> EvalM (Scope, Term->Term, Rho)
-skolemise scope ty@(VMeta i vs) = do
-  mv <- getMeta i
-  case mv of
-    Residuation _ _ -> return (scope,id,ty)                   -- guarded constant?
-    Bound _ ty      -> do g <- globals
-                          skolemise scope (apply g ty vs)
-skolemise scope (VProd Implicit x ty1 ty2) = do
-  let v = newVar scope
-  ty2 <- evalCodomain x (VGen (length scope) []) ty2
-  (scope,f,ty2) <- skolemise ((v,ty1):scope) ty2
-  return (scope,Abs Implicit v . f,ty2)
-skolemise scope ty = do
-  return (scope,id,ty)
-
--- | Quantify over the specified type variables (all flexible)
-quantify :: Scope -> Term -> [MetaId] -> Rho -> EvalM (Term,Sigma)
-quantify scope t tvs ty = do
-  let m = length tvs
-      n = length scope
-  (used_bndrs,ty) <- check m n [] ty
-  let new_bndrs  = take m (allBinders \\ used_bndrs)
-  mapM_ (bind ([(var,VSort cType)|var <- new_bndrs]++scope)) (zip3 [0..] tvs new_bndrs)
-  let ty' = foldr (\ty -> VProd Implicit ty vtypeType) ty new_bndrs
-  return (foldr (Abs Implicit) t new_bndrs,ty')
-  where
-    bind scope (i, meta_id, name) = setMeta meta_id (Bound scope (VGen i []))
-
-    check m n xs (VApp c f vs)     = do
-      (xs,vs) <- mapAccumM (check m n) xs vs
-      return (xs,VApp c f vs)
-    check m n xs (VMeta i vs)      = do
-      s <- getMeta i
-      case s of
-        Bound _ v -> do g <- globals
-                        check m n xs (apply g v vs)
-        _         -> do (xs,vs) <- mapAccumM (check m n) xs vs
-                        return (xs,VMeta i vs)
-    check m n st (VGen i vs)= do
-      (st,vs) <- mapAccumM (check m n) st vs
-      return (st, VGen (m+i) vs)
-    check m n st (VClosure env c (Abs bt x t)) = do
-      (st,env) <- mapAccumM (\st (x,v) -> check m n st v >>= \(st,v) -> return (st,(x,v))) st env
-      return (st,VClosure env c (Abs bt x t))
-    check m n xs (VProd bt x v1 v2) = do
-      (xs,v1) <- check m n xs v1
-      case v2 of
-        VClosure env c t -> do (st,env) <- mapAccumM (\xs (x,tnk) -> check m n xs tnk >>= \(xs,tnk) -> return (xs,(x,tnk))) xs env
-                               return (x:xs,VProd bt x v1 (VClosure env c t))
-        v2               -> do (xs,v2) <- check m (n+1) xs v2
-                               return (x:xs,VProd bt x v1 v2)
-    check m n xs (VRecType as)     = do
-      (xs,as) <- mapAccumM (\xs (l,o,v) -> check m n xs v >>= \(xs,v) -> return (xs,(l,o,v))) xs as
-      return (xs,VRecType as)
-    check m n xs (VR as)           = do
-      (xs,as) <- mapAccumM (\xs (lbl,tnk) -> check m n xs tnk >>= \(xs,tnk) -> return (xs,(lbl,tnk))) xs as
-      return (xs,VR as)
-    check m n xs (VP v l vs)       = do
-      (xs,v)  <- check m n xs v
-      (xs,vs) <- mapAccumM (check m n) xs vs
-      return (xs,VP v l vs)
-    check m n xs (VExtR v1 v2)     = do
-      (xs,v1) <- check m n xs v1
-      (xs,v2) <- check m n xs v2
-      return (xs,VExtR v1 v2)
-    check m n xs (VTable v1 v2)    = do
-      (xs,v1) <- check m n xs v1
-      (xs,v2) <- check m n xs v2
-      return (xs,VTable v1 v2)
-    check m n xs (VT ty env c cs)    = do
-      (xs,ty) <- check m n xs ty
-      (xs,env) <- mapAccumM (\xs (x,tnk) -> check m n xs tnk >>= \(xs,tnk) -> return (xs,(x,tnk))) xs env
-      return (xs,VT ty env c cs)
-    check m n xs (VV ty cs)        = do
-      (xs,ty) <- check m n xs ty
-      (xs,cs) <- mapAccumM (check m n) xs cs
-      return (xs,VV ty cs)
-    check m n xs (VS v1 tnk vs)    = do
-      (xs,v1)  <- check m n xs v1
-      (xs,tnk) <- check m n xs tnk
-      (xs,vs)  <- mapAccumM (check m n) xs vs
-      return (xs,VS v1 tnk vs)
-    check m n xs v@(VSort _)       = return (xs,v)
-    check m n xs v@(VInt _)        = return (xs,v)
-    check m n xs v@(VFlt _)        = return (xs,v)
-    check m n xs v@(VStr _)        = return (xs,v)
-    check m n xs v@VEmpty          = return (xs,v)
-    check m n xs (VC v1 v2)        = do
-      (xs,v1) <- check m n xs v1
-      (xs,v2) <- check m n xs v2
-      return (xs,VC v1 v2)
-    check m n xs (VGlue v1 v2)        = do
-      (xs,v1) <- check m n xs v1
-      (xs,v2) <- check m n xs v2
-      return (xs,VGlue v1 v2)
-    check m n xs v@(VPatt _ _ _)   = return (xs,v)
-    check m n xs (VPattType v)     = do
-      (xs,v) <- check m n xs v
-      return (xs,VPattType v)
-    check m n xs (VFV c (VarFree vs)) = do
-      (xs,vs) <- mapAccumM (check m n) xs vs
-      return (xs,VFV c (VarFree vs))
-    check m n xs (VFV c (VarOpts name os)) = do
-      (xs,os) <- mapAccumM (\acc (l,v) -> second (l,) <$> check m n acc v) xs os
-      return (xs,VFV c (VarOpts name os))
-    check m n xs (VAlts v vs)      = do
-      (xs,v)  <- check m n xs v
-      (xs,vs) <- mapAccumM (\xs (v1,v2) -> do (xs,v1) <- check m n xs v1
-                                              (xs,v2) <- check m n xs v2
-                                              return (xs,(v1,v2)))
-                           xs vs
-      return (xs,VAlts v vs)
-    check m n xs (VStrs vs)        = do
-      (xs,vs) <- mapAccumM (check m n) xs vs
-      return (xs,VStrs vs)
-    check m n xs v = unimplemented ("check "++show (ppValue Unqualified 5 v))
-
-    mapAccumM :: Monad m => (a -> b -> m (a,c)) -> a -> [b] -> m (a,[c])
-    mapAccumM f s []     = return (s,[])
-    mapAccumM f s (x:xs) = do
-      (s,y)  <- f s x
-      (s,ys) <- mapAccumM f s xs
-      return (s,y:ys)
-
-allBinders :: [Ident]    -- a,b,..z, a1, b1,... z1, a2, b2,...
-allBinders = [ identS [x]          | x <- ['a'..'z'] ] ++
-             [ identS (x : show i) | i <- [1 :: Integer ..], x <- ['a'..'z']]
-
------------------------------------------------------------------------
--- Helpers
------------------------------------------------------------------------
-
-type Sigma = Value
-type Rho   = Value -- No top-level ForAll
-type Tau   = Value -- No ForAlls anywhere
-
-unimplemented str = fail ("Unimplemented: "++str)
-
-newVar :: Scope -> Ident
-newVar scope = head [x | i <- [1..],
-                         let x = identS ('v':show i),
-                         isFree scope x]
-  where
-    isFree []            x = True
-    isFree ((y,_):scope) x = x /= y && isFree scope x
-
-scopeEnv   scope = zipWith (\(x,ty) i -> (x,VGen i [])) (reverse scope) [0..]
-scopeVars  scope = map fst scope
-scopeTypes scope = zipWith (\(_,ty) scope -> (scope,ty)) scope (tails scope)
-
--- | This function takes account of zonking, and returns a set
--- (no duplicates) of unbound meta-type variables
-getMetaVars :: [(Scope,Sigma)] -> EvalM [MetaId]
-getMetaVars sc_tys = foldM (\acc (scope,ty) -> go acc ty) [] sc_tys
-  where
-    -- Get the MetaIds from a term; no duplicates in result
-    go acc (VGen i args)     = foldM go acc args
-    go acc (VSort s)         = return acc
-    go acc (VInt _)          = return acc
-    go acc (VRecType vs)    = foldM (\acc (lbl,_,v) -> go acc v) acc vs
-    go acc (VClosure _ _ _)  = return acc
-    go acc (VProd b x v1 v2) = go acc v2 >>= \acc -> go acc v1
-    go acc (VTable v1 v2)    = go acc v2 >>= \acc -> go acc v1
-    go acc (VMeta m args)
-      | m `elem` acc         = return acc
-      | otherwise            = do res <- getMeta m
-                                  case res of
-                                    Bound _ v              -> go acc v
-                                    Residuation _ Nothing  -> foldM go (m:acc) args
-                                    Residuation _ (Just v) -> go acc v
-                                    _                      -> return acc
-    go acc (VApp c f args)   = foldM go acc args
-    go acc (VFV c vs)        = foldM go acc (unvariants vs)
-    go acc (VInts _ _)      = return acc
-    go acc v                 = unimplemented ("go "++show (ppValue Unqualified 5 v))
-
--- | Eliminate any substitutions in a term
-zonkTerm :: [Ident] -> Term -> EvalM Term
-zonkTerm xs (Abs b x t) = do
-  t <- zonkTerm (x:xs) t
-  return (Abs b x t)
-zonkTerm xs (Prod b x t1 t2) = do
-  t1 <- zonkTerm xs  t1
-  t2 <- zonkTerm xs' t2
-  return (Prod b x t1 t2)
-  where
-    xs' | x == identW = xs
-        | otherwise   = x:xs
-zonkTerm xs (Meta i) = do
-  st <- getMeta i
-  case st of
-    Bound _ v           -> zonkTerm xs =<< value2termM False xs v
-    Residuation scope v -> case v of
-                            Just v  -> zonkTerm xs =<< value2termM False (map fst scope) v
-                            Nothing -> return (Meta i)
-    Narrowing _         -> return (Meta i)
-zonkTerm xs t = composOp (zonkTerm xs) t
diff --git a/src/compiler/api/GF/Interactive.hs b/src/compiler/api/GF/Interactive.hs
index 80e60ef8e..895229d94 100644
--- a/src/compiler/api/GF/Interactive.hs
+++ b/src/compiler/api/GF/Interactive.hs
@@ -14,7 +14,8 @@ 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.Compute.Concrete(normalForm,stdPredef,Globals(..))
+import qualified GF.Compile.Compute.Concrete as O(normalForm,stdPredef,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)
@@ -317,11 +318,12 @@ transactionCommand (CreateLin opts f mb_t is_alter) pgf mb_txnid = do
     compileLinTerm sgr mo f mb_t ty = do
       (t,ty) <- case mb_t of
                   Just t  -> do t <- renameSourceTerm sgr mo (Typed t ty)
-                                (t,ty) <- inferLType sgr [] t
+                                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 <- normalForm (Gl sgr stdPredef) ty
+                                             ty <- O.normalForm (O.Gl sgr O.stdPredef) ty
                                              return (t,ty)
                                Bad msg -> fail msg
       let (ctxt,res_ty) = typeFormCnc ty
@@ -344,7 +346,8 @@ transactionCommand (CreateLincat opts c mb_t) pgf mb_txnid = do
     compileLincatTerm sgr mo mb_t = do
       t <- case mb_t of
              Just t  -> do t <- renameSourceTerm sgr mo t
-                           (t,_) <- inferLType sgr [] t
+                           let g = Gl sgr (stdPredef g)
+                           (t,_) <- inferLType g t
                            return t
              Nothing -> case lookupResDef sgr (mo,identS c) of
                           Ok t    -> return t
diff --git a/src/compiler/api/GF/Term.hs b/src/compiler/api/GF/Term.hs
index 410360ea8..0b2bd2626 100644
--- a/src/compiler/api/GF/Term.hs
+++ b/src/compiler/api/GF/Term.hs
@@ -9,4 +9,4 @@ module GF.Term (renameSourceTerm,
 
 import GF.Compile.Rename
 import GF.Compile.Compute.Concrete
-import GF.Compile.TypeCheck.ConcreteNew
+import GF.Compile.TypeCheck.Concrete
diff --git a/src/compiler/gf.cabal b/src/compiler/gf.cabal
index e0dc76ccb..56875c9bb 100644
--- a/src/compiler/gf.cabal
+++ b/src/compiler/gf.cabal
@@ -127,7 +127,6 @@ library
     GF.Compile.ToAPI
     GF.Compile.TypeCheck.Abstract
     GF.Compile.TypeCheck.Concrete
-    GF.Compile.TypeCheck.ConcreteNew
     GF.Compile.TypeCheck.TC
     GF.Compile.Update
     GF.Data.BacktrackM

From 9c038ceb7c5dda39e0e8ad935e22e624eedee6d7 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 22 May 2025 11:48:21 +0200
Subject: [PATCH 010/144] more updates to get English compile

---
 .../api/GF/Compile/Compute/Concrete2.hs       |  18 +--
 .../api/GF/Compile/TypeCheck/Concrete.hs      | 119 +++++++++++-------
 src/compiler/api/GF/Grammar/Printer.hs        |   1 +
 3 files changed, 84 insertions(+), 54 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index 6c2639740..fdb9a2cf4 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -348,7 +348,8 @@ evalPredef g@(Gl gr pds) c n args =
 
 stdPredef :: Globals -> PredefTable
 stdPredef g = Map.fromList
-  [(cLength, pdArity 1 $\ \g c [v] -> fmap (VInt . genericLength) (value2string g v))
+  [(cInts,   pdArity 1 $\ \g c vs -> Const (case vs of {[VInt i] -> VInts (Just i) (Just i); vs -> VApp c (cPredef,cInts) vs}))
+  ,(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)))
   ,(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)))
@@ -972,9 +973,9 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
     listify mn cat (t1:ts) = do t2 <- listify mn cat ts
                                 return (App (App (QC (mn,identS ("Cons"++cat))) t1) t2)
 value2termM flat xs (VError msg) = evalError msg
-value2termM flat xs (VInts Nothing    Nothing) = return (App (QC (cPredef,cInts)) (Meta 0))
-value2termM flat xs (VInts (Just min) Nothing) = return (App (QC (cPredef,cInts)) (EInt min))
-value2termM flat xs (VInts _       (Just max)) = return (App (QC (cPredef,cInts)) (EInt max))
+value2termM flat xs (VInts Nothing    Nothing) = return (App (Q (cPredef,cInts)) (Meta 0))
+value2termM flat xs (VInts (Just min) Nothing) = return (App (Q (cPredef,cInts)) (EInt min))
+value2termM flat xs (VInts _       (Just max)) = return (App (Q (cPredef,cInts)) (EInt max))
 value2termM flat xs v = evalError ("value2termM" <+> ppValue Unqualified 5 v)
 
 
@@ -995,7 +996,10 @@ ppValue q d (VMeta i vs) = prec d 4 (hsep ((if i > 0 then pp "?" <> pp i else 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 (VClosure env c t) = pp "[|" <> ppTerm q 4 t <> pp "|]"
-ppValue q d (VProd _ _ _ _) = pp "VProd"
+ppValue q d (VProd bt x a b) =
+  if x == identW && bt == Explicit
+    then prec d 0 (ppValue q 4 a <+> "->" <+> ppValue q 0 b)
+    else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppValue q 0 a) <+> "->" <+> ppValue q 0 b)
 ppValue q d (VRecType xs)
   | q == Terse         = case [cat | (l,_,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
                            [cat] -> pp cat
@@ -1032,9 +1036,7 @@ ppValue q d (VError msg) = prec d 4 (pp "error" <+> ppTerm q 5 (K (show msg)))
 ppValue q d (VInts Nothing    Nothing)    = prec d 4 (pp "Ints ?")
 ppValue q d (VInts (Just min) Nothing)    = prec d 4 (pp "Ints" <+> brackets (pp min <> ".."))
 ppValue q d (VInts Nothing    (Just max)) = prec d 4 (pp "Ints" <+> brackets (".." <> pp max))
-ppValue q d (VInts (Just min) (Just max))
-   | min == max                           = prec d 4 (pp "Ints" <+> min)
-   | otherwise                            = prec d 4 (pp "Ints" <+> brackets (pp min <> ".." <> pp max))
+ppValue q d (VInts (Just min) (Just max)) = prec d 4 (pp "Ints" <+> brackets (pp min <> ".." <> pp max))
 
 ppAltern q (x,y) = ppValue q 0 x <+> '/' <+> ppValue q 0 y
 
diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index ce9ea1add..5b55826ff 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -13,7 +13,7 @@ import GF.Grammar.Lockfield
 import GF.Compile.Compute.Concrete2
 import GF.Infra.CheckM
 import GF.Data.ErrM ( Err(Ok, Bad) )
-import Control.Applicative(Applicative(..))
+import Control.Applicative(Applicative(..),(<|>))
 import Control.Monad(ap,liftM,mplus,foldM,zipWithM,forM,filterM,unless)
 import Control.Monad.ST
 import GF.Text.Pretty
@@ -68,7 +68,6 @@ inferSigma scope s t = do                                      -- GEN1
 
 vtypeInt   = VApp poison (cPredef,cInt) []
 vtypeFloat = VApp poison (cPredef,cFloat) []
-vtypeInts i= VApp poison (cPredef,cInts) [VInt i]
 vtypeStr   = VSort cStr
 vtypeStrs  = VSort cStrs
 vtypeType  = VSort cType
@@ -76,7 +75,7 @@ vtypePType = VSort cPType
 vtypeMarkup= VApp poison (cPredef,cMarkup) []
 
 tcRho :: Scope -> Choice -> Term -> Maybe Rho -> EvalM (Term, Rho)
-tcRho scope s t@(EInt i)   mb_ty = instSigma scope s t (vtypeInts i) mb_ty -- INT
+tcRho scope s t@(EInt i)   mb_ty = instSigma scope s t (VInts (Just i) Nothing) mb_ty -- INT
 tcRho scope s t@(EFloat _) mb_ty = instSigma scope s t vtypeFloat mb_ty    -- FLOAT
 tcRho scope s t@(K _)      mb_ty = instSigma scope s t vtypeStr   mb_ty    -- STR
 tcRho scope s t@(Empty)    mb_ty = instSigma scope s t vtypeStr   mb_ty
@@ -328,14 +327,38 @@ tcRho scope c t@(ExtR t1 t2) mb_ty = do
   let (c1,c2,c3,c4) = split4 c
   (t1,t1_ty) <- tcRho scope c1 t1 Nothing
   (t2,t2_ty) <- tcRho scope c2 t2 Nothing
-  case (t1_ty,t2_ty) of
-    (VSort s1,VSort s2)
+  ty <- join t1_ty t2_ty
+  instSigma scope c3 (ExtR t1 t2) ty mb_ty
+  where
+    join (VMeta i vs) ty2 = do
+      mv <- getMeta i
+      case mv of
+        Bound _ v -> do
+          g <- globals
+          join (apply g v vs) ty2
+        Residuation _ (Just ctr) -> do
+          g <- globals
+          join (apply g ctr vs) ty2
+    join ty1 (VMeta j vs) = do
+      mv <- getMeta j
+      case mv of
+        Bound _ v -> do
+          g <- globals
+          join ty1 (apply g v vs)
+        Residuation _ (Just ctr) -> do
+          g <- globals
+          join ty1 (apply g ctr vs)
+    join (VSort s1) (VSort s2)
        | (s1 == cType || s1 == cPType) &&
-         (s2 == cType || s2 == cPType) -> let sort | s1 == cPType && s2 == cPType = cPType
-                                                   | otherwise                    = cType
-                                          in instSigma scope c3 (ExtR t1 t2) (VSort sort) mb_ty
-    (VRecType rs1, VRecType rs2)       -> instSigma scope c3 (ExtR t1 t2) (VRecType (rs2++rs1)) mb_ty
-    _                                  -> evalError ("Cannot type check" <+> ppTerm Unqualified 0 t)
+         (s2 == cType || s2 == cPType) = let sort | s1 == cPType && s2 == cPType = cPType
+                                                  | otherwise                    = cType
+                                         in return (VSort sort)
+    join ty1@(VRecType _) ty2@(VRecType _) = subtype scope (Just ty1) ty2
+    join ty1            ty2            = do ty1 <- value2termM False (scopeVars scope) ty1
+                                            ty2 <- value2termM False (scopeVars scope) ty2
+                                            evalError ("Cannot type check" <+> ppTerm Unqualified 0 t $$
+                                                       "       with types" <+> (ppTerm Unqualified 0 ty1 $$
+                                                                                ppTerm Unqualified 0 ty2))
 tcRho scope c (ELin cat t) mb_ty = do  -- this could be done earlier, i.e. in the parser
   tcRho scope c (ExtR t (R [(lockLabel cat,(Just (RecType []),R []))])) mb_ty
 tcRho scope c (ELincat cat t) mb_ty = do  -- this could be done earlier, i.e. in the parser
@@ -590,7 +613,7 @@ tcPatt scope c (PP q ps) ty0 = do
   unify scope ty0 ty
   return scope
 tcPatt scope c (PInt i) ty0 = do
-  subsCheckRho scope (EInt i) (vtypeInts i) ty0
+  subsCheckRho scope (EInt i) (VInts (Just i) Nothing) ty0
   return scope
 tcPatt scope c (PString s) ty0 = do
   unify scope ty0 vtypeStr
@@ -778,35 +801,31 @@ subsCheckRho scope t (VSort s1) (VSort s2)                    -- Rule PTYPE
   | s1 == cPType && s2 == cType = return t
 subsCheckRho scope t (VApp _ p1 []) rho2                      -- for backwards compatibility
   | p1 == (cPredef,cErrorType) = return t
-subsCheckRho scope t (VApp _ p1 _) (VApp _ p2 _)              -- This is not correct but there is in the RGL nextPrec relies on it.
-  | p1 == (cPredef,cInt) && p2 == (cPredef,cInts) = return t  -- Should be only a temporary hack.
-subsCheckRho scope t (VApp _ p1 _) (VApp _ p2 _)              -- Rule INT1
-  | p1 == (cPredef,cInts) && p2 == (cPredef,cInt) = return t
-subsCheckRho scope t (VApp _ p1 [VInt i]) (VApp _ p2 [VInt j]) -- Rule INT2
-  | p1 == (cPredef,cInts) && p2 == (cPredef,cInts) = do
-      if i <= j
-        then return t
-        else evalError ("Ints" <+> i <+> "is not a subtype of" <+> "Ints" <+> j)
+subsCheckRho scope t (VApp _ p _) (VInts _ _)              -- This is not correct but nextPrec in the RGL relies on it.
+  | p == (cPredef,cInt) = return t                         -- Should be only a temporary hack.
+subsCheckRho scope t (VInts _ _) (VApp _ p _)                 -- Rule INT1
+  | p == (cPredef,cInt) = return t
+subsCheckRho scope t ty1@(VInts min1 max1) ty2@(VInts min2 max2)     -- Rule INT2
+  | i <= j    = return t
+  | otherwise = evalError ("Ints" <+> i <+> "is not a subtype of" <+> "Ints" <+> j)
+  where
+    i = fromMaybe 0 (max1 <|> min1)
+    j = fromMaybe 0 (min2 <|> max2)
 subsCheckRho scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do      -- Rule REC
   let mkAccess scope t =
         case t of
-          ExtR t1 t2 -> do (scope,mkProj1,mkWrap1) <- mkAccess scope t1
-                           (scope,mkProj2,mkWrap2) <- mkAccess scope t2
-                           return (scope
-                                  ,\l -> mkProj2 l `mplus` mkProj1 l
-                                  ,mkWrap1 . mkWrap2
-                                  )
+          ExtR t1 (R rs) ->
+                  do (scope,mkProj1,mkWrap1) <- mkAccess scope t1
+                     sequence_ [evalWarn ("Discarded field:" <+> l) | (l,_) <- rs, isNothing (lookup3 l rs2)]
+                     return (scope
+                            ,\l -> lookup l rs `mplus` mkProj1 l
+                            ,mkWrap1
+                            )
           R rs -> do sequence_ [evalWarn ("Discarded field:" <+> l) | (l,_) <- rs, isNothing (lookup3 l rs2)]
                      return (scope
                             ,\l -> lookup l rs
                             ,id
                             )
-          Vr x -> do return (scope
-                            ,\l -> do VRecType rs <- lookup x scope
-                                      ty <- lookup3 l rs
-                                      return (Nothing,P t l)
-                            ,id
-                            )
           t    -> let x = newVar scope
                   in return (((x,ty1):scope)
                             ,\l  -> return (Nothing,P (Vr x) l)
@@ -863,12 +882,16 @@ subsCheckTbl scope t p1 r1 p2 r2 = do
   p2 <- value2termM True (scopeVars scope) p2
   return (T (TTyped p2) [(PV x,t)])
 
-subtype scope Nothing (VApp c p [VInt i])
-  | p == (cPredef,cInts) = do
-      return (VInts Nothing (Just i))
-subtype scope (Just (VInts i j)) (VApp c p [VInt k])
-  | p == (cPredef,cInts) = do
-      return (VInts j (Just (maybe k (min k) i)))
+subtype scope (Just (VInts i1 j1)) (VInts i2 j2) =
+  case VInts (lift max i1 i2) (lift min j1 j2) of
+    ty@(VInts (Just i) (Just j))
+      | i > j -> evalError (ppValue Unqualified 0 ty <+> "is an empty type")
+    ty        -> return ty
+  where
+    lift f Nothing  Nothing  = Nothing
+    lift f (Just x) Nothing  = Just x
+    lift f Nothing  (Just y) = Just y
+    lift f (Just x) (Just y) = Just (f x y)
 subtype scope Nothing (VRecType ltys) = do
   lctrs <- mapM (\(l,o,ty) -> subtype scope Nothing ty >>= \ctr -> return (l,o,ctr)) ltys
   return (VRecType lctrs)
@@ -897,12 +920,16 @@ subtype scope (Just ctr) ty = do
   unify scope ctr ty
   return ty
 
-supertype scope Nothing (VApp c p [VInt i])
-  | p == (cPredef,cInts) = do
-      return (VInts (Just i) Nothing)
-supertype scope (Just (VInts i j)) (VApp c p [VInt k])
-  | p == (cPredef,cInts) = do
-      return (VInts (Just (maybe k (max k) i)) j)
+supertype scope (Just (VInts i1 j1)) (VInts i2 j2) =
+  case VInts (lift min i1 i2) (lift max j1 j2) of
+    ty@(VInts (Just i) (Just j))
+      | i > j -> evalError (ppValue Unqualified 0 ty <+> "is an empty type")
+    ty        -> return ty
+  where
+    lift f Nothing  Nothing  = Nothing
+    lift f (Just x) Nothing  = Nothing
+    lift f Nothing  (Just y) = Nothing
+    lift f (Just x) (Just y) = Just (f x y)
 supertype scope Nothing (VRecType ltys) = do
   lctrs <- mapM (\(l,o,ty) -> supertype scope Nothing ty >>= \ctr -> return (l,False,ctr)) ltys
   return (VRecType lctrs)
@@ -1009,8 +1036,8 @@ unify scope VEmpty VEmpty      = return ()
 unify scope v1 v2 = do
   t1 <- value2termM False (scopeVars scope) v1
   t2 <- value2termM False (scopeVars scope) v2
-  evalError ("Cannot unify:" <+> ppTerm Terse 0 t1 $$
-             "        with:" <+> ppTerm Terse 0 t2)
+  evalError ("Cannot unify:" <+> ppValue Terse 0 v1 $$
+             "        with:" <+> ppValue Terse 0 v2)
 
 
 -- | Invariant: tv1 is a flexible type variable
diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs
index 3f7364bbb..e9947b494 100644
--- a/src/compiler/api/GF/Grammar/Printer.hs
+++ b/src/compiler/api/GF/Grammar/Printer.hs
@@ -17,6 +17,7 @@ module GF.Grammar.Printer
            , ppTerm
            , ppPatt
            , ppValue
+           , ppBind
            , ppConstrs
            , ppQIdent
            , ppMeta

From 9a3cb2369d37eaafe983d6103359e0fc655e967d Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 22 May 2025 11:54:17 +0200
Subject: [PATCH 011/144] added missing cases for VInts

---
 src/compiler/api/GF/Compile/TypeCheck/Concrete.hs | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index 5b55826ff..116e0ebe3 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -150,6 +150,7 @@ tcRho scope c (Abs bt var body) Nothing = do                   -- ABS1
       foldM (\st (v1,v2) -> check m n st v1 >>= \st -> check m n st v2) st vs
     check m n st (VStrs vs)        =
       foldM (check m n) st vs
+    check m n xs v@(VInts _ _) = return (xs,v)
 tcRho scope c t@(Abs Implicit var body) (Just ty) = do         -- ABS2
   (bt, x, var_ty, body_ty) <- unifyFun scope ty
   if bt == Implicit
@@ -1252,6 +1253,7 @@ quantify scope t tvs ty = do
     check m n xs (VStrs vs)        = do
       (xs,vs) <- mapAccumM (check m n) xs vs
       return (xs,VStrs vs)
+    check m n xs v@(VInts _ _) = return (xs,v)
     check m n xs v = unimplemented ("check "++show (ppValue Unqualified 5 v))
 
     mapAccumM :: Monad m => (a -> b -> m (a,c)) -> a -> [b] -> m (a,[c])

From 9e6885c901fd6ae4c90e35b416c28be734442239 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 22 May 2025 11:55:29 +0200
Subject: [PATCH 012/144] fix for VInts

---
 src/compiler/api/GF/Compile/TypeCheck/Concrete.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index 116e0ebe3..e335195e3 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -150,7 +150,7 @@ tcRho scope c (Abs bt var body) Nothing = do                   -- ABS1
       foldM (\st (v1,v2) -> check m n st v1 >>= \st -> check m n st v2) st vs
     check m n st (VStrs vs)        =
       foldM (check m n) st vs
-    check m n xs v@(VInts _ _) = return (xs,v)
+    check m n st (VInts _ _) = return st
 tcRho scope c t@(Abs Implicit var body) (Just ty) = do         -- ABS2
   (bt, x, var_ty, body_ty) <- unifyFun scope ty
   if bt == Implicit

From f82b8b6e112f7baf0983ad41843e70d7048b5032 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 22 May 2025 20:06:50 +0200
Subject: [PATCH 013/144] missing cases in collectOp

---
 src/compiler/api/GF/Grammar/Macros.hs | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs
index 526969b93..92de22594 100644
--- a/src/compiler/api/GF/Grammar/Macros.hs
+++ b/src/compiler/api/GF/Grammar/Macros.hs
@@ -443,10 +443,14 @@ collectOp :: Monoid m => (Term -> m) -> Term -> m
 collectOp co trm = case trm of
   App c a      -> co c <> co a
   Abs _ _ b    -> co b
+  ImplArg t    -> co t
   Prod _ _ a b -> co a <> co b
+  Typed a b    -> co a <> co b
+  Example t _  -> co t
   S c a        -> co c <> co a
   Table a c    -> co a <> co c
   ExtR a c     -> co a <> co c
+  Opts t os    -> co t <> mconcatMap (\(a,b) -> co a <> co b) os
   R r          -> mconcatMap (\ (_,(mt,a)) -> maybe mempty co mt <> co a) r
   RecType r    -> mconcatMap (co . snd) r
   P t i        -> co t
@@ -455,9 +459,13 @@ collectOp co trm = case trm of
   Let (x,(mt,a)) b -> maybe mempty co mt <> co a <> co b
   C s1 s2      -> co s1 <> co s2
   Glue s1 s2   -> co s1 <> co s2
+  EPattType t  -> co t
   Alts t aa    -> let (x,y) = unzip aa in co t <> mconcatMap co (x <> y)
   FV ts        -> mconcatMap co ts
   Strs tt      -> mconcatMap co tt
+  ELincat _ t  -> co t
+  ELin _ t     -> co t
+  AdHocOverload ts -> mconcatMap co ts
   Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap co cs
   Reset _ ct t _-> maybe mempty co ct <> co t
   _            -> mempty -- covers K, Vr, Cn, Sort

From a0faa4853790799c785d9bd807b4104dd695e823 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 23 May 2025 15:11:00 +0200
Subject: [PATCH 014/144] progress on Finnish

---
 .../api/GF/Compile/Compute/Concrete2.hs       |  13 +-
 .../api/GF/Compile/TypeCheck/Concrete.hs      | 329 ++++++++++--------
 2 files changed, 197 insertions(+), 145 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index fdb9a2cf4..464555f1d 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE RankNTypes, BangPatterns, GeneralizedNewtypeDeriving, TupleSections #-}
 
 module GF.Compile.Compute.Concrete2
-           (Env, Scope, Value(..), Variants(..), Constraint, OptionInfo(..), ChoiceMap, cleanOptions,
+           (Env, Scope, Value(..), Variants(..), OptionInfo(..), ChoiceMap, cleanOptions,
             ConstValue(..), ConstVariants(..), Globals(..), PredefTable, EvalM,
             mapVariants, unvariants, variants2consts, consts2variants,
             runEvalM, runEvalMWithOpts, stdPredef, globals, withState,
@@ -667,11 +667,10 @@ value2term g xs v = do
     [t] -> return t
     ts  -> return (FV ts)
 
-type Constraint = Value
 data MetaState
   = Bound Scope Value
   | Narrowing   Type
-  | Residuation Scope (Maybe Constraint)
+  | Residuation Scope
 data OptionInfo
   = OptionInfo
       { optChoice  :: Choice
@@ -790,7 +789,7 @@ try f select xs = EvalM (\g k state r msgs ->
 newResiduation :: Scope -> EvalM MetaId
 newResiduation scope = EvalM (\g k (State choices metas opts) r msgs ->
   let meta_id = Map.size metas+1
-  in k meta_id (State choices (Map.insert meta_id (Residuation scope Nothing) metas) opts) r msgs)
+  in k meta_id (State choices (Map.insert meta_id (Residuation scope) metas) opts) r msgs)
 
 getMeta :: MetaId -> EvalM MetaState
 getMeta i = EvalM (\g k state r msgs ->
@@ -811,11 +810,7 @@ value2termM flat xs (VMeta i vs) = do
   case mv of
     Bound scope v -> do g <- globals
                         value2termM flat (map fst scope) (apply g v vs)
-    Residuation _ mb_ctr ->
-      case mb_ctr of
-        Just ctr -> do g <- globals
-                       value2termM flat xs (apply g ctr vs)
-        Nothing  -> foldM (\t v -> fmap (App t) (value2termM flat xs v)) (Meta i) vs
+    Residuation _ -> foldM (\t v -> fmap (App t) (value2termM flat xs v)) (Meta i) vs
 value2termM flat xs (VSusp j k vs) =
   let v = k (VGen maxBound vs)
   in value2termM flat xs v
diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index e335195e3..c90564296 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -36,7 +36,7 @@ checkLType globals t ty = do
     [tty] -> return tty
     _     -> checkError (pp "Encountered variants while type checking")
 
-checkLType' :: Choice -> Term -> Constraint -> EvalM (Term, Constraint)
+checkLType' :: Choice -> Term -> Value -> EvalM (Term, Value)
 checkLType' c t vty = do
   (t,vty) <- tcRho [] c t (Just vty)
   t <- zonkTerm [] t
@@ -52,7 +52,7 @@ inferLType globals t = do
     [tty] -> return tty
     _     -> checkError (pp "Encountered variants while type checking")
 
-inferLType' :: Term -> EvalM (Term, Constraint)
+inferLType' :: Term -> EvalM (Term, Value)
 inferLType' t = do
   (t,vty) <- inferSigma [] unit t
   t <- zonkTerm [] t
@@ -273,7 +273,8 @@ tcRho scope c (V p_ty ts) Nothing = do
   let res_ty = VMeta i []
 
   let go c t = do (t, ty) <- tcRho scope c t Nothing
-                  subsCheckRho scope t ty res_ty
+                  (t,_,_) <- subsCheckRho scope t ty res_ty
+                  return t
 
   ts <- mapCM go c2 ts
   g <- globals
@@ -305,7 +306,7 @@ tcRho scope c (R rs) (Just ty) = do
     ty              -> do lttys <- inferRecFields scope c rs
                           t <- liftM (f . R) (mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys)
                           let ty' = VRecType [(l,True,ty) | (l,t,ty) <- lttys]
-                          t <- subsCheckRho scope t ty' ty
+                          (t,_,_) <- subsCheckRho scope t ty' ty
                           return (t, ty')
 tcRho scope c (P t l) mb_ty = do
   l_ty   <- case mb_ty of
@@ -337,24 +338,26 @@ tcRho scope c t@(ExtR t1 t2) mb_ty = do
         Bound _ v -> do
           g <- globals
           join (apply g v vs) ty2
-        Residuation _ (Just ctr) -> do
-          g <- globals
-          join (apply g ctr vs) ty2
     join ty1 (VMeta j vs) = do
       mv <- getMeta j
       case mv of
         Bound _ v -> do
           g <- globals
           join ty1 (apply g v vs)
-        Residuation _ (Just ctr) -> do
-          g <- globals
-          join ty1 (apply g ctr vs)
     join (VSort s1) (VSort s2)
        | (s1 == cType || s1 == cPType) &&
          (s2 == cType || s2 == cPType) = let sort | s1 == cPType && s2 == cPType = cPType
                                                   | otherwise                    = cType
                                          in return (VSort sort)
-    join ty1@(VRecType _) ty2@(VRecType _) = subtype scope (Just ty1) ty2
+    join (VRecType rs1) (VRecType rs2) = do
+      rs <- foldM (\rs (l,o,ctr) -> extend l o ctr rs) rs1 rs2
+      return (VRecType rs)
+      where
+        extend l o1 ty1 [] = do return [(l,o1,ty1)]
+        extend l o1 ty1 ((l',o2,ty2):rs)
+          | l == l'   = do return ((l,o1,ty1):rs)
+          | otherwise = do rs <- extend l o1 ty1 rs
+                           return ((l',o2,ty2):rs)
     join ty1            ty2            = do ty1 <- value2termM False (scopeVars scope) ty1
                                             ty2 <- value2termM False (scopeVars scope) ty2
                                             evalError ("Cannot type check" <+> ppTerm Unqualified 0 t $$
@@ -453,14 +456,14 @@ evalCodomain x v (VClosure env c ty) = do
   return (eval g ((x,v):env) c ty [])
 evalCodomain x _ ty = return ty
 
-tcUnifying :: Scope -> Choice -> [Term] -> Maybe Rho -> EvalM ([Term], Constraint)
+tcUnifying :: Scope -> Choice -> [Term] -> Maybe Rho -> EvalM ([Term], Value)
 tcUnifying scope c ts mb_ty = do
   (ty,subsume) <-
     case mb_ty of
       Just ty -> do return (ty, \t ty' -> return t)
       Nothing -> do i <- newResiduation scope
                     let ty = VMeta i []
-                    return (ty, \t ty' -> subsCheckRho scope t ty' ty)
+                    return (ty, \t ty' -> subsCheckRho scope t ty' ty >>= \(t,_,_) -> return t)
 
   let go c t = do (t, ty) <- tcRho scope c t mb_ty
                   subsume t ty
@@ -558,15 +561,13 @@ resolveOverloads scope c t0 q args mb_ty = do
         zonk (VProd bt x ty1 ty2) = VProd bt x (zonk ty1) (zonk ty2)
         zonk (VMeta i vs)         =
           case Map.lookup i (metaVars state) of
-            Just (Bound _ v)              -> zonk (apply g v vs)
-            Just (Residuation _ (Just v)) -> zonk (apply g v vs)
-            _                             -> VMeta i (map zonk vs)
-        zonk (VSusp i k vs)      =
+            Just (Bound _ v)     -> zonk (apply g v vs)
+            _                    -> VMeta i (map zonk vs)
+        zonk (VSusp i k vs)       =
           case Map.lookup i (metaVars state) of
-            Just (Bound _ v)              -> zonk (apply g (k v) vs)
-            Just (Residuation _ (Just v)) -> zonk (apply g (k v) vs)
-            _                             -> VSusp i k (map zonk vs)
-        zonk v                   = v
+            Just (Bound _ v)     -> zonk (apply g (k v) vs)
+            _                    -> VSusp i k (map zonk vs)
+        zonk v                    = v
 
         one t ty state = do
           t <- withState state (zonkTerm [] t)
@@ -585,13 +586,13 @@ reapply2 scope c fun fun_ty ((ImplArg arg,arg_v,arg_ty):args) mb_ty = do -- Impl
   unless (bt == Implicit) $
      evalError (ppTerm Unqualified 0 (App fun (ImplArg arg)) <+>
                 "is an implicit argument application, but no implicit argument is expected")
-  arg <- subsCheckRho scope arg arg_ty' arg_ty
+  (arg,_,_) <- subsCheckRho scope arg arg_ty' arg_ty
   res_ty <- evalCodomain x arg_v res_ty
   reapply2 scope c (App fun (ImplArg arg)) res_ty args mb_ty
 reapply2 scope c fun fun_ty ((arg,arg_v,arg_ty):args) mb_ty = do -- Explicit arg (fallthrough) case
   (fun,fun_ty) <- instantiate scope fun fun_ty
   (_, x, arg_ty', res_ty) <- unifyFun scope fun_ty
-  arg <- subsCheckRho scope arg arg_ty arg_ty'
+  (arg,_,_) <- subsCheckRho scope arg arg_ty arg_ty'
   res_ty <- evalCodomain x arg_v res_ty
   reapply2 scope c (App fun arg) res_ty args mb_ty
 
@@ -613,9 +614,21 @@ tcPatt scope c (PP q ps) ty0 = do
   (scope,ty) <- go scope c1 (eval g [] c2 ty []) ps
   unify scope ty0 ty
   return scope
-tcPatt scope c (PInt i) ty0 = do
-  subsCheckRho scope (EInt i) (VInts (Just i) Nothing) ty0
-  return scope
+tcPatt scope c p@(PInt i) ty0 =
+  case ty0 of
+    VInts min max
+       | i <= fromMaybe i max -> return scope
+       | otherwise            -> evalError ("Ints" <+> i <+> "is not a subtype of" <+> ppValue Unqualified 0 ty0)
+    VMeta k vs -> do
+       mv <- getMeta k
+       case mv of
+         Bound _ v -> do
+           g  <- globals
+           tcPatt scope c p (apply g v vs)
+         Residuation scope1 -> do
+           setMeta k (Bound scope1 (VInts (Just i) Nothing))
+           return scope
+    _ -> evalError (pp "An integer must have an Int or Ints n type")
 tcPatt scope c (PString s) ty0 = do
   unify scope ty0 vtypeStr
   return scope
@@ -636,18 +649,38 @@ tcPatt scope c (PRep _ _ p) ty0 = do
   tcPatt scope c p vtypeStr
 tcPatt scope c (PAs x p) ty0 = do
   tcPatt ((x,ty0):scope) c p ty0
-tcPatt scope c (PR rs) ty0 = do
-  let mk_ltys []            = return []
-      mk_ltys ((l,p):rs)    = do i <- newResiduation scope
-                                 ltys <- mk_ltys rs
-                                 return ((l,p,VMeta i []) : ltys)
-      go scope c []            = return scope
-      go scope c ((l,p,ty):rs) = do let (c1,c2) = split c
-                                    scope <- tcPatt scope c1 p ty
-                                    go scope c2 rs
-  ltys <- mk_ltys rs
-  subsCheckRho scope (EPatt 0 Nothing (PR rs)) (VRecType [(l,True,ty) | (l,p,ty) <- ltys]) ty0
-  go scope c ltys
+tcPatt scope c p@(PR rs) ty0 =
+  case ty0 of
+    VRecType ltys ->
+       let go scope c []         = return scope
+           go scope c ((l,p):rs) =
+             case lookup3 l ltys of
+               Just ty -> do let (c1,c2) = split c
+                             scope <- tcPatt scope c1 p ty
+                             go scope c2 rs
+               Nothing -> do ty <- value2termM False (scopeVars scope) ty0
+                             evalError (pp "Label" <+> pp l <+> " is not defined in the type of the pattern:" $$
+                                        nest 4 (ppTerm Unqualified 0 ty))
+       in go scope c rs
+    VMeta i vs -> do
+       g  <- globals
+       mv <- getMeta i
+       case mv of
+         Bound _ v ->
+           tcPatt scope c p (apply g v vs)
+         Residuation scope1 ->
+           let go scope c []         = return (scope,[])
+               go scope c ((l,p):rs) = do
+                 i <- newResiduation scope
+                 let ty      = VMeta i []
+                     (c1,c2) = split c
+                 scope <- tcPatt scope c1 p ty
+                 (scope,ltys) <- go scope c2 rs
+                 return (scope,(l,True,ty):ltys)
+           in do (scope,ltys) <- go scope c rs
+                 setMeta i (Bound scope1 (VRecType ltys))
+                 return scope
+    _ -> evalError (pp "An record must have an record type")
 tcPatt scope c (PAlt p1 p2) ty0 = do
   let (c1,c2) = split c
   tcPatt scope c1 p1 ty0
@@ -718,62 +751,64 @@ tcRecTypeFields scope c ((l,ty):rs) mb_ty = do
 instSigma :: Scope -> Choice -> Term -> Sigma -> Maybe Rho -> EvalM (Term, Rho)
 instSigma scope s t ty1 Nothing    = return (t,ty1)           -- INST1
 instSigma scope s t ty1 (Just ty2) = do                       -- INST2
-  t <- subsCheckRho scope t ty1 ty2
+  (t,ty1,ty2) <- subsCheckRho scope t ty1 ty2
   return (t,ty2)
 
 -- | Invariant: the second argument is in weak-prenex form
-subsCheckRho :: Scope -> Term -> Sigma -> Rho -> EvalM Term
-subsCheckRho scope t (VMeta i vs1) (VMeta j vs2)
+subsCheckRho :: Scope -> Term -> Sigma -> Rho -> EvalM (Term,Sigma,Rho)
+subsCheckRho scope t ty1@(VApp _ p1 []) ty2                   -- for backwards compatibility
+  | p1 == (cPredef,cErrorType) = return (t,ty1,ty2)
+subsCheckRho scope t ty1 ty2@(VApp _ p2 [])                   -- for backwards compatibility
+  | p2 == (cPredef,cErrorType) = return (t,ty1,ty2)
+subsCheckRho scope t ty1@(VMeta i vs1) ty2@(VMeta j vs2)
   | i  == j   = do sequence_ (zipWith (unify scope) vs1 vs2)
-                   return t
+                   return (t,ty1,ty2)
   | otherwise = do
       mv <- getMeta i
       case mv of
         Bound _ v1 -> do
           g <- globals
           subsCheckRho scope t (apply g v1 vs1) (VMeta j vs2)
-        Residuation scope1 (Just ctr1) -> do
-          g <- globals
-          subsCheckRho scope t (apply g ctr1 vs1) (VMeta j vs2)
-        Residuation scope1 Nothing -> do
+        Residuation scope1 -> do
           mv <- getMeta j
           case mv of
             Bound _ v2 -> do
               g <- globals
               subsCheckRho scope t (VMeta i vs1) (apply g v2 vs2)
-            Residuation scope2 ctr2
+            Residuation scope2
               | m > n     -> do setMeta i (Bound scope1 (VMeta j vs2))
-                                return t
-              | otherwise -> case ctr2 of
-                               Nothing   -> do setMeta j (Bound scope2 (VMeta i vs2))
-                                               return t
-                               Just ctr2 -> do g <- globals
-                                               subsCheckRho scope t (VMeta i vs1) (apply g ctr2 vs2)
+                                return (t,VMeta j vs2,VMeta j vs2)
+              | otherwise -> do setMeta j (Bound scope2 (VMeta i vs1))
+                                return (t,VMeta i vs1,VMeta j vs1)
               where
                 m = length scope1
                 n = length scope2
 subsCheckRho scope t ty1@(VMeta i vs) ty2 = do
   mv <- getMeta i
   case mv of
-    Bound _ ty1 -> do
+    Bound scope' ty1 -> do
       g <- globals
-      subsCheckRho scope t (apply g ty1 vs) ty2
-    Residuation scope' ctr -> do
+      (t,ty1,ty2) <- subsCheckRho scope t (apply g ty1 vs) ty2
+      setMeta i (Bound scope' ty1)
+      return (t,ty1,ty2)
+    Residuation scope' -> do
       occursCheck scope' i scope ty2
-      ctr <- subtype scope ctr ty2
-      setMeta i (Residuation scope' (Just ctr))
-      return t
+      ty1 <- subtype scope Nothing ty2
+      setMeta i (Bound scope' ty1)
+      return (t,ty1,ty2)
 subsCheckRho scope t ty1 ty2@(VMeta i vs) = do
   mv <- getMeta i
   case mv of
-    Bound _ ty2 -> do
+    Bound scope' ty2 -> do
       g <- globals
-      subsCheckRho scope t ty1 (apply g ty2 vs)
-    Residuation scope' ctr -> do
+      (t,ty1,ty2) <- subsCheckRho scope t ty1 (apply g ty2 vs)
+      setMeta i (Bound scope' ty2)
+      return (t,ty1,ty2)
+    Residuation scope' -> do
       occursCheck scope' i scope ty1
-      ctr <- supertype scope ctr ty1
-      setMeta i (Residuation scope' (Just ctr))
-      return t
+      ty2 <- supertype scope Nothing ty1
+      setMeta i (Bound scope' ty2)
+      return (t,ty1,ty2)
 subsCheckRho scope t (VProd Implicit x ty1 ty2) rho2 = do     -- Rule SPEC
   i <- newResiduation scope
   g <- globals
@@ -784,8 +819,8 @@ subsCheckRho scope t (VProd Implicit x ty1 ty2) rho2 = do     -- Rule SPEC
 subsCheckRho scope t rho1 (VProd Implicit x ty1 ty2) = do     -- Rule SKOL
   let v = newVar scope
   ty2 <- evalCodomain x (VGen (length scope) []) ty2
-  t <- subsCheckRho ((v,ty1):scope) t rho1 ty2
-  return (Abs Implicit v t)
+  (t,ty1,ty2) <- subsCheckRho ((v,ty1):scope) t rho1 ty2
+  return (Abs Implicit v t,ty1,ty2)
 subsCheckRho scope t rho1 (VProd Explicit _ a2 r2) = do       -- Rule FUN
   (_,_,a1,r1) <- unifyFun scope rho1
   subsCheckFun scope t a1 r1 a2 r2
@@ -798,20 +833,31 @@ subsCheckRho scope t rho1 (VTable p2 r2) = do                 -- Rule TABLE
 subsCheckRho scope t (VTable p1 r1) rho2 = do                 -- Rule TABLE
   (p2,r2) <- unifyTbl scope rho2
   subsCheckTbl scope t p1 r1 p2 r2
-subsCheckRho scope t (VSort s1) (VSort s2)                    -- Rule PTYPE
-  | s1 == cPType && s2 == cType = return t
-subsCheckRho scope t (VApp _ p1 []) rho2                      -- for backwards compatibility
-  | p1 == (cPredef,cErrorType) = return t
-subsCheckRho scope t (VApp _ p _) (VInts _ _)              -- This is not correct but nextPrec in the RGL relies on it.
-  | p == (cPredef,cInt) = return t                         -- Should be only a temporary hack.
-subsCheckRho scope t (VInts _ _) (VApp _ p _)                 -- Rule INT1
-  | p == (cPredef,cInt) = return t
-subsCheckRho scope t ty1@(VInts min1 max1) ty2@(VInts min2 max2)     -- Rule INT2
-  | i <= j    = return t
-  | otherwise = evalError ("Ints" <+> i <+> "is not a subtype of" <+> "Ints" <+> j)
+subsCheckRho scope t ty1@(VSort s1) ty2@(VSort s2)            -- Rule PTYPE
+  | s1 == cPType && s2 == cType = return (t,ty1,ty2)
+subsCheckRho scope t ty1@(VApp _ p _) ty2@(VInts _ _)         -- This is not correct but nextPrec in the RGL relies on it.
+  | p == (cPredef,cInt) = return (t,ty1,ty2)                  -- Should be only a temporary hack.
+subsCheckRho scope t ty1@(VInts _ _) ty2@(VApp _ p _)         -- Rule INT1
+  | p == (cPredef,cInt) = return (t,ty1,ty2)
+subsCheckRho scope t ty1@(VInts i1 j1) ty2@(VInts i2 j2)      -- Rule INT2
+  | j1  `less1` i2  = return (t,ty1,ty2)
+  | j1' `less1` i2' = return (t,VInts i1 j1',VInts i2' j2)
+  | otherwise       = evalError ("In the term" <+> ppTerm Unqualified 0 t $$
+                                 ppValue Terse 0 ty1 <+> "is not a subtype of" <+> ppValue Terse 0 ty2)
   where
-    i = fromMaybe 0 (max1 <|> min1)
-    j = fromMaybe 0 (min2 <|> max2)
+    less1 (Just x) (Just y) = x <= y
+    less1 _        _        = False
+
+    less2 (Just x) (Just y) = x <= y
+    less2 Nothing  (Just y) = True
+    less2 _        _        = False
+
+    less3 (Just x) (Just y) = x <= y
+    less3 (Just x) Nothing  = True
+    less3 _        _        = False
+
+    j1' = if i1 `less2` i2 then i2 else j1
+    i2' = if j1 `less3` j2 then j1 else i2
 subsCheckRho scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do      -- Rule REC
   let mkAccess scope t =
         case t of
@@ -834,14 +880,9 @@ subsCheckRho scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do      -- Rule REC
                             )
 
       mkField scope l (mb_ty,t) ty1 ty2 = do
-        t <- subsCheckRho scope t ty1 ty2
+        (t,_,_) <- subsCheckRho scope t ty1 ty2
         return (l, (mb_ty,t))
 
-      lookup3 l []  = Nothing
-      lookup3 l ((l',_,v):rs)
-        | l == l'   = Just v
-        | otherwise = lookup3 l rs
-
   (scope,mkProj,mkWrap) <- mkAccess scope t
 
   let fields = [(l,ty2,lookup3 l rs1) | (l,o2,ty2) <- rs2]
@@ -850,39 +891,46 @@ subsCheckRho scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do      -- Rule REC
     missing -> evalError ("In the term" <+> pp t $$
                           "there are no values for fields:" <+> hsep missing)
   rs <- sequence [mkField scope l t ty1 ty2 | (l,ty2,Just ty1) <- fields, Just t <- [mkProj l]]
-  return (mkWrap (R (rs++[(l, (Just (RecType []),R [])) | (l,_,Nothing) <- fields, isLockLabel l])))
-subsCheckRho scope t tau1 (VFV c (VarFree vs)) = do
-  tau2 <- variants c vs
-  subsCheckRho scope t tau1 tau2
-subsCheckRho scope t (VFV c (VarFree vs)) tau2 = do
-  tau1 <- variants c vs
-  subsCheckRho scope t tau1 tau2
-subsCheckRho scope t tau1 tau2 = do                           -- Rule EQ
-  unify scope tau1 tau2                                 -- Revert to ordinary unification
-  return t
+  return (mkWrap (R (rs++[(l, (Just (RecType []),R [])) | (l,_,Nothing) <- fields, isLockLabel l])),ty1,ty2)
+subsCheckRho scope t ty1 (VFV c (VarFree vs)) = do
+  ty2 <- variants c vs
+  subsCheckRho scope t ty1 ty2
+subsCheckRho scope t (VFV c (VarFree vs)) ty2 = do
+  ty1 <- variants c vs
+  subsCheckRho scope t ty1 ty2
+subsCheckRho scope t ty1 ty2 = do                           -- Rule EQ
+  unify scope ty1 ty2                                  -- Revert to ordinary unification
+  return (t,ty1,ty2)
 
-subsCheckFun :: Scope -> Term -> Sigma -> Value -> Sigma -> Value -> EvalM Term
+subsCheckFun :: Scope -> Term -> Sigma -> Value -> Sigma -> Value -> EvalM (Term,Value,Value)
 subsCheckFun scope t a1 r1 a2 r2 = do
   let v   = newVar scope
-  vt <- subsCheckRho ((v,a2):scope) (Vr v) a2 a1
+  (vt,a2,a1) <- subsCheckRho ((v,a2):scope) (Vr v) a2 a1
   g  <- globals
-  let r1' = case r1 of
-              VClosure env c r1 -> eval g ((v,(VGen (length scope) [])):env) c r1 []
-              r1                -> r1
-      r2' = case r2 of
-              VClosure env c r2 -> eval g ((v,(VGen (length scope) [])):env) c r2 []
-              r2                -> r2
-  t  <- subsCheckRho ((v,vtypeType):scope) (App t vt) r1' r2'
-  return (Abs Explicit v t)
+  let (v1',r1') = case r1 of
+                    VClosure env c r1 -> (v,eval g ((v,(VGen (length scope) [])):env) c r1 [])
+                    r1                -> (identW,r1)
+      (v2',r2') = case r2 of
+                    VClosure env c r2 -> (v,eval g ((v,(VGen (length scope) [])):env) c r2 [])
+                    r2                -> (identW,r2)
+  (t,r1,r2)  <- subsCheckRho ((v,vtypeType):scope) (App t vt) r1' r2'
+  return (Abs Explicit v t, VProd Explicit v1' a1 r1, VProd Explicit v2' a2 r2)
 
-subsCheckTbl :: Scope -> Term -> Sigma -> Rho -> Sigma -> Rho  -> EvalM Term
+subsCheckTbl :: Scope -> Term -> Sigma -> Rho -> Sigma -> Rho  -> EvalM (Term,Value,Value)
 subsCheckTbl scope t p1 r1 p2 r2 = do
   let x = newVar scope
-  xt <- subsCheckRho ((x,p2):scope) (Vr x) p2 p1
-  t  <- subsCheckRho ((x,p2):scope) (S t xt) r1 r2
-  p2 <- value2termM True (scopeVars scope) p2
-  return (T (TTyped p2) [(PV x,t)])
+  (xt,p2,p1) <- subsCheckRho ((x,p2):scope) (Vr x) p2 p1
+  (t,r1,r2)  <- subsCheckRho ((x,p2):scope) (S t xt) r1 r2
+  p2_t <- value2termM True (scopeVars scope) p2
+  return (T (TTyped p2_t) [(PV x,t)],VTable p1 r1,VTable p2 r2)
 
+{-subtype scope Nothing              (VInts i2 j2) =
+  return (VInts Nothing j2)
+subtype scope (Just (VMeta i vs))  ty2 = do
+  g  <- globals
+  mv <- getMeta i
+  case mv of
+    Bound _ v -> subtype scope (Just (apply g v vs)) ty2-}
 subtype scope (Just (VInts i1 j1)) (VInts i2 j2) =
   case VInts (lift max i1 i2) (lift min j1 j2) of
     ty@(VInts (Just i) (Just j))
@@ -916,11 +964,17 @@ subtype scope (Just (VProd Explicit x a1 r1)) (VProd Explicit y a2 r2)
        a <- supertype scope (Just a1) a2
        r <- subtype scope (Just r1) r2
        return (VProd Explicit identW a r)
+subtype scope (Just (VApp _ p1 [])) ty2                      -- for backwards compatibility
+  | p1 == (cPredef,cErrorType) = return ty2
+subtype scope (Just ty1) (VApp _ p2 [])                      -- for backwards compatibility
+  | p2 == (cPredef,cErrorType) = return ty1
 subtype scope Nothing    ty = return ty
 subtype scope (Just ctr) ty = do
   unify scope ctr ty
   return ty
 
+supertype scope Nothing (VInts i2 j2) =
+  return (VInts i2 Nothing)
 supertype scope (Just (VInts i1 j1)) (VInts i2 j2) =
   case VInts (lift min i1 i2) (lift max j1 j2) of
     ty@(VInts (Just i) (Just j))
@@ -952,6 +1006,10 @@ supertype scope (Just (VProd Explicit x a1 r1)) (VProd Explicit y a2 r2)
        a <- subtype scope (Just a1) a2
        r <- supertype scope (Just r1) r2
        return (VProd Explicit identW a r)
+supertype scope (Just (VApp _ p1 [])) ty2                      -- for backwards compatibility
+  | p1 == (cPredef,cErrorType) = return ty2
+supertype scope (Just ty1) (VApp _ p2 [])                      -- for backwards compatibility
+  | p2 == (cPredef,cErrorType) = return ty1
 supertype scope Nothing    ty = return ty
 supertype scope (Just ctr) ty = do
   unify scope ctr ty
@@ -1000,13 +1058,13 @@ unify scope (VMeta i vs1) (VMeta j vs2)
         Bound _ v1 -> do
           g <- globals
           unify scope (apply g v1 vs1) (VMeta j vs2)
-        Residuation scope1 _ -> do
+        Residuation scope1 -> do
           mv <- getMeta j
           case mv of
             Bound _ v2 -> do
               g <- globals
               unify scope (VMeta i vs1) (apply g v2 vs2)
-            Residuation scope2 _
+            Residuation scope2
               | m > n     -> setMeta i (Bound scope1 (VMeta j vs2))
               | otherwise -> setMeta j (Bound scope2 (VMeta i vs2))
               where
@@ -1037,19 +1095,19 @@ unify scope VEmpty VEmpty      = return ()
 unify scope v1 v2 = do
   t1 <- value2termM False (scopeVars scope) v1
   t2 <- value2termM False (scopeVars scope) v2
-  evalError ("Cannot unify:" <+> ppValue Terse 0 v1 $$
-             "        with:" <+> ppValue Terse 0 v2)
+  evalError ("Cannot unify:" <+> ppValue Qualified 0 v1 $$
+             "        with:" <+> ppValue Qualified 0 v2)
 
 
 -- | Invariant: tv1 is a flexible type variable
 unifyVar :: Scope -> MetaId -> [Value] -> Tau -> EvalM ()
-unifyVar scope metaid vs ty2 = do            -- Check whether i is bound
-  mv <- getMeta metaid
+unifyVar scope i vs ty2 = do            -- Check whether i is bound
+  mv <- getMeta i
   case mv of
-    Bound _ ty1          -> do g <- globals
-                               unify scope (apply g ty1 vs) ty2
-    Residuation scope' _ -> do occursCheck scope' metaid scope ty2
-                               setMeta metaid (Bound scope' ty2)
+    Bound _ ty1        -> do g <- globals
+                             unify scope (apply g ty1 vs) ty2
+    Residuation scope' -> do occursCheck scope' i scope ty2
+                             setMeta i (Bound scope' ty2)
 
 occursCheck scope' i0 scope v =
   let m = length scope'
@@ -1131,9 +1189,8 @@ instantiate scope t (VProd Implicit x ty1 ty2) = do
            ty2                -> return ty2
   instantiate scope (App t (ImplArg (Meta i))) ty2
 instantiate scope t ty@(VMeta i args) = getMeta i >>= \case
-  Bound _ v              -> instantiate scope t v
-  Residuation _ (Just v) -> instantiate scope t v
-  _                      -> return (t,ty) -- We don't have enough information to try any instantiation
+  Bound _ v -> instantiate scope t v
+  _         -> return (t,ty) -- We don't have enough information to try any instantiation
 instantiate scope t ty = do
   return (t,ty)
 
@@ -1142,9 +1199,9 @@ skolemise :: Scope -> Sigma -> EvalM (Scope, Term->Term, Rho)
 skolemise scope ty@(VMeta i vs) = do
   mv <- getMeta i
   case mv of
-    Residuation _ _ -> return (scope,id,ty)                   -- guarded constant?
-    Bound _ ty      -> do g <- globals
-                          skolemise scope (apply g ty vs)
+    Residuation _ -> return (scope,id,ty)                   -- guarded constant?
+    Bound _ ty    -> do g <- globals
+                        skolemise scope (apply g ty vs)
 skolemise scope (VProd Implicit x ty1 ty2) = do
   let v = newVar scope
   ty2 <- evalCodomain x (VGen (length scope) []) ty2
@@ -1277,6 +1334,11 @@ type Tau   = Value -- No ForAlls anywhere
 
 unimplemented str = fail ("Unimplemented: "++str)
 
+lookup3 l []  = Nothing
+lookup3 l ((l',_,v):rs)
+  | l == l'   = Just v
+  | otherwise = lookup3 l rs
+
 newVar :: Scope -> Ident
 newVar scope = head [x | i <- [1..],
                          let x = identS ('v':show i),
@@ -1306,10 +1368,8 @@ getMetaVars sc_tys = foldM (\acc (scope,ty) -> go acc ty) [] sc_tys
       | m `elem` acc         = return acc
       | otherwise            = do res <- getMeta m
                                   case res of
-                                    Bound _ v              -> go acc v
-                                    Residuation _ Nothing  -> foldM go (m:acc) args
-                                    Residuation _ (Just v) -> go acc v
-                                    _                      -> return acc
+                                    Bound _ v -> go acc v
+                                    _         -> foldM go (m:acc) args
     go acc (VApp c f args)   = foldM go acc args
     go acc (VFV c vs)        = foldM go acc (unvariants vs)
     go acc (VInts _ _)      = return acc
@@ -1330,9 +1390,6 @@ zonkTerm xs (Prod b x t1 t2) = do
 zonkTerm xs (Meta i) = do
   st <- getMeta i
   case st of
-    Bound _ v           -> zonkTerm xs =<< value2termM False xs v
-    Residuation scope v -> case v of
-                            Just v  -> zonkTerm xs =<< value2termM False (map fst scope) v
-                            Nothing -> return (Meta i)
-    Narrowing _         -> return (Meta i)
+    Bound _ v -> zonkTerm xs =<< value2termM False xs v
+    _         -> return (Meta i)
 zonkTerm xs t = composOp (zonkTerm xs) t

From 52eb5899d487f9b03cd0304b276951a6935d5158 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 28 May 2025 14:02:06 +0000
Subject: [PATCH 015/144] added zonkValue

---
 .../api/GF/Compile/TypeCheck/ConcreteNew.hs   | 23 +++++++++++++++++++
 1 file changed, 23 insertions(+)

diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
index 9fa151701..684d50f4d 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -1283,3 +1283,26 @@ zonkTerm xs (Meta i) = do
                             Nothing -> return (Meta i)
     Narrowing _         -> return (Meta i)
 zonkTerm xs t = composOp (zonkTerm xs) t
+
+zonkValue :: Value -> EvalM Value
+zonkValue (VProd bt x ty1 ty2) = do
+  ty1 <- zonkValue ty1
+  ty2 <- zonkValue ty2
+  return (VProd bt x ty1 ty2)
+zonkValue (VMeta i vs)         = do
+  g  <- globals
+  st <- getMeta i
+  case st of
+    Bound _ v              -> zonkValue (apply g v vs)
+    Residuation _ (Just v) -> zonkValue (apply g v vs)
+    _                      -> do vs <- mapM zonkValue vs
+                                 return (VMeta i vs)
+zonkValue (VSusp i k vs)       = do
+  g  <- globals
+  st <- getMeta i
+  case st of
+    Bound _ v              -> zonkValue (apply g (k v) vs)
+    Residuation _ (Just v) -> zonkValue (apply g (k v) vs)
+    _                      -> do vs <- mapM zonkValue vs
+                                 return (VSusp i k vs)
+zonkValue v                    = return v

From 2c427b69feaa2aeb3aa11edc161119a3569b484e Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 28 May 2025 14:20:16 +0000
Subject: [PATCH 016/144] avoid using withState

---
 .../api/GF/Compile/Compute/Concrete2.hs       |  9 ++---
 .../api/GF/Compile/TypeCheck/ConcreteNew.hs   | 35 ++++++-------------
 2 files changed, 14 insertions(+), 30 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index d8e24a363..9c6d9cf56 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -4,7 +4,7 @@ module GF.Compile.Compute.Concrete2
            (Env, Scope, Value(..), Variants(..), Constraint, OptionInfo(..), ChoiceMap, cleanOptions,
             ConstValue(..), ConstVariants(..), Globals(..), PredefTable, EvalM,
             mapVariants, unvariants, variants2consts, consts2variants,
-            runEvalM, runEvalMWithOpts, stdPredef, globals, withState,
+            runEvalM, runEvalMWithOpts, stdPredef, globals,
             PredefImpl, Predef(..), ($\),
             pdCanonicalArgs, pdArity,
             normalForm, normalFlatForm,
@@ -729,9 +729,6 @@ runEvalMWithOpts g cs (EvalM f) = Check $ \(es,ws) ->
   where
     init = State cs Map.empty []
 
-withState :: State -> EvalM a -> EvalM a
-withState state (EvalM f) = EvalM $ \g k _ r ws -> f g k state r ws
-
 reset :: EvalM a -> EvalM [a]
 reset (EvalM f) = EvalM $ \g k state r ws ->
   case f g (\x state xs ws -> Success (x:xs) ws) state [] ws of
@@ -769,7 +766,7 @@ variants' c f xs = EvalM (\g k state@(State choices metas opts) r msgs ->
                      Fail    msg msgs -> Fail msg msgs
                      Success ts  msgs -> backtrack g (j+1) xs choices metas opts ts msgs
 
-try :: (a -> EvalM b) -> ([(b,State)] -> EvalM b) -> [a] -> EvalM b
+try :: (a -> EvalM b) -> ([b] -> EvalM b) -> [a] -> EvalM b
 try f select xs = EvalM (\g k state r msgs ->
   let (res,msgs') = backtrack g xs state [] msgs
   in case select res of
@@ -778,7 +775,7 @@ try f select xs = EvalM (\g k state r msgs ->
     backtrack g []     state res msgs = (res,msgs)
     backtrack g (x:xs) state res msgs =
       case f x of
-        EvalM f -> case f g (\x state res msgs -> Success ((x,state):res) msgs) state res msgs of
+        EvalM f -> case f g (\y state ys msgs -> Success (y:ys) msgs) state res msgs of
                      Fail msg _       -> backtrack g xs state res msgs
                      Success res msgs -> backtrack g xs state res msgs
 
diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
index 684d50f4d..967a577ac 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -518,45 +518,32 @@ resolveOverloads scope c t0 q args mb_ty = do
     minimum g []                    = (maxBound,err)
       where
         err = evalError (pp "Overload resolution failed")
-    minimum g (tty@((t,ty),state):ttys) =
-      let ty'      = zonk ty
-          a        = arity ty'
+    minimum g (tty@(t,ty):ttys) =
+      let a        = arity ty
           (a',res) = minimum g ttys
       in case compare a a' of
            GT -> (a',res)
-           EQ -> (a',join t ty' state res)
-           LT -> (a ,one  t ty' state)
+           EQ -> (a',join t ty res)
+           LT -> (a ,one  t ty)
       where
         arity :: Value -> Int
         arity (VProd _ _ _ ty) = 1 + arity ty
         arity _                = 0
 
-        zonk :: Value -> Value
-        zonk (VProd bt x ty1 ty2) = VProd bt x (zonk ty1) (zonk ty2)
-        zonk (VMeta i vs)         =
-          case Map.lookup i (metaVars state) of
-            Just (Bound _ v)              -> zonk (apply g v vs)
-            Just (Residuation _ (Just v)) -> zonk (apply g v vs)
-            _                             -> VMeta i (map zonk vs)
-        zonk (VSusp i k vs)      =
-          case Map.lookup i (metaVars state) of
-            Just (Bound _ v)              -> zonk (apply g (k v) vs)
-            Just (Residuation _ (Just v)) -> zonk (apply g (k v) vs)
-            _                             -> VSusp i k (map zonk vs)
-        zonk v                   = v
-
-        one t ty state = do
-          t <- withState state (zonkTerm [] t)
+        one t ty = do
           return ([t],ty)
 
-        join t ty state res = do
-          t <- withState state (zonkTerm [] t)
+        join t ty res = do
           (ts,ty') <- res
           unify scope ty ty'
           return (t:ts,ty)
 
 reapply2 :: Scope -> Choice -> Term -> Value -> [(Term,Value,Value)] -> Maybe Rho -> EvalM (Term,Rho)
-reapply2 scope c fun fun_ty []                                mb_ty = instSigma scope c fun fun_ty mb_ty
+reapply2 scope c fun fun_ty []                                mb_ty = do
+  (t,ty) <- instSigma scope c fun fun_ty mb_ty
+  t  <- zonkTerm (scopeVars scope) t
+  ty <- zonkValue ty
+  return (t,ty)
 reapply2 scope c fun fun_ty ((ImplArg arg,arg_v,arg_ty):args) mb_ty = do -- Implicit arg case
   (bt, x, arg_ty', res_ty) <- unifyFun scope fun_ty
   unless (bt == Implicit) $

From 68bab72cd366dd6b6b53fda0f40883415dbb9f3e Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 28 May 2025 19:17:45 +0000
Subject: [PATCH 017/144] remove redundant variants

---
 src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
index 967a577ac..a8113618d 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -501,9 +501,12 @@ resolveOverloads scope c t0 q args mb_ty = do
                       arg_tys <- mapCM (checkArg g) c1 args
                       let v_ttys = mapC (\c (t,ty) -> (t,eval g [] c ty [])) c2 ttys
                       try (\(fun,fun_ty) -> reapply2 scope c3 fun fun_ty arg_tys mb_ty)
-                          (\ttys -> fmap (\(ts,ty) -> (FV ts,ty)) (snd (minimum g ttys)))
+                          (\ttys -> fmap (\(ts,ty) -> (mkFV ts,ty)) (snd (minimum g ttys)))
                           v_ttys
   where
+    mkFV [t] = t
+    mkFV ts  = FV ts
+
     checkArg g c (ImplArg arg) = do
       let (c1,c2) = split c
       (arg,arg_ty) <- tcRho scope c1 arg Nothing

From a59967d5f96726ab76f75c7cb7f56c6beccfd16f Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 5 Jun 2025 11:57:31 +0000
Subject: [PATCH 018/144] added value2float, exported value2float, value2int

---
 src/compiler/api/GF/Compile/Compute/Concrete2.hs | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index 9c6d9cf56..29ecfbecf 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -8,7 +8,7 @@ module GF.Compile.Compute.Concrete2
             PredefImpl, Predef(..), ($\),
             pdCanonicalArgs, pdArity,
             normalForm, normalFlatForm,
-            eval, apply, value2term, value2termM, bubble, patternMatch, vtableSelect, State(..),
+            eval, apply, value2term, value2termM, value2int, value2float, bubble, patternMatch, vtableSelect, State(..),
             newResiduation, getMeta, setMeta, MetaState(..), variants, try,
             evalError, evalWarn, ppValue, Choice(..), unit, poison, split, split3, split4, mapC, mapCM) where
 
@@ -1101,6 +1101,12 @@ value2int g (VInt n)         = Const n
 value2int g (VFV s vs)       = CFV s (variants2consts (value2int g) vs)
 value2int g _                = RunTime
 
+value2float g (VMeta i vs)     = CSusp i (\v -> value2float g (apply g v vs))
+value2float g (VSusp i k vs)   = CSusp i (\v -> value2float g (apply g (k v) vs))
+value2float g (VFlt f)         = Const f
+value2float g (VFV s vs)       = CFV s (variants2consts (value2float g) vs)
+value2float g _                = RunTime
+
 newtype Choice = Choice { unchoice :: Integer }
   deriving (Eq,Ord,Pretty,Show)
 

From 21b44e3c55e04d7e30cc283a3f38a8d23585e8ad Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 5 Jun 2025 11:58:25 +0000
Subject: [PATCH 019/144] control structure concat'

---
 src/compiler/api/GF/Compile/Compute/Concrete2.hs     | 9 +++++++++
 src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs | 2 +-
 src/compiler/api/GF/Grammar/Predef.hs                | 1 +
 3 files changed, 11 insertions(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index 29ecfbecf..7acb76e9d 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -942,6 +942,15 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
          case ts of
            [t] -> return t
            ts  -> return (Markup identW [] ts)
+      | ctl == cConcat' = do
+         ts <- case mb_cv of
+                 Just (VInt n) -> return (genericTake n ts)
+                 Nothing       -> return ts
+                 _             -> evalError (pp "[concat: .. | ..] requires an integer constant")
+         case ts of
+           []  -> mzero
+           [t] -> return t
+           ts  -> return (Markup identW [] ts)
       | ctl == cOne =
          case (ts,mb_cv) of
            ([]  ,Nothing) -> mzero
diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
index a8113618d..74c20f2ab 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -379,7 +379,7 @@ tcRho scope c (Markup tag attrs children) mb_ty = do
   res <- mapCM (\c child -> tcRho scope c child Nothing) c2 children
   instSigma scope c3 (Markup tag attrs (map fst res)) vtypeMarkup mb_ty
 tcRho scope c (Reset ctl mb_ct t qid) mb_ty
-  | ctl == cConcat = do
+  | ctl == cConcat || ctl == cConcat' = do
       let (c1,c23) = split c
           (c2,c3 ) = split c23
       (t,_) <- tcRho scope c1 t Nothing
diff --git a/src/compiler/api/GF/Grammar/Predef.hs b/src/compiler/api/GF/Grammar/Predef.hs
index 4313042fa..5f561303e 100644
--- a/src/compiler/api/GF/Grammar/Predef.hs
+++ b/src/compiler/api/GF/Grammar/Predef.hs
@@ -63,6 +63,7 @@ cError = identS "error"
 
 -- * Used in the delimited continuations
 cConcat = identS "concat"
+cConcat' = identS "concat'"
 cOne = identS "one"
 cDefault = identS "default"
 cList = identS "list"

From 04639d2c6b19f106ec6f88077265e09b0e32b57e Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 6 Jun 2025 06:21:32 +0000
Subject: [PATCH 020/144] allow multiple tags inside control and top-level
 opers

---
 src/compiler/api/GF/Grammar/Parser.y | 35 +++++++++++++++++++---------
 1 file changed, 24 insertions(+), 11 deletions(-)

diff --git a/src/compiler/api/GF/Grammar/Parser.y b/src/compiler/api/GF/Grammar/Parser.y
index 9167e5c1c..1edeaf8bb 100644
--- a/src/compiler/api/GF/Grammar/Parser.y
+++ b/src/compiler/api/GF/Grammar/Parser.y
@@ -275,10 +275,10 @@ ParamDef
 
 OperDef :: { [(Ident,Info)] }
 OperDef
-  : Posn LhsNames ':' Exp ';'        Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $6 $4)) Nothing  ] }
-  | Posn LhsNames '=' Markup         Posn { [(i, info) | i <- $2,   info <- mkOverload Nothing   (Just (mkL $1 $5 $4))] }
-  | Posn LhsName ListArg '=' Markup  Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing   (Just (mkL $1 $6 (mkAbs $3 $5)))] }
-  | Posn LhsNames ':' Exp '=' Markup Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $7 $4)) (Just (mkL $1 $7 $6))] }
+  : Posn LhsNames ':' Exp ';'         Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $6 $4)) Nothing  ] }
+  | Posn LhsNames '=' Exp ';'         Posn { [(i, info) | i <- $2,   info <- mkOverload Nothing   (Just (mkL $1 $6 $4))] }
+  | Posn LhsName ListArg '=' Exp ';'  Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing   (Just (mkL $1 $7 (mkAbs $3 $5)))] }
+  | Posn LhsNames ':' Exp '=' Exp ';' Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $8 $4)) (Just (mkL $1 $8 $6))] }
 
 LinDef :: { [(Ident,Info)] }
 LinDef
@@ -487,8 +487,7 @@ Exp6
   | '{' ListLocDef '}'    {% mkR $2 }
   | '<' ListTupleComp '>' { R (tuple2record $2) }
   | '<' Exp ':' Exp '>'   { Typed $2 $4      }
-  | '[' Control '|' Tag ']'      { Reset (fst $2) (snd $2) $4 Nothing }
-  | '[' Control '|' Exp ']'      { Reset (fst $2) (snd $2) $4 Nothing }
+  | '[' Control '|' ListMarkup ']'      { Reset (fst $2) (snd $2) (mkMarkup $4) Nothing }
   | '(' Exp ')'           { $2 }
 
 ListExp :: { [Term] }
@@ -720,14 +719,21 @@ ERHS3 :: { ERHS }
   | '(' ERHS0 ')'         { $2         }
 
 NLG :: { Map.Map Ident Info }
-  : ListNLGDef     { Map.fromList $1 }
-  | Posn Tag 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))) }
+  : ListNLGDef             { Map.fromList $1 }
+  | 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)))) }
 
 ListNLGDef :: { [(Ident,Info)] }
 ListNLGDef
-  : {- empty -}               { []       }
-  | 'oper' OperDef ListNLGDef { $2 ++ $3 }
+  : 'oper' NLGDef            { []       }
+  | 'oper' NLGDef ListNLGDef { $2 ++ $3 }
+
+NLGDef :: { [(Ident,Info)] }
+NLGDef
+  : Posn LhsNames ':' Exp ';'             Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $6 $4)) Nothing  ] }
+  | Posn LhsNames '=' ListMarkup2         Posn { [(i, info) | i <- $2,   info <- mkOverload Nothing   (Just (mkL $1 $5 (mkMarkup $4)))] }
+  | 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
@@ -746,6 +752,10 @@ ListMarkup :: { [Term] }
   | Exp                { [$1]    }
   | Markup ListMarkup  { $1 : $2 }
 
+ListMarkup2 :: { [Term] }
+  : Markup              { [$1]    }
+  | Markup ListMarkup2  { $1 : $2 }
+
 Control :: { (Ident,Maybe Term) }
   : Ident            { ($1, Nothing) }
   | Ident ':' Exp6   { ($1, Just $3) }
@@ -884,4 +894,7 @@ 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 ts  = Markup identW [] ts
+
 }

From ceb07da0c03150c77a3ca3063c7fe2f8b18fdd0e Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 6 Jun 2025 16:57:29 +0000
Subject: [PATCH 021/144] leftover change

---
 .../api/GF/Compile/TypeCheck/Concrete.hs      | 50 +++++++++++--------
 1 file changed, 28 insertions(+), 22 deletions(-)

diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index c90564296..a48a954ae 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -406,7 +406,7 @@ tcRho scope c (Markup tag attrs children) mb_ty = do
   res <- mapCM (\c child -> tcRho scope c child Nothing) c2 children
   instSigma scope c3 (Markup tag attrs (map fst res)) vtypeMarkup mb_ty
 tcRho scope c (Reset ctl mb_ct t qid) mb_ty
-  | ctl == cConcat = do
+  | ctl == cConcat || ctl == cConcat' = do
       let (c1,c23) = split c
           (c2,c3 ) = split c23
       (t,_) <- tcRho scope c1 t Nothing
@@ -544,37 +544,22 @@ resolveOverloads scope c t0 q args mb_ty = do
     minimum g []                    = (maxBound,err)
       where
         err = evalError (pp "Overload resolution failed")
-    minimum g (tty@((t,ty),state):ttys) =
-      let ty'      = zonk ty
-          a        = arity ty'
+    minimum g (tty@(t,ty):ttys) =
+      let a        = arity ty
           (a',res) = minimum g ttys
       in case compare a a' of
            GT -> (a',res)
-           EQ -> (a',join t ty' state res)
-           LT -> (a ,one  t ty' state)
+           EQ -> (a',join t ty res)
+           LT -> (a ,one  t ty)
       where
         arity :: Value -> Int
         arity (VProd _ _ _ ty) = 1 + arity ty
         arity _                = 0
 
-        zonk :: Value -> Value
-        zonk (VProd bt x ty1 ty2) = VProd bt x (zonk ty1) (zonk ty2)
-        zonk (VMeta i vs)         =
-          case Map.lookup i (metaVars state) of
-            Just (Bound _ v)     -> zonk (apply g v vs)
-            _                    -> VMeta i (map zonk vs)
-        zonk (VSusp i k vs)       =
-          case Map.lookup i (metaVars state) of
-            Just (Bound _ v)     -> zonk (apply g (k v) vs)
-            _                    -> VSusp i k (map zonk vs)
-        zonk v                    = v
-
-        one t ty state = do
-          t <- withState state (zonkTerm [] t)
+        one t ty = do
           return ([t],ty)
 
-        join t ty state res = do
-          t <- withState state (zonkTerm [] t)
+        join t ty res = do
           (ts,ty') <- res
           ty <- supertype scope (Just ty) ty'
           return (t:ts,ty)
@@ -1393,3 +1378,24 @@ zonkTerm xs (Meta i) = do
     Bound _ v -> zonkTerm xs =<< value2termM False xs v
     _         -> return (Meta i)
 zonkTerm xs t = composOp (zonkTerm xs) t
+
+zonkValue :: Value -> EvalM Value
+zonkValue (VProd bt x ty1 ty2) = do
+  ty1 <- zonkValue ty1
+  ty2 <- zonkValue ty2
+  return (VProd bt x ty1 ty2)
+zonkValue (VMeta i vs)         = do
+  g  <- globals
+  st <- getMeta i
+  case st of
+    Bound _ v              -> zonkValue (apply g v vs)
+    _                      -> do vs <- mapM zonkValue vs
+                                 return (VMeta i vs)
+zonkValue (VSusp i k vs)       = do
+  g  <- globals
+  st <- getMeta i
+  case st of
+    Bound _ v              -> zonkValue (apply g (k v) vs)
+    _                      -> do vs <- mapM zonkValue vs
+                                 return (VSusp i k vs)
+zonkValue v                    = return v

From b9939318207f0986193163607d5974db58b26c82 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 10 Jun 2025 17:27:30 +0000
Subject: [PATCH 022/144] change the semantics of bubbling and add the len
 construction

---
 .../api/GF/Compile/Compute/Concrete2.hs       | 19 ++++++++++++++++---
 .../api/GF/Compile/TypeCheck/ConcreteNew.hs   | 11 +++++++++++
 src/compiler/api/GF/Grammar/Predef.hs         |  1 +
 3 files changed, 28 insertions(+), 3 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index 7acb76e9d..1799264ce 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -24,6 +24,7 @@ import GF.Grammar.Predef
 import GF.Grammar.Printer hiding (ppValue)
 import GF.Grammar.Lockfield(lockLabel)
 import GF.Text.Pretty hiding (empty)
+import qualified GF.Text.Pretty as PP
 import Control.Monad
 import Control.Applicative hiding (Const)
 import qualified Control.Applicative as A
@@ -411,18 +412,20 @@ bubble v = snd (bubble v)
     bubble v@(VFV c (VarFree vs))
       | null vs   = (Map.empty, v)
       | otherwise = let (union,vs') = mapAccumL descend Map.empty vs
-                    in (Map.insert c (BubbleFree (length vs),1) union, addVariants (VFV c (VarFree vs')) union)
+                    in (Map.insert c (BubbleFree (length vs),1) union, VFV c (VarFree vs'))
     bubble v@(VFV c (VarOpts n os))
       | null os   = (Map.empty, v)
       | otherwise = let (union,os') = mapAccumL (\acc (k,v) -> second (k,) $ descend acc v) Map.empty os
-                    in (Map.insert c (BubbleOpts n (fst <$> os),1) union, addVariants (VFV c (VarOpts n os')) union)
+                    in (Map.insert c (BubbleOpts n (fst <$> os),1) union, VFV c (VarOpts n os'))
     bubble (VAlts v vs) = lift1L2 VAlts v vs
     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
       in (union2, VMarkup tag attrs' vs')
-    bubble (VReset ctl mb_cv v id) = lift1 (\v -> VReset ctl mb_cv v id) v
+    bubble (VReset ctl mb_cv v id) =
+      let (union,v') = bubble v
+      in (Map.empty,VReset ctl mb_cv v' id)
     bubble (VSymCat d i0 vs) =
       let (union,vs') = mapAccumL descendC Map.empty vs
       in (union, addVariants (VSymCat d i0 vs') union)
@@ -972,6 +975,11 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
                 t <- listify mn cat ts
                 return (App (App (QC (mn,identS ("Conj"++cat))) ct) t)
            _             -> evalError (pp "[list: .. | ..] requires an argument")
+      | ctl == cLen =
+         case mb_cv of
+           Just cv  -> do g <- globals
+                          value2termM True xs (apply g cv [VInt (genericLength ts)])
+           Nothing  -> return (EInt (genericLength ts))
       | 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)
@@ -999,6 +1007,7 @@ pattVars st (PSeq _ _ p1 _ _ p2) = pattVars (pattVars st p1) p2
 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 (VMeta i vs) = prec d 4 (hsep ((if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs))
 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))
@@ -1030,6 +1039,10 @@ ppValue q d (VFV i vs) = prec d 4 ("variants" <+> pp i <+> braces (fsep (punctua
 ppValue q d (VAlts e xs) = prec d 4 ("pre" <+> braces (ppValue q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
 ppValue q d (VStrs _) = pp "VStrs"
 ppValue q d (VMarkup _ _ _) = pp "VMarkup"
+ppValue q d (VReset ctl ct t _) = pp "[" <> pp ctl <> 
+                                  maybe PP.empty (\v -> pp ':' <+> ppValue q 6 v) ct <>
+                                  pp "|" <> ppValue q 0 t <>
+                                  pp "]"
 ppValue q d (VSymCat i r rs) = pp '<' <> pp i <> pp ',' <> pp r <> pp '>'
 ppValue q d (VError msg) = prec d 4 (pp "error" <+> ppTerm q 5 (K (show msg)))
 ppValue q d (VCRecType ass) = pp "VCRecType"
diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
index 74c20f2ab..0aa5a444d 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -414,6 +414,17 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
          case ty of
            VApp c qid [] -> return (Reset ctl mb_ct t (Just qid), ty)
            _             -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty)
+  | ctl == cLen = do
+      do let (c1,c2) = split c
+         (t,_) <- tcRho scope c1 t Nothing
+         case mb_ct of
+           Just ct -> do res_ty <- case mb_ty of
+                                     Just ty -> return ty
+                                     Nothing -> do i <- newResiduation scope
+                                                   return (VMeta i [])
+                         (ct,_) <- tcRho scope c2 ct (Just (VProd Explicit identW vtypeInt res_ty))
+                         return (Reset ctl (Just ct) t Nothing, res_ty)
+           Nothing -> instSigma scope c2 (Reset ctl Nothing t Nothing) vtypeInt mb_ty
   | otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
 tcRho scope s (Opts n cs) mb_ty = do
   let (s1,s2,s3) = split3 s
diff --git a/src/compiler/api/GF/Grammar/Predef.hs b/src/compiler/api/GF/Grammar/Predef.hs
index 5f561303e..ca4ea545b 100644
--- a/src/compiler/api/GF/Grammar/Predef.hs
+++ b/src/compiler/api/GF/Grammar/Predef.hs
@@ -67,6 +67,7 @@ cConcat' = identS "concat'"
 cOne = identS "one"
 cDefault = identS "default"
 cList = identS "list"
+cLen = identS "len"
 
 -- * Hacks: dummy identifiers used in various places.
 -- Not very nice!

From 4c8549d6ddf34f85fcb357cabbb09fb3404c17ac Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 11 Jun 2025 08:48:04 +0000
Subject: [PATCH 023/144] a simple selection operation

---
 .../api/GF/Compile/Compute/Concrete2.hs       | 21 +++++++++++++++++++
 .../api/GF/Compile/TypeCheck/ConcreteNew.hs   | 15 +++++++++++++
 src/compiler/api/GF/Grammar/Predef.hs         |  4 ++++
 3 files changed, 40 insertions(+)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index 1799264ce..aad10371f 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -959,6 +959,22 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
            ([]  ,Nothing) -> mzero
            ([]  ,Just v)  -> value2termM flat xs v
            (t:ts,_)       -> return t
+      | ctl == cSelect =
+         case mb_cv of
+           Just (VInt n) | n >= 0    -> select n      ts'
+                         | otherwise -> select (-n-1) (reverse ts')
+                         where
+                           ts' = sortBy compareKey ts
+
+                           select _ []     = mzero
+                           select 0 (t:ts) =
+                             case t of
+                               R rs -> case lookup (ident2label cp1) rs  of
+                                         Just (_,t) -> return t
+                                         Nothing    -> evalError (pp "Missing label p1")
+                               _    -> evalError (pp "The term must be a record")
+                           select n (t:ts) = select (n-1) ts
+           _             -> evalError (pp "[select: .. | ..] requires an integer constant")
       | ctl == cDefault =
          case (ts,mb_cv) of
            ([]  ,Nothing) -> mzero
@@ -985,6 +1001,11 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
     listify mn cat [t1,t2] = do return (App (App (QC (mn,identS ("Base"++cat))) t1) t2)
     listify mn cat (t1:ts) = do t2 <- listify mn cat ts
                                 return (App (App (QC (mn,identS ("Cons"++cat))) t1) t2)
+
+    compareKey (R rs1) (R rs2) =
+      case (lookup (ident2label cp2) rs1, lookup (ident2label cp2) rs2) of
+        (Just (_,K s1), Just (_,K s2)) -> compare s1 s2
+
 value2termM flat xs (VError msg) = evalError msg
 value2termM flat xs (VCRecType lbls) = do
   lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
index 0aa5a444d..99d85dd67 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -396,6 +396,21 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
                                     return (Just ct,ty)
                       Nothing -> return (Nothing,ty)
       return (Reset ctl mb_ct t qid,ty)
+  | ctl == cSelect = do
+      let (c1,c2) = split c
+      ty <- case mb_ty of
+              Just ty -> return ty
+              Nothing -> do i <- newResiduation scope
+                            return (VMeta i [])
+      let rec_ty = VRecType [ (ident2label cp1, ty)
+                            , (ident2label cp2, VSort cStr)
+                            ]
+      mb_ct <- case mb_ct of
+                 Just ct -> do (ct,_) <- tcRho scope c2 ct (Just vtypeInt)
+                               return (Just ct)
+                 Nothing -> evalError (pp "[select: .. | ..] requires an integer argument")
+      (t,_) <- tcRho scope c1 t (Just rec_ty)
+      return (Reset ctl mb_ct t qid,ty)
   | ctl == cDefault = do
       let (c1,c2) = split c
       (t,ty)     <- tcRho scope c1 t mb_ty
diff --git a/src/compiler/api/GF/Grammar/Predef.hs b/src/compiler/api/GF/Grammar/Predef.hs
index ca4ea545b..f807d762a 100644
--- a/src/compiler/api/GF/Grammar/Predef.hs
+++ b/src/compiler/api/GF/Grammar/Predef.hs
@@ -65,10 +65,14 @@ cError = identS "error"
 cConcat = identS "concat"
 cConcat' = identS "concat'"
 cOne = identS "one"
+cSelect = identS "select"
 cDefault = identS "default"
 cList = identS "list"
 cLen = identS "len"
 
+cp1 = identS "p1"
+cp2 = identS "p2"
+
 -- * Hacks: dummy identifiers used in various places.
 -- Not very nice!
 

From f2de64cd346d3650f4635e482458e372ca71229f Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 7 Aug 2025 13:38:38 +0200
Subject: [PATCH 024/144] progress on the type checker

---
 src/compiler/api/GF/Compile/CheckGrammar.hs   |   8 +-
 .../api/GF/Compile/Compute/Concrete2.hs       |  35 +-
 .../api/GF/Compile/TypeCheck/Concrete.hs      | 447 ++++++++++--------
 3 files changed, 258 insertions(+), 232 deletions(-)

diff --git a/src/compiler/api/GF/Compile/CheckGrammar.hs b/src/compiler/api/GF/Compile/CheckGrammar.hs
index b366b55d6..5f0deb696 100644
--- a/src/compiler/api/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/api/GF/Compile/CheckGrammar.hs
@@ -232,12 +232,12 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
     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
       tysts0 <- lookupOverload gr (fst sm,c)  -- check against inherited ones too
-      tysts1 <- mapM (uncurry $ flip (checkLType g))
-                  [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
+      tysts1 <- sequence
+                  [checkLType g 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 $
-        sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
+      --checkUniq $
+      --  sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
       update sm c (ResOverload os [(y,x) | (x,y) <- tysts'])
 
     ResParam (Just (L loc pcs)) _ -> do
diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index 4cafea9b4..0182c93ff 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -65,7 +65,7 @@ data Value
   | VGen  {-# UNPACK #-} !Int [Value]
   | VClosure Env Choice Term
   | VProd BindType Ident Value Value
-  | VRecType [(Label, Bool, Value)]
+  | VRecType [(Label, Bool, Value)] Bool
   | VR [(Label, Value)]
   | VP Value Label [Value]
   | VExtR Value Value
@@ -89,7 +89,7 @@ data Value
   | VReset Ident (Maybe Value) Value (Maybe QIdent)
   | VSymCat Int LIndex [(LIndex, (Value, Type))]
   | VError Doc
-  | VInts (Maybe Integer) (Maybe Integer)
+  | VInts Integer Bool
 
 data Variants
   = VarFree [Value]
@@ -106,7 +106,7 @@ unvariants (VarOpts n cs) = snd <$> cs
 isCanonicalForm :: Bool -> Value -> Bool
 isCanonicalForm flat  (VClosure {})       = True
 isCanonicalForm flat  (VProd b x d cod)   = isCanonicalForm flat d && isCanonicalForm flat cod
-isCanonicalForm flat  (VRecType fs)       = all (\(l,_,ty) -> isCanonicalForm flat ty) fs
+isCanonicalForm flat  (VRecType fs _)     = all (\(l,_,ty) -> isCanonicalForm flat ty) fs
 isCanonicalForm flat  (VR {})             = True
 isCanonicalForm flat  (VTable d cod)      = isCanonicalForm flat d && isCanonicalForm flat cod
 isCanonicalForm flat  (VT {})             = True
@@ -200,7 +200,7 @@ 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)
+eval g env s (RecType lbls) []  = VRecType (mapC (\s (lbl,ty) -> (lbl, True, eval g env s ty [])) s lbls) 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 $$
@@ -214,7 +214,7 @@ eval g env s (P t lbl)      vs  = let project (VR as)        = case lookup lbl a
 eval g env s (ExtR t1 t2)   []  = let (s1,s2) = split s
 
                                       extend (VR       as1) (VR       as2)   = VR       (foldl (\as (lbl,v) -> update lbl v as) as1 as2)
-                                      extend (VRecType as1) (VRecType as2)   = VRecType (foldl (\as (lbl,o,v) -> update3 lbl o v as) as1 as2)
+                                      extend (VRecType as1 e1) (VRecType as2 e2)=VRecType (foldl (\as (lbl,o,v) -> update3 lbl o v as) as1 as2) (e1 || e2)
                                       extend (VFV i fvs)    v2               = VFV i (mapVariants (`extend` v2) fvs)
                                       extend v1             (VFV i fvs)      = VFV i (mapVariants (v1 `extend`) fvs)
                                       extend (VMeta i vs)   v2               = VSusp i (\v -> extend (apply g v vs) v2) []
@@ -348,7 +348,7 @@ evalPredef g@(Gl gr pds) c n args =
 
 stdPredef :: Globals -> PredefTable
 stdPredef g = Map.fromList
-  [(cInts,   pdArity 1 $\ \g c vs -> Const (case vs of {[VInt i] -> VInts (Just i) (Just i); vs -> VApp c (cPredef,cInts) vs}))
+  [(cInts,   pdArity 1 $\ \g c vs -> Const (case vs of {[VInt i] -> VInts i False; vs -> VApp c (cPredef,cInts) vs}))
   ,(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)))
   ,(cDrop,   pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericDrop (value2int g v1) (value2string g v2)))
@@ -392,9 +392,9 @@ bubble v = snd (bubble v)
     bubble (VGen i vs) = liftL (VGen i) vs
     bubble (VClosure env c t) = liftL' (\env -> VClosure env c t) env
     bubble (VProd bt x v1 v2) = lift2 (VProd bt x) v1 v2
-    bubble v@(VRecType lbls) =
+    bubble v@(VRecType lbls ext) =
       let (union,lbls') = mapAccumL descendR Map.empty lbls
-      in (union, addVariants (VRecType lbls') union)
+      in (union, addVariants (VRecType lbls' ext) union)
     bubble (VR as) = liftL' VR as
     bubble (VP v l vs) = lift1L (\v vs -> VP v l vs) v vs
     bubble (VExtR v1 v2) = lift2 VExtR v1 v2
@@ -830,7 +830,7 @@ 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 _) = do
   lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
   return (RecType lbls)
 value2termM flat xs (VR as) = do
@@ -974,9 +974,7 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
     listify mn cat (t1:ts) = do t2 <- listify mn cat ts
                                 return (App (App (QC (mn,identS ("Cons"++cat))) t1) t2)
 value2termM flat xs (VError msg) = evalError msg
-value2termM flat xs (VInts Nothing    Nothing) = return (App (Q (cPredef,cInts)) (Meta 0))
-value2termM flat xs (VInts (Just min) Nothing) = return (App (Q (cPredef,cInts)) (EInt min))
-value2termM flat xs (VInts _       (Just max)) = return (App (Q (cPredef,cInts)) (EInt max))
+value2termM flat xs (VInts n _) = return (App (Q (cPredef,cInts)) (EInt n))
 value2termM flat xs v = evalError ("value2termM" <+> ppValue Unqualified 5 v)
 
 
@@ -1001,13 +999,13 @@ ppValue q d (VProd bt x a b) =
   if x == identW && bt == Explicit
     then prec d 0 (ppValue q 4 a <+> "->" <+> ppValue q 0 b)
     else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppValue q 0 a) <+> "->" <+> ppValue q 0 b)
-ppValue q d (VRecType xs)
+ppValue q d (VRecType xs ext)
   | 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 <+> (if o then ":" else ":?") <+> ppValue q 0 v | (l,o,v) <- xs]))
+    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 (VP v l vs) = prec d 5 (hsep (ppValue q 5 v <> '.' <> l : map (ppValue q 5) vs))
 ppValue q d (VExtR _ _) = pp "VExtR"
@@ -1027,17 +1025,16 @@ ppValue q d VEmpty = pp "[]"
 ppValue q d (VC v1 v2) = prec d 1 (hang (ppValue q 2 v1) 2 ("++" <+> ppValue q 1 v2))
 ppValue q d (VGlue v1 v2) = prec d 2 (ppValue q 3 v1 <+> '+'  <+> ppValue q 2 v2)
 ppValue q d (VPatt _ _ _) = pp "VPatt"
-ppValue q d (VPattType _) = pp "VPattType"
+ppValue q d (VPattType v) = prec d 4 ("pattern" <+> ppValue q 0 v)
 ppValue q d (VFV i vs) = prec d 4 ("variants" <+> pp i <+> braces (fsep (punctuate ';' (map (ppValue q 0) (unvariants vs)))))
 ppValue q d (VAlts e xs) = prec d 4 ("pre" <+> braces (ppValue q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
 ppValue q d (VStrs _) = pp "VStrs"
 ppValue q d (VMarkup _ _ _) = pp "VMarkup"
 ppValue q d (VSymCat i r rs) = pp '<' <> pp i <> pp ',' <> pp r <> pp '>'
 ppValue q d (VError msg) = prec d 4 (pp "error" <+> ppTerm q 5 (K (show msg)))
-ppValue q d (VInts Nothing    Nothing)    = prec d 4 (pp "Ints ?")
-ppValue q d (VInts (Just min) Nothing)    = prec d 4 (pp "Ints" <+> brackets (pp min <> ".."))
-ppValue q d (VInts Nothing    (Just max)) = prec d 4 (pp "Ints" <+> brackets (".." <> pp max))
-ppValue q d (VInts (Just min) (Just max)) = prec d 4 (pp "Ints" <+> brackets (pp min <> ".." <> pp max))
+ppValue q d (VInts n ext)
+  | ext       = prec d 4 (pp "Ints" <+> brackets (pp n <> ".."))
+  | otherwise = prec d 4 (pp "Ints" <+> pp n)
 
 ppAltern q (x,y) = ppValue q 0 x <+> '/' <+> ppValue q 0 y
 
diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index a48a954ae..954c31452 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -75,7 +75,7 @@ vtypePType = VSort cPType
 vtypeMarkup= VApp poison (cPredef,cMarkup) []
 
 tcRho :: Scope -> Choice -> Term -> Maybe Rho -> EvalM (Term, Rho)
-tcRho scope s t@(EInt i)   mb_ty = instSigma scope s t (VInts (Just i) Nothing) mb_ty -- INT
+tcRho scope s t@(EInt i)   mb_ty = instSigma scope s t (VInts i True) mb_ty -- INT
 tcRho scope s t@(EFloat _) mb_ty = instSigma scope s t vtypeFloat mb_ty    -- FLOAT
 tcRho scope s t@(K _)      mb_ty = instSigma scope s t vtypeStr   mb_ty    -- STR
 tcRho scope s t@(Empty)    mb_ty = instSigma scope s t vtypeStr   mb_ty
@@ -117,7 +117,7 @@ tcRho scope c (Abs bt var body) Nothing = do                   -- ABS1
         VClosure env c t -> do g  <- globals
                                check m (n+1) (b,x:xs) (eval g ((x,VGen n []):env) c t [])
         v2               -> check m n st v2
-    check m n st (VRecType as)     = foldM (\st (l,_,v) -> check m n st v) st as
+    check m n st (VRecType as _)   = foldM (\st (l,_,v) -> check m n st v) st as
     check m n st (VR as)           =
       foldM (\st (lbl,tnk) -> check m n st tnk) st as
     check m n st (VP v l vs)       =
@@ -200,7 +200,7 @@ tcRho scope c (FV ts) mb_ty = do
 tcRho scope s t@(Sort _) mb_ty = do
   instSigma scope s t vtypeType mb_ty
 tcRho scope c t@(RecType rs) Nothing   = do
-  (rs,mb_ty) <- tcRecTypeFields scope c rs Nothing
+  (rs,mb_ty) <- tcRecTypeFields scope c [] rs Nothing
   return (RecType rs,fromMaybe vtypePType mb_ty)
 tcRho scope c t@(RecType rs) (Just ty) = do
   (scope,f,ty') <- skolemise scope ty
@@ -214,7 +214,7 @@ tcRho scope c t@(RecType rs) (Just ty) = do
     ty        -> do ty <- value2termM False (scopeVars scope) ty
                     evalError ("The record type" <+> ppTerm Unqualified 0 t $$
                                "cannot be of type" <+> ppTerm Unqualified 0 ty)
-  (rs,mb_ty) <- tcRecTypeFields scope c rs (Just ty')
+  (rs,mb_ty) <- tcRecTypeFields scope c [] rs (Just ty')
   return (f (RecType rs),ty)
 tcRho scope s t@(Table p res) mb_ty = do
   let (s1,s23) = split s
@@ -241,15 +241,13 @@ tcRho scope c (S t p) mb_ty = do
   return (S t p, res_ty)
 tcRho scope c (T tt ps) Nothing = do                           -- ABS1/AABS1 for tables
   let (c1,c2) = split c
-  let mk_val i = VMeta i []
-  p_ty   <- case tt of
-              TRaw      -> fmap mk_val $ newResiduation scope
-              TTyped ty -> do let (c3,c4) = split c1
-                              (ty, _) <- tcRho scope c3 ty (Just vtypeType)
-                              g <- globals
-                              return (eval g (scopeEnv scope) c4 ty [])
-  res_ty <- fmap mk_val $ newResiduation scope
-  ps <- tcCases scope c2 ps p_ty res_ty
+  mb_p_ty <- case tt of
+               TRaw      -> return Nothing
+               TTyped ty -> do let (c3,c4) = split c1
+                               (ty, _) <- tcRho scope c3 ty (Just vtypeType)
+                               g <- globals
+                               return (Just (eval g (scopeEnv scope) c4 ty []))
+  (ps,p_ty,res_ty) <- tcCases scope c2 ps mb_p_ty Nothing
   p_ty_t <- value2termM True [] p_ty
   return (T (TTyped p_ty_t) ps, VTable p_ty res_ty)
 tcRho scope c (T tt ps) (Just ty) = do                         -- ABS2/AABS2 for tables
@@ -262,8 +260,9 @@ tcRho scope c (T tt ps) (Just ty) = do                         -- ABS2/AABS2 for
     TTyped ty -> do let (c1,c2) = split c12
                     (ty, _) <- tcRho scope c1 ty (Just vtypeType)
                     g <- globals
-                    unify scope (eval g (scopeEnv scope) c2 ty []) p_ty
-  ps <- tcCases scope c3 ps p_ty res_ty
+                    subsCheckRho scope (Meta 0) (eval g (scopeEnv scope) c2 ty []) p_ty
+                    return ()
+  (ps,p_ty,res_ty) <- tcCases scope c3 ps (Just p_ty) (Just res_ty)
   p_ty_t <- value2termM True (scopeVars scope) p_ty
   return (f (T (TTyped p_ty_t) ps), VTable p_ty res_ty)
 tcRho scope c (V p_ty ts) Nothing = do
@@ -290,22 +289,22 @@ tcRho scope c (V p_ty0 ts) (Just ty) = do
   ts <- mapCM (\c t -> fmap fst $ tcRho scope c t (Just res_ty)) c3 ts
   return (V p_ty0 ts, VTable p_ty res_ty)
 tcRho scope c (R rs) Nothing = do
-  lttys <- inferRecFields scope c rs
+  lttys <- inferRecFields scope c [] rs
   rs <- mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
   return (R        rs,
-          VRecType [(l,True,ty) | (l,t,ty) <- lttys]
+          VRecType [(l,True,ty) | (l,t,ty) <- lttys] False
          )
 tcRho scope c (R rs) (Just ty) = do
   (scope,f,ty') <- skolemise scope ty
   case ty' of
-    (VRecType ltys) -> do lttys <- checkRecFields scope c rs ltys
+    (VRecType ltys _)->do lttys <- checkRecFields scope c [] rs ltys
                           rs <- mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
                           return ((f . R)  rs,
-                                  VRecType [(l,True,ty) | (l,t,ty) <- lttys]
+                                  VRecType [(l,True,ty) | (l,t,ty) <- lttys] False
                                  )
-    ty              -> do lttys <- inferRecFields scope c rs
+    ty              -> do lttys <- inferRecFields scope c [] rs
                           t <- liftM (f . R) (mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys)
-                          let ty' = VRecType [(l,True,ty) | (l,t,ty) <- lttys]
+                          let ty' = VRecType [(l,True,ty) | (l,t,ty) <- lttys] False
                           (t,_,_) <- subsCheckRho scope t ty' ty
                           return (t, ty')
 tcRho scope c (P t l) mb_ty = do
@@ -313,7 +312,7 @@ tcRho scope c (P t l) mb_ty = do
               Just ty -> return ty
               Nothing -> do i <- newResiduation scope
                             return (VMeta i [])
-  (t,t_ty) <- tcRho scope c t (Just (VRecType [(l,True,l_ty)]))
+  (t,t_ty) <- tcRho scope c t (Just (VRecType [(l,True,l_ty)] True))
   return (P t l,l_ty)
 tcRho scope c (C t1 t2) mb_ty = do
   let (c1,c2,c3,c4) = split4 c
@@ -325,12 +324,21 @@ tcRho scope c (Glue t1 t2) mb_ty = do
   (t1,t1_ty) <- tcRho scope c1 t1 (Just vtypeStr)
   (t2,t2_ty) <- tcRho scope c2 t2 (Just vtypeStr)
   instSigma scope c3 (Glue t1 t2) vtypeStr mb_ty
-tcRho scope c t@(ExtR t1 t2) mb_ty = do
-  let (c1,c2,c3,c4) = split4 c
-  (t1,t1_ty) <- tcRho scope c1 t1 Nothing
-  (t2,t2_ty) <- tcRho scope c2 t2 Nothing
-  ty <- join t1_ty t2_ty
-  instSigma scope c3 (ExtR t1 t2) ty mb_ty
+tcRho scope c t@(ExtR t1 t2) mb_ty =
+  case (mb_ty,t2) of
+    (Just (VRecType ltys ext),R ss) -> do
+       let ll2 = map fst ss
+           (c1,c2) = split c
+       (t1,t1_ty) <- tcRho scope c1 t1 (Just (VRecType [field | field@(l,_,_) <- ltys, not (elem l ll2)] ext))
+       (t2,t2_ty) <- tcRho scope c2 t2 (Just (VRecType [field | field@(l,_,_) <- ltys, elem l ll2] ext))
+       ty <- join t1_ty t2_ty
+       return (ExtR t1 t2, ty)
+    _ -> do
+       let (c1,c2,c3,c4) = split4 c
+       (t1,t1_ty) <- tcRho scope c1 t1 Nothing
+       (t2,t2_ty) <- tcRho scope c2 t2 Nothing
+       ty <- join t1_ty t2_ty
+       instSigma scope c3 (ExtR t1 t2) ty mb_ty
   where
     join (VMeta i vs) ty2 = do
       mv <- getMeta i
@@ -349,9 +357,9 @@ tcRho scope c t@(ExtR t1 t2) mb_ty = do
          (s2 == cType || s2 == cPType) = let sort | s1 == cPType && s2 == cPType = cPType
                                                   | otherwise                    = cType
                                          in return (VSort sort)
-    join (VRecType rs1) (VRecType rs2) = do
+    join (VRecType rs1 ext1) (VRecType rs2 ext2) = do
       rs <- foldM (\rs (l,o,ctr) -> extend l o ctr rs) rs1 rs2
-      return (VRecType rs)
+      return (VRecType rs (ext1 || ext2))
       where
         extend l o1 ty1 [] = do return [(l,o1,ty1)]
         extend l o1 ty1 ((l',o2,ty2):rs)
@@ -388,15 +396,14 @@ tcRho scope c (EPattType ty) mb_ty = do
   (ty, _) <- tcRho scope c1 ty (Just vtypeType)
   instSigma scope c2 (EPattType ty) vtypeType mb_ty
 tcRho scope c t@(EPatt min max p) mb_ty = do
-  (scope,f,ty) <- case mb_ty of
-                    Nothing -> do i <- newResiduation scope
-                                  return (scope,id,VMeta i [])
-                    Just ty -> do (scope,f,ty) <- skolemise scope ty
-                                  case ty of
-                                    VPattType ty -> return (scope,f,ty)
-                                    _            -> evalError (ppTerm Unqualified 0 t <+> "must be of pattern type but" <+> ppTerm Unqualified 0 t <+> "is expected")
-  tcPatt scope c p ty
-  return (f (EPatt min max p), ty)
+  (scope,f,mb_ty) <- case mb_ty of
+                       Nothing -> return (scope,id,Nothing)
+                       Just ty -> do (scope,f,ty) <- skolemise scope ty
+                                     case ty of
+                                       VPattType ty -> return (scope,f,Just ty)
+                                       _            -> evalError (ppTerm Unqualified 0 t <+> "must be of pattern type but" <+> ppTerm Unqualified 0 t <+> "is expected")
+  (_,ty) <- tcPatt scope c p mb_ty
+  return (f (EPatt min max p), VPattType ty)
 tcRho scope c (Markup tag attrs children) mb_ty = do
   let (c1,c2,c3,c4) = split4 c
   attrs <- mapCM (\c (id,t) -> do
@@ -471,13 +478,13 @@ tcUnifying scope c ts mb_ty = do
   ts <- mapCM go c ts
   return (ts,ty)
 
-tcCases scope c []         p_ty res_ty = return []
-tcCases scope c ((p,t):cs) p_ty res_ty = do
+tcCases scope c []         (Just p_ty) (Just res_ty) = return ([],p_ty,res_ty)
+tcCases scope c ((p,t):cs) mb_p_ty     mb_res_ty     = do
   let (c1,c2,c3,c4) = split4 c
-  scope' <- tcPatt scope c1 p p_ty
-  (t,_)  <- tcRho scope' c2 t (Just res_ty)
-  cs <- tcCases scope c3 cs p_ty res_ty
-  return ((p,t):cs)
+  (scope',p_ty) <- tcPatt scope c1 p mb_p_ty
+  (t,res_ty)  <- tcRho scope' c2 t mb_res_ty
+  (cs,p_ty,res_ty) <- tcCases scope c3 cs (Just p_ty) (Just res_ty)
+  return ((p,t):cs,p_ty,res_ty)
 
 tcApp scope c t0 (App fun arg) args mb_ty = tcApp scope c t0 fun (arg:args) mb_ty     -- APP
 tcApp scope c t0 t@(Q id)      args mb_ty = resolveOverloads scope c t0 id args mb_ty -- VAR (global)
@@ -581,11 +588,18 @@ reapply2 scope c fun fun_ty ((arg,arg_v,arg_ty):args) mb_ty = do -- Explicit arg
   res_ty <- evalCodomain x arg_v res_ty
   reapply2 scope c (App fun arg) res_ty args mb_ty
 
-tcPatt scope c PW        ty0 =
-  return scope
-tcPatt scope c (PV x)    ty0 =
-  return ((x,ty0):scope)
-tcPatt scope c (PP q ps) ty0 = do
+tcPatt scope c PW        Nothing    = do
+  i <- newResiduation scope
+  return (scope,VMeta i [])
+tcPatt scope c PW        (Just ty0) =
+  return (scope,ty0)
+tcPatt scope c (PV x)    Nothing    = do
+  i <- newResiduation scope
+  let ty = VMeta i []
+  return ((x,ty):scope,ty)
+tcPatt scope c (PV x)    (Just ty) =
+  return ((x,ty):scope,ty)
+tcPatt scope c (PP q ps) mb_ty = do
   g@(Gl gr _) <- globals
   ty <- case lookupResType gr q of
           Ok ty   -> return ty
@@ -593,111 +607,153 @@ tcPatt scope c (PP q ps) ty0 = do
   let go scope c ty []     = return (scope,ty)
       go scope c ty (p:ps) = do (_,_,arg_ty,res_ty) <- unifyFun scope ty
                                 let (c1,c2) = split c
-                                scope <- tcPatt scope c1 p arg_ty
+                                (scope,arg_ty) <- tcPatt scope c1 p (Just arg_ty)
                                 go scope c2 res_ty ps
   let (c1,c2) = split c
-  (scope,ty) <- go scope c1 (eval g [] c2 ty []) ps
-  unify scope ty0 ty
-  return scope
-tcPatt scope c p@(PInt i) ty0 =
-  case ty0 of
-    VInts min max
-       | i <= fromMaybe i max -> return scope
-       | otherwise            -> evalError ("Ints" <+> i <+> "is not a subtype of" <+> ppValue Unqualified 0 ty0)
-    VMeta k vs -> do
+  (scope,res_ty) <- go scope c1 (eval g [] c2 ty []) ps
+  case mb_ty of
+    Just ty -> unify scope ty res_ty
+    Nothing -> return ()
+  return (scope,res_ty)
+tcPatt scope c p@(PInt i) mb_ty =
+  case mb_ty of
+    Just ty0@(VInts n ext)
+       | i <= n    -> return (scope,ty0)
+       | ext       -> return (scope,VInts i ext)
+       | otherwise -> evalError ("Ints" <+> i <+> "is not a subtype of" <+> ppValue Unqualified 0 ty0)
+    Just ty0@(VMeta k vs) -> do
        mv <- getMeta k
        case mv of
-         Bound _ v -> do
+         Bound scope1 v -> do
            g  <- globals
-           tcPatt scope c p (apply g v vs)
+           (scope,ty) <- tcPatt scope c p (Just (apply g v vs))
+           setMeta k (Bound scope1 ty)
+           return (scope,ty0)
          Residuation scope1 -> do
-           setMeta k (Bound scope1 (VInts (Just i) Nothing))
-           return scope
+           setMeta k (Bound scope1 (VInts i True))
+           return (scope,ty0)
+    Nothing -> return (scope,VInts i True)
     _ -> evalError (pp "An integer must have an Int or Ints n type")
-tcPatt scope c (PString s) ty0 = do
-  unify scope ty0 vtypeStr
-  return scope
-tcPatt scope c PChar ty0 = do
-  unify scope ty0 vtypeStr
-  return scope
-tcPatt scope c (PChars cs) ty0 = do
-  unify scope ty0 vtypeStr
-  return scope
-tcPatt scope c (PSeq _ _ p1 _ _ p2) ty0 = do
-  unify scope ty0 vtypeStr
+tcPatt scope c (PString s) mb_ty = do
+  case mb_ty of
+    Just ty -> unify scope ty vtypeStr
+    Nothing -> return ()
+  return (scope,vtypeStr)
+tcPatt scope c PChar mb_ty = do
+  case mb_ty of
+    Just ty -> unify scope ty vtypeStr
+    Nothing -> return ()
+  return (scope,vtypeStr)
+tcPatt scope c (PChars cs) mb_ty = do
+  case mb_ty of
+    Just ty -> unify scope ty vtypeStr
+    Nothing -> return ()
+  return (scope,vtypeStr)
+tcPatt scope c (PSeq _ _ p1 _ _ p2) mb_ty = do
+  case mb_ty of
+    Just ty -> unify scope ty vtypeStr
+    Nothing -> return ()
   let (c1,c2) = split c
-  scope <- tcPatt scope c1 p1 vtypeStr
-  scope <- tcPatt scope c2 p2 vtypeStr
-  return scope
-tcPatt scope c (PRep _ _ p) ty0 = do
-  unify scope ty0 vtypeStr
-  tcPatt scope c p vtypeStr
-tcPatt scope c (PAs x p) ty0 = do
-  tcPatt ((x,ty0):scope) c p ty0
-tcPatt scope c p@(PR rs) ty0 =
-  case ty0 of
-    VRecType ltys ->
-       let go scope c []         = return scope
-           go scope c ((l,p):rs) =
-             case lookup3 l ltys of
-               Just ty -> do let (c1,c2) = split c
-                             scope <- tcPatt scope c1 p ty
-                             go scope c2 rs
-               Nothing -> do ty <- value2termM False (scopeVars scope) ty0
-                             evalError (pp "Label" <+> pp l <+> " is not defined in the type of the pattern:" $$
-                                        nest 4 (ppTerm Unqualified 0 ty))
-       in go scope c rs
-    VMeta i vs -> do
-       g  <- globals
+  (scope,_) <- tcPatt scope c1 p1 (Just vtypeStr)
+  (scope,_) <- tcPatt scope c2 p2 (Just vtypeStr)
+  return (scope,vtypeStr)
+tcPatt scope c (PRep _ _ p) mb_ty = do
+  case mb_ty of
+    Just ty -> unify scope ty vtypeStr
+    Nothing -> return ()
+  tcPatt scope c p (Just vtypeStr)
+tcPatt scope c (PAs x p) mb_ty = do
+  ty <- case mb_ty of
+          Just ty -> return ty
+          Nothing -> do i <- newResiduation scope
+                        return (VMeta i [])
+  tcPatt ((x,ty):scope) c p (Just ty)
+tcPatt scope c p@(PR rs) mb_ty =
+  case mb_ty of
+    Just (VRecType ltys ext) -> check scope c rs ltys ext
+    Just ty0@(VMeta i vs) -> do
        mv <- getMeta i
        case mv of
-         Bound _ v ->
-           tcPatt scope c p (apply g v vs)
+         Bound scope1 v ->
+              do g <- globals
+                 (scope,ty) <- tcPatt scope c p (Just (apply g v vs))
+                 setMeta i (Bound scope1 ty)
+                 return (scope,ty0)
          Residuation scope1 ->
-           let go scope c []         = return (scope,[])
-               go scope c ((l,p):rs) = do
-                 i <- newResiduation scope
-                 let ty      = VMeta i []
-                     (c1,c2) = split c
-                 scope <- tcPatt scope c1 p ty
-                 (scope,ltys) <- go scope c2 rs
-                 return (scope,(l,True,ty):ltys)
-           in do (scope,ltys) <- go scope c rs
-                 setMeta i (Bound scope1 (VRecType ltys))
-                 return scope
+              do (scope,ltys) <- infer scope c rs
+                 setMeta i (Bound scope1 (VRecType ltys True))
+                 return (scope,ty0)
+    Nothing ->do (scope,ltys) <- infer scope c rs
+                 return (scope,VRecType ltys True)
     _ -> evalError (pp "An record must have an record type")
-tcPatt scope c (PAlt p1 p2) ty0 = do
+  where
+    check scope c []         ltys ext = return (scope,VRecType ltys ext)
+    check scope c ((l,p):rs) ltys ext =
+      case lookup3 l ltys of
+        Just ty -> do let (c1,c2) = split c
+                      (scope,ty) <- tcPatt scope c1 p (Just ty)
+                      check scope c2 rs (update3 l True ty ltys) ext
+        Nothing
+          | ext -> do let (c1,c2) = split c
+                      (scope,ty) <- tcPatt scope c1 p Nothing
+                      check scope c2 rs (ltys++[(l,True,ty)]) ext
+          | otherwise
+                -> do ty <- value2termM False (scopeVars scope) (VRecType ltys ext)
+                      evalError (pp "Label" <+> pp l <+> " is not defined in the type of the pattern:" $$
+                                 nest 4 (ppTerm Unqualified 0 ty))
+
+    infer scope c []         = return (scope,[])
+    infer scope c ((l,p):rs) = do
+      let (c1,c2) = split c
+      (scope,ty) <- tcPatt scope c1 p Nothing
+      (scope,ltys) <- infer scope c2 rs
+      return (scope,(l,True,ty):ltys)
+tcPatt scope c (PNeg p) mb_ty = do
+  (_,ty) <- tcPatt scope c p mb_ty
+  return (scope, ty)
+tcPatt scope c (PAlt p1 p2) mb_ty = do
   let (c1,c2) = split c
-  tcPatt scope c1 p1 ty0
-  tcPatt scope c2 p2 ty0
-  return scope
-tcPatt scope c (PM q) ty0 = do
+  (_,ty) <- tcPatt scope c1 p1 mb_ty
+  (_,ty) <- tcPatt scope c2 p2 (Just ty)
+  return (scope,ty)
+tcPatt scope c (PM q) mb_ty = do
   g@(Gl gr _) <- globals
   ty <- case lookupResType gr q of
           Ok ty   -> return ty
           Bad msg -> evalError (pp msg)
   case ty of
     EPattType ty
-            -> do unify scope ty0 (eval g [] c ty [])
-                  return scope
+         -> do let vty = eval g [] c ty []
+               case mb_ty of
+                 Just ty0 -> unify scope ty0 vty
+                 Nothing  -> return ()
+               return (scope,vty)
     ty   -> evalError ("Pattern type expected but " <+> pp ty <+> " found.")
 tcPatt scope c p ty = unimplemented ("tcPatt "++show p)
 
-inferRecFields scope c rs =
-  mapCM (\c (l,r) -> tcRecField scope c l r Nothing) c rs
+inferRecFields scope c ls []          = return []
+inferRecFields scope c ls ((l,t):lts)
+  | elem l ls = evalError ("Repeated definition for field" <+> l)
+  | otherwise = do
+      let (c1,c2) = split c
+      lt  <- tcRecField scope c1 l t Nothing
+      lts <- inferRecFields scope c2 (l:ls) lts
+      return (lt:lts)
 
-checkRecFields scope c []          ltys
+checkRecFields scope c ls []          ltys
   | null ltys                            = return []
   | otherwise                            = evalError ("Missing fields:" <+> hsep [l | (l,_,_) <- ltys])
-checkRecFields scope c ((l,t):lts) ltys =
-  case takeIt l ltys of
-    (Just ty,ltys) -> do let (c1,c2) = split c
-                         ltty  <- tcRecField scope c1 l t (Just ty)
-                         lttys <- checkRecFields scope c2 lts ltys
-                         return (ltty : lttys)
-    (Nothing,ltys) -> do evalWarn ("Discarded field:" <+> l)
-                         lttys <- checkRecFields scope c lts ltys
-                         return lttys     -- ignore the field
+checkRecFields scope c ls ((l,t):lts) ltys
+  | elem l ls = evalError ("Repeated definition for field" <+> l)
+  | otherwise =
+      case takeIt l ltys of
+        (Just ty,ltys) -> do let (c1,c2) = split c
+                             ltty  <- tcRecField scope c1 l t (Just ty)
+                             lttys <- checkRecFields scope c2 ls lts ltys
+                             return (ltty : lttys)
+        (Nothing,ltys) -> do evalWarn ("Discarded field:" <+> l)
+                             lttys <- checkRecFields scope c ls lts ltys
+                             return lttys     -- ignore the field
   where
     takeIt l1 []  = (Nothing, [])
     takeIt l1 (lty@(l2,_,ty):ltys)
@@ -716,20 +772,22 @@ tcRecField scope c l (mb_ann_ty,t) mb_ty = do
               Nothing     -> tcRho scope c t mb_ty
   return (l,t,ty)
 
-tcRecTypeFields scope c []          mb_ty = return ([],mb_ty)
-tcRecTypeFields scope c ((l,ty):rs) mb_ty = do
-  let (c1,c2) = split c
-  (ty,sort) <- tcRho scope c1 ty mb_ty
-  mb_ty <- case sort of
-             VSort s
-               | s == cType  -> return (Just sort)
-               | s == cPType -> return mb_ty
-             VMeta _ _       -> return mb_ty
-             _               -> do sort <- value2termM False (scopeVars scope) sort
-                                   evalError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$
-                                              "cannot be of type" <+> ppTerm Unqualified 0 sort)
-  (rs,mb_ty) <- tcRecTypeFields scope c2 rs mb_ty
-  return ((l,ty):rs,mb_ty)
+tcRecTypeFields scope c ls []          mb_ty = return ([],mb_ty)
+tcRecTypeFields scope c ls ((l,ty):rs) mb_ty
+  | elem l ls = evalError ("Repeated definition for field" <+> l)
+  | otherwise = do
+      let (c1,c2) = split c
+      (ty,sort) <- tcRho scope c1 ty mb_ty
+      mb_ty <- case sort of
+                 VSort s
+                    | s == cType  -> return (Just sort)
+                    | s == cPType -> return mb_ty
+                 VMeta _ _       -> return mb_ty
+                 _               -> do sort <- value2termM False (scopeVars scope) sort
+                                       evalError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$
+                                                  "cannot be of type" <+> ppTerm Unqualified 0 sort)
+      (rs,mb_ty) <- tcRecTypeFields scope c2 (l:ls) rs mb_ty
+      return ((l,ty):rs,mb_ty)
 
 -- | Invariant: if the third argument is (Just rho),
 --              then rho is in weak-prenex form
@@ -824,26 +882,12 @@ subsCheckRho scope t ty1@(VApp _ p _) ty2@(VInts _ _)         -- This is not cor
   | p == (cPredef,cInt) = return (t,ty1,ty2)                  -- Should be only a temporary hack.
 subsCheckRho scope t ty1@(VInts _ _) ty2@(VApp _ p _)         -- Rule INT1
   | p == (cPredef,cInt) = return (t,ty1,ty2)
-subsCheckRho scope t ty1@(VInts i1 j1) ty2@(VInts i2 j2)      -- Rule INT2
-  | j1  `less1` i2  = return (t,ty1,ty2)
-  | j1' `less1` i2' = return (t,VInts i1 j1',VInts i2' j2)
-  | otherwise       = evalError ("In the term" <+> ppTerm Unqualified 0 t $$
-                                 ppValue Terse 0 ty1 <+> "is not a subtype of" <+> ppValue Terse 0 ty2)
-  where
-    less1 (Just x) (Just y) = x <= y
-    less1 _        _        = False
-
-    less2 (Just x) (Just y) = x <= y
-    less2 Nothing  (Just y) = True
-    less2 _        _        = False
-
-    less3 (Just x) (Just y) = x <= y
-    less3 (Just x) Nothing  = True
-    less3 _        _        = False
-
-    j1' = if i1 `less2` i2 then i2 else j1
-    i2' = if j1 `less3` j2 then j1 else i2
-subsCheckRho scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do      -- Rule REC
+subsCheckRho scope t ty1@(VInts n1 ext1) ty2@(VInts n2 ext2)  -- Rule INT2
+  | n1 <= n2  = return (t,ty1,ty2)
+  | ext2      = return (t,ty1,VInts n1 ext2)
+  | otherwise = evalError ("In the term" <+> ppTerm Unqualified 0 t $$
+                           ppValue Terse 0 ty1 <+> "is not a subtype of" <+> ppValue Terse 0 ty2)
+subsCheckRho scope t ty1@(VRecType rs1 ext1) ty2@(VRecType rs2 ext2) = do      -- Rule REC
   let mkAccess scope t =
         case t of
           ExtR t1 (R rs) ->
@@ -883,6 +927,8 @@ subsCheckRho scope t ty1 (VFV c (VarFree vs)) = do
 subsCheckRho scope t (VFV c (VarFree vs)) ty2 = do
   ty1 <- variants c vs
   subsCheckRho scope t ty1 ty2
+subsCheckRho scope t ty1@(VPattType (VSort s1)) ty2@(VSort s2)      -- for backwards compatibility
+  | s1 == cStr && s2 == cStrs = return (t,ty1,ty2)
 subsCheckRho scope t ty1 ty2 = do                           -- Rule EQ
   unify scope ty1 ty2                                  -- Revert to ordinary unification
   return (t,ty1,ty2)
@@ -909,29 +955,16 @@ subsCheckTbl scope t p1 r1 p2 r2 = do
   p2_t <- value2termM True (scopeVars scope) p2
   return (T (TTyped p2_t) [(PV x,t)],VTable p1 r1,VTable p2 r2)
 
-{-subtype scope Nothing              (VInts i2 j2) =
-  return (VInts Nothing j2)
-subtype scope (Just (VMeta i vs))  ty2 = do
-  g  <- globals
-  mv <- getMeta i
-  case mv of
-    Bound _ v -> subtype scope (Just (apply g v vs)) ty2-}
-subtype scope (Just (VInts i1 j1)) (VInts i2 j2) =
-  case VInts (lift max i1 i2) (lift min j1 j2) of
-    ty@(VInts (Just i) (Just j))
-      | i > j -> evalError (ppValue Unqualified 0 ty <+> "is an empty type")
-    ty        -> return ty
-  where
-    lift f Nothing  Nothing  = Nothing
-    lift f (Just x) Nothing  = Just x
-    lift f Nothing  (Just y) = Just y
-    lift f (Just x) (Just y) = Just (f x y)
-subtype scope Nothing (VRecType ltys) = do
+subtype scope Nothing              (VInts i2 _) =
+  return (VInts i2 True)
+subtype scope (Just (VInts n1 _))  (VInts n2 _) =
+  return (VInts (min n1 n2) False)
+subtype scope Nothing (VRecType ltys ext) = do
   lctrs <- mapM (\(l,o,ty) -> subtype scope Nothing ty >>= \ctr -> return (l,o,ctr)) ltys
-  return (VRecType lctrs)
-subtype scope (Just (VRecType lctrs1)) (VRecType lctrs2) = do
+  return (VRecType lctrs ext)
+subtype scope (Just (VRecType lctrs1 ext1)) (VRecType lctrs2 ext2) = do
   lctrs <- foldM (\lctrs (l,o,ctr) -> union l o ctr lctrs) lctrs1 lctrs2
-  return (VRecType lctrs)
+  return (VRecType lctrs (ext1 || ext2))
   where
     union l o1 ctr1 [] = do ctr <- subtype scope Nothing ctr1
                             return [(l,True,ctr)]
@@ -958,24 +991,16 @@ subtype scope (Just ctr) ty = do
   unify scope ctr ty
   return ty
 
-supertype scope Nothing (VInts i2 j2) =
-  return (VInts i2 Nothing)
-supertype scope (Just (VInts i1 j1)) (VInts i2 j2) =
-  case VInts (lift min i1 i2) (lift max j1 j2) of
-    ty@(VInts (Just i) (Just j))
-      | i > j -> evalError (ppValue Unqualified 0 ty <+> "is an empty type")
-    ty        -> return ty
-  where
-    lift f Nothing  Nothing  = Nothing
-    lift f (Just x) Nothing  = Nothing
-    lift f Nothing  (Just y) = Nothing
-    lift f (Just x) (Just y) = Just (f x y)
-supertype scope Nothing (VRecType ltys) = do
+supertype scope Nothing (VInts n2 _) =
+  return (VInts n2 True)
+supertype scope (Just (VInts n1 _)) (VInts n2 _) =
+  return (VInts (max n1 n2) True)
+supertype scope Nothing (VRecType ltys ext) = do
   lctrs <- mapM (\(l,o,ty) -> supertype scope Nothing ty >>= \ctr -> return (l,False,ctr)) ltys
-  return (VRecType lctrs)
-supertype scope (Just (VRecType lctrs1)) (VRecType lctrs2) = do
+  return (VRecType lctrs ext)
+supertype scope (Just (VRecType lctrs1 ext1)) (VRecType lctrs2 ext2) = do
   lctrs <- foldM (\lctrs (l,o,ctr) -> intersect l o ctr lctrs lctrs2) [] lctrs1
-  return (VRecType lctrs)
+  return (VRecType lctrs (ext1 || ext2))
   where
     intersect l o1 ctr1 lctrs [] = return lctrs
     intersect l o1 ctr1 lctrs ((l',o2,ctr2):lctrs2)
@@ -1077,9 +1102,7 @@ unify scope (VFlt x)  (VFlt y)
 unify scope (VStr s1) (VStr s2)
   | s1 == s2                   = return ()
 unify scope VEmpty VEmpty      = return ()
-unify scope v1 v2 = do
-  t1 <- value2termM False (scopeVars scope) v1
-  t2 <- value2termM False (scopeVars scope) v2
+unify scope v1 v2 =
   evalError ("Cannot unify:" <+> ppValue Qualified 0 v1 $$
              "        with:" <+> ppValue Qualified 0 v2)
 
@@ -1124,7 +1147,7 @@ occursCheck scope' i0 scope v =
         VClosure env c t -> do g <- globals
                                check (m+1) (n+1) (eval g ((x,VGen n []):env) c t [])
         _                -> check m n ty2
-    check m n (VRecType as) =
+    check m n (VRecType as _) =
       mapM_ (\(_,_,v) -> check m n v) as
     check m n (VR as) =
       mapM_ (\(lbl,v) -> check m n v) as
@@ -1231,9 +1254,9 @@ quantify scope t tvs ty = do
                                return (x:xs,VProd bt x v1 (VClosure env c t))
         v2               -> do (xs,v2) <- check m (n+1) xs v2
                                return (x:xs,VProd bt x v1 v2)
-    check m n xs (VRecType as)     = do
+    check m n xs (VRecType as ext)     = do
       (xs,as) <- mapAccumM (\xs (l,o,v) -> check m n xs v >>= \(xs,v) -> return (xs,(l,o,v))) xs as
-      return (xs,VRecType as)
+      return (xs,VRecType as ext)
     check m n xs (VR as)           = do
       (xs,as) <- mapAccumM (\xs (lbl,tnk) -> check m n xs tnk >>= \(xs,tnk) -> return (xs,(lbl,tnk))) xs as
       return (xs,VR as)
@@ -1324,6 +1347,11 @@ lookup3 l ((l',_,v):rs)
   | l == l'   = Just v
   | otherwise = lookup3 l rs
 
+update3 l o v []  = [(l,o,v)]
+update3 l o v (r@(l',_,_):rs)
+  | l == l'   = (l,o,v) : rs
+  | otherwise = r : update3 l o v rs
+
 newVar :: Scope -> Ident
 newVar scope = head [x | i <- [1..],
                          let x = identS ('v':show i),
@@ -1345,7 +1373,7 @@ getMetaVars sc_tys = foldM (\acc (scope,ty) -> go acc ty) [] sc_tys
     go acc (VGen i args)     = foldM go acc args
     go acc (VSort s)         = return acc
     go acc (VInt _)          = return acc
-    go acc (VRecType vs)    = foldM (\acc (lbl,_,v) -> go acc v) acc vs
+    go acc (VRecType vs _)   = foldM (\acc (lbl,_,v) -> go acc v) acc vs
     go acc (VClosure _ _ _)  = return acc
     go acc (VProd b x v1 v2) = go acc v2 >>= \acc -> go acc v1
     go acc (VTable v1 v2)    = go acc v2 >>= \acc -> go acc v1
@@ -1357,7 +1385,8 @@ getMetaVars sc_tys = foldM (\acc (scope,ty) -> go acc ty) [] sc_tys
                                     _         -> foldM go (m:acc) args
     go acc (VApp c f args)   = foldM go acc args
     go acc (VFV c vs)        = foldM go acc (unvariants vs)
-    go acc (VInts _ _)      = return acc
+    go acc (VInts _ _)       = return acc
+    go acc (VPattType v)     = go acc v
     go acc v                 = unimplemented ("go "++show (ppValue Unqualified 5 v))
 
 -- | Eliminate any substitutions in a term

From be1de111ce61871aef3755dfecc58a1bad848b57 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 8 Aug 2025 09:19:14 +0200
Subject: [PATCH 025/144] support pattern definitions inside pre

---
 src/compiler/api/GF/Compile/GeneratePMCFG.hs | 23 ++++++++++++++++----
 1 file changed, 19 insertions(+), 4 deletions(-)

diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index b5861b350..952c65730 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -214,11 +214,26 @@ str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs
 str2lin (VSymVar d r)    = return [SymVar d r]
 str2lin VEmpty           = return []
 str2lin (VC v1 v2)       = liftM2 (++) (str2lin v1) (str2lin v2)
-str2lin (VAlts def alts) = do def <- str2lin def
-                              alts <- forM alts $ \(v,VStrs vs) -> do
-                                lin <- str2lin v
-                                return (lin,[s | VStr s <- vs])
+str2lin v0@(VAlts def alts)
+                         = do def <- str2lin def
+                              alts <- forM alts $ \(v1,v2) -> do
+                                lin <- str2lin v1
+                                ss  <- to_strs v2
+                                return (lin,ss)
                               return [SymKP def alts]
+  where
+    to_strs (VStrs vs)    = mapM to_str vs
+    to_strs (VPatt _ _ p) = from_patt p
+    to_strs v             = fail
+
+    to_str (VStr s) = return s
+    to_str _        = fail
+
+    from_patt (PAlt p1 p2) = liftM2 (++) (from_patt p1) (from_patt p2)
+    from_patt (PString s)  = return [s]
+    from_patt _            = fail
+
+    fail = evalError ("Complex patterns are not supported in:" $$ nest 2 (pp (showValue v0)))
 str2lin v                = do t <- value2term False [] v
                               evalError ("the string:" <+> ppTerm Unqualified 0 t $$
                                          "cannot be evaluated at compile time.")

From 0b4426ab83b874e2db9c0f3b20de403ec02131ed Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 8 Aug 2025 09:21:34 +0200
Subject: [PATCH 026/144] detect and eliminate unnecessary coercions

---
 .../api/GF/Compile/Compute/Concrete2.hs       |  2 +-
 .../api/GF/Compile/TypeCheck/Concrete.hs      | 73 +++++++++++++++----
 2 files changed, 59 insertions(+), 16 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index 0182c93ff..e6416b5d7 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -316,7 +316,7 @@ eval g env s (FV ts)        vs  = VFV s (VarFree (mapC (\s t -> eval g env s t v
 eval g env s (Alts d as)    []  = let (!s1,!s2) = split s
                                       vd  = eval g env s1 d []
                                       vas = mapC (\s (t1,t2) -> let (!s1,!s2) = split s
-                                                              in (eval g env s1 t1 [],eval g env s2 t2 [])) s2 as
+                                                                in (eval g env s1 t1 [],eval g env s2 t2 [])) s2 as
                                   in VAlts vd vas
 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) [] =
diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index 954c31452..d0ff0155e 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -902,17 +902,28 @@ subsCheckRho scope t ty1@(VRecType rs1 ext1) ty2@(VRecType rs2 ext2) = do      -
                             ,\l -> lookup l rs
                             ,id
                             )
+          Vr x  -> return (scope
+                          ,\l  -> return (Nothing,P t l)
+                          ,\t' -> if is_trivial x t' then t else t'
+                          )
           t    -> let x = newVar scope
                   in return (((x,ty1):scope)
                             ,\l  -> return (Nothing,P (Vr x) l)
-                            ,Let (x, (Nothing, t))
+                            ,\t' -> if is_trivial x t' then t else Let (x, (Nothing, t)) t'
                             )
 
+      is_trivial x (R rs) = all is_selection rs
+        where
+          is_selection (l, (_, P (Vr u) l'))
+            | l == l' && u == x = True
+          is_selection _        = False
+      is_trivial x _      = False
+
       mkField scope l (mb_ty,t) ty1 ty2 = do
         (t,_,_) <- subsCheckRho scope t ty1 ty2
         return (l, (mb_ty,t))
 
-  (scope,mkProj,mkWrap) <- mkAccess scope t
+  (scope,mkProj,wrap) <- mkAccess scope t
 
   let fields = [(l,ty2,lookup3 l rs1) | (l,o2,ty2) <- rs2]
   case [l | (l,_,Nothing) <- fields, not (isLockLabel l)] of
@@ -920,7 +931,7 @@ subsCheckRho scope t ty1@(VRecType rs1 ext1) ty2@(VRecType rs2 ext2) = do      -
     missing -> evalError ("In the term" <+> pp t $$
                           "there are no values for fields:" <+> hsep missing)
   rs <- sequence [mkField scope l t ty1 ty2 | (l,ty2,Just ty1) <- fields, Just t <- [mkProj l]]
-  return (mkWrap (R (rs++[(l, (Just (RecType []),R [])) | (l,_,Nothing) <- fields, isLockLabel l])),ty1,ty2)
+  return (wrap (R (rs++[(l, (Just (RecType []),R [])) | (l,_,Nothing) <- fields, isLockLabel l])),ty1,ty2)
 subsCheckRho scope t ty1 (VFV c (VarFree vs)) = do
   ty2 <- variants c vs
   subsCheckRho scope t ty1 ty2
@@ -935,25 +946,57 @@ subsCheckRho scope t ty1 ty2 = do                           -- Rule EQ
 
 subsCheckFun :: Scope -> Term -> Sigma -> Value -> Sigma -> Value -> EvalM (Term,Value,Value)
 subsCheckFun scope t a1 r1 a2 r2 = do
-  let v   = newVar scope
-  (vt,a2,a1) <- subsCheckRho ((v,a2):scope) (Vr v) a2 a1
+  let x = newVar scope
+  (xt,a2,a1) <- subsCheckRho ((x,a2):scope) (Vr x) a2 a1
   g  <- globals
-  let (v1',r1') = case r1 of
-                    VClosure env c r1 -> (v,eval g ((v,(VGen (length scope) [])):env) c r1 [])
+  let (x1',r1') = case r1 of
+                    VClosure env c r1 -> (x,eval g ((x,(VGen (length scope) [])):env) c r1 [])
                     r1                -> (identW,r1)
-      (v2',r2') = case r2 of
-                    VClosure env c r2 -> (v,eval g ((v,(VGen (length scope) [])):env) c r2 [])
+      (x2',r2') = case r2 of
+                    VClosure env c r2 -> (x,eval g ((x,(VGen (length scope) [])):env) c r2 [])
                     r2                -> (identW,r2)
-  (t,r1,r2)  <- subsCheckRho ((v,vtypeType):scope) (App t vt) r1' r2'
-  return (Abs Explicit v t, VProd Explicit v1' a1 r1, VProd Explicit v2' a2 r2)
+  (t,r1,r2)  <- subsCheckRho ((x,a2):scope) (App t xt) r1' r2'
+  case t of
+    App t (Vr u) | u == x -> return (t, VProd Explicit x1' a1 r1, VProd Explicit x2' a2 r2)
+    _                     -> return (Abs Explicit x t, VProd Explicit x1' a1 r1, VProd Explicit x2' a2 r2)
 
 subsCheckTbl :: Scope -> Term -> Sigma -> Rho -> Sigma -> Rho  -> EvalM (Term,Value,Value)
 subsCheckTbl scope t p1 r1 p2 r2 = do
-  let x = newVar scope
-  (xt,p2,p1) <- subsCheckRho ((x,p2):scope) (Vr x) p2 p1
-  (t,r1,r2)  <- subsCheckRho ((x,p2):scope) (S t xt) r1 r2
+  (scope,y,sel,wrap) <-
+        case t of
+          Vr x -> let y = newVar scope
+                  in return ((y,p2):scope
+                            ,y
+                            ,\t -> S (Vr x) t
+                            ,\p2 t' -> case t' of
+                                         S (Vr u) (Vr v) | u == x && v == y -> t
+                                         _                                  -> T (TTyped p2) [(PV y,t')]
+                            )
+          T _ [(PV x,t')] ->
+                  let scope' = (x,p1):scope
+                      y      = newVar scope'
+                  in return (((y,p2):scope')
+                            ,y
+                            ,\t  -> Let (x, (Nothing, t)) t'
+                            ,\p2 t -> case t of
+                                        Let (u, (Nothing, Vr v)) t | u == x && v == y -> T (TTyped p2) [(PV x,t)]
+                                        _                                             -> T (TTyped p2) [(PV y,t)]
+                            )
+          t    -> let x = newVar scope
+                      scope' = (x,VTable p1 r1):scope
+                      y = newVar scope'
+                  in return (((y,VTable p1 r1):scope')
+                            ,y
+                            ,\t  -> S (Vr x) t
+                            ,\p2 t' -> case t' of
+                                         S (Vr u) (Vr v) | u == x && v == y -> t
+                                         _                                  -> Let (x, (Nothing, t)) (T (TTyped p2) [(PV y,t')])
+                            )
+  (yt,p2,p1) <- subsCheckRho scope (Vr y) p2 p1
+  (t,r1,r2)  <- subsCheckRho scope (sel yt) r1 r2
   p2_t <- value2termM True (scopeVars scope) p2
-  return (T (TTyped p2_t) [(PV x,t)],VTable p1 r1,VTable p2 r2)
+  return (wrap p2_t t,VTable p1 r1,VTable p2 r2)
+
 
 subtype scope Nothing              (VInts i2 _) =
   return (VInts i2 True)

From 82c1a70cfb9b13f09cd8ee28c79ab99d3448280d Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 8 Aug 2025 13:55:39 +0200
Subject: [PATCH 027/144] allow patterns inside pre to contain concatenation

---
 src/compiler/api/GF/Compile/GeneratePMCFG.hs | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index 952c65730..ce65033fd 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -230,6 +230,7 @@ str2lin v0@(VAlts def alts)
     to_str _        = fail
 
     from_patt (PAlt p1 p2) = liftM2 (++) (from_patt p1) (from_patt p2)
+    from_patt (PSeq _ _ p1 _ _ p2) = liftM2 (liftM2 (++)) (from_patt p1) (from_patt p2)
     from_patt (PString s)  = return [s]
     from_patt _            = fail
 

From c6c1dc178df7109b6a28687defe246b8b1fa9d18 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 12 Aug 2025 15:23:45 +0200
Subject: [PATCH 028/144] fixed typechecking for record extension

---
 .../api/GF/Compile/TypeCheck/Concrete.hs      | 57 ++++++++++++++++---
 1 file changed, 49 insertions(+), 8 deletions(-)

diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index d0ff0155e..f7b232640 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -325,33 +325,74 @@ tcRho scope c (Glue t1 t2) mb_ty = do
   (t2,t2_ty) <- tcRho scope c2 t2 (Just vtypeStr)
   instSigma scope c3 (Glue t1 t2) vtypeStr mb_ty
 tcRho scope c t@(ExtR t1 t2) mb_ty =
-  case (mb_ty,t2) of
-    (Just (VRecType ltys ext),R ss) -> do
-       let ll2 = map fst ss
+  case (t2,mb_ty) of
+    (R rs,Just (VRecType ltys ext)) -> do
+       let ll2   = map fst rs
            (c1,c2) = split c
-       (t1,t1_ty) <- tcRho scope c1 t1 (Just (VRecType [field | field@(l,_,_) <- ltys, not (elem l ll2)] ext))
-       (t2,t2_ty) <- tcRho scope c2 t2 (Just (VRecType [field | field@(l,_,_) <- ltys, elem l ll2] ext))
-       ty <- join t1_ty t2_ty
-       return (ExtR t1 t2, ty)
+
+       (t1,ty1@(VRecType ltys1 ext)) <- tcRho scope c1 t1 (Just (VRecType [field | field@(l,_,_) <- ltys, not (elem l ll2)] ext))
+       let (scope',proj1,wrap) = access scope t1 ty1
+
+       lttys2 <- checkRecFields scope' c2 [] rs [field | field@(l,_,_) <- ltys, elem l ll2]
+       let proj2 l =
+             case [(Nothing,t) | (l',t,_) <- lttys2, l'==l] of
+               []    -> Nothing
+               (x:_) -> Just x
+
+       return (wrap (R [(l,t) | (l,_,_) <- ltys, Just t <- [if elem l ll2 then proj2 l else proj1 l]]),
+               VRecType ltys False
+              )
     _ -> do
        let (c1,c2,c3,c4) = split4 c
        (t1,t1_ty) <- tcRho scope c1 t1 Nothing
        (t2,t2_ty) <- tcRho scope c2 t2 Nothing
        ty <- join t1_ty t2_ty
-       instSigma scope c3 (ExtR t1 t2) ty mb_ty
+       let (scope1,proj1,wrap1) = access scope  t1 t1_ty
+           (scope2,proj2,wrap2) = access scope1 t2 t2_ty
+       let t = case (mb_ty,ty,t2_ty) of
+                 (Just (VRecType ltys False), _, VRecType ltys2 False) ->
+                    let ll2 = [l | (l,_,_) <- ltys2]
+                    in (wrap1 . wrap2) (R [(l,t) | (l,_,_) <- ltys, Just t <- [if elem l ll2 then proj2 l else proj1 l]])
+                 (_, VRecType ltys False, VRecType ltys2 False) ->
+                    let ll2 = [l | (l,_,_) <- ltys2]
+                    in (wrap1 . wrap2) (R [(l,t) | (l,_,_) <- ltys, Just t <- [if elem l ll2 then proj2 l else proj1 l]])
+                 _ -> ExtR t1 t2
+       return (t,ty)
   where
+    access scope (R rs) ty = (scope
+                             ,\l -> lookup l rs
+                             ,id
+                             )
+    access scope (RecType rs) ty
+                           = (scope
+                             ,\l -> fmap ((,) Nothing) (lookup l rs)
+                             ,id
+                             )
+    access scope t@(Vr x) ty
+                           = (scope
+                             ,\l  -> return (Nothing,P t l)
+                             ,id
+                             )
+    access scope t      ty = let x = newVar scope
+                             in (((x,ty):scope)
+                                ,\l  -> return (Nothing,P (Vr x) l)
+                                ,Let (x, (Nothing, t))
+                                )
+
     join (VMeta i vs) ty2 = do
       mv <- getMeta i
       case mv of
         Bound _ v -> do
           g <- globals
           join (apply g v vs) ty2
+        _ -> evalError (pp "Cannot type check record extensions when one of the types is a meta variable")
     join ty1 (VMeta j vs) = do
       mv <- getMeta j
       case mv of
         Bound _ v -> do
           g <- globals
           join ty1 (apply g v vs)
+        _ -> evalError (pp "Cannot type check record extensions when one of the types is a meta variable")
     join (VSort s1) (VSort s2)
        | (s1 == cType || s1 == cPType) &&
          (s2 == cType || s2 == cPType) = let sort | s1 == cPType && s2 == cPType = cPType

From ca4e99baf85ca5d8cf22092cef8790d5bf880a0a Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 13 Aug 2025 11:51:11 +0200
Subject: [PATCH 029/144] restore the pattern measureing for better performance

---
 .../api/GF/Compile/TypeCheck/Concrete.hs      | 50 ++++++++++++++++++-
 1 file changed, 48 insertions(+), 2 deletions(-)

diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index f7b232640..63ef81374 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -14,7 +14,7 @@ import GF.Compile.Compute.Concrete2
 import GF.Infra.CheckM
 import GF.Data.ErrM ( Err(Ok, Bad) )
 import Control.Applicative(Applicative(..),(<|>))
-import Control.Monad(ap,liftM,mplus,foldM,zipWithM,forM,filterM,unless)
+import Control.Monad(ap,liftM,liftM2,mplus,foldM,zipWithM,forM,filterM,unless)
 import Control.Monad.ST
 import GF.Text.Pretty
 import Data.STRef
@@ -436,7 +436,7 @@ tcRho scope c (EPattType ty) mb_ty = do
   let (c1,c2) = split c
   (ty, _) <- tcRho scope c1 ty (Just vtypeType)
   instSigma scope c2 (EPattType ty) vtypeType mb_ty
-tcRho scope c t@(EPatt min max p) mb_ty = do
+tcRho scope c t@(EPatt _ _ p) mb_ty = do
   (scope,f,mb_ty) <- case mb_ty of
                        Nothing -> return (scope,id,Nothing)
                        Just ty -> do (scope,f,ty) <- skolemise scope ty
@@ -444,6 +444,7 @@ tcRho scope c t@(EPatt min max p) mb_ty = do
                                        VPattType ty -> return (scope,f,Just ty)
                                        _            -> evalError (ppTerm Unqualified 0 t <+> "must be of pattern type but" <+> ppTerm Unqualified 0 t <+> "is expected")
   (_,ty) <- tcPatt scope c p mb_ty
+  (min,max,p) <- measurePatt p
   return (f (EPatt min max p), VPattType ty)
 tcRho scope c (Markup tag attrs children) mb_ty = do
   let (c1,c2,c3,c4) = split4 c
@@ -525,6 +526,7 @@ tcCases scope c ((p,t):cs) mb_p_ty     mb_res_ty     = do
   (scope',p_ty) <- tcPatt scope c1 p mb_p_ty
   (t,res_ty)  <- tcRho scope' c2 t mb_res_ty
   (cs,p_ty,res_ty) <- tcCases scope c3 cs (Just p_ty) (Just res_ty)
+  (_,_,p) <- measurePatt p
   return ((p,t):cs,p_ty,res_ty)
 
 tcApp scope c t0 (App fun arg) args mb_ty = tcApp scope c t0 fun (arg:args) mb_ty     -- APP
@@ -772,6 +774,50 @@ tcPatt scope c (PM q) mb_ty = do
     ty   -> evalError ("Pattern type expected but " <+> pp ty <+> " found.")
 tcPatt scope c p ty = unimplemented ("tcPatt "++show p)
 
+measurePatt p =
+  case p of
+    PM q       -> do g <- globals
+                     case eval g [] unit (Q q) [] of
+                       VPatt minp maxp _ -> return (minp,maxp,p)
+                       v                 -> evalError ("Expected pattern macro, but found:" $$ nest 2 (ppValue Unqualified 0 v))
+    PR ass     -> do ass <- mapM (\(lbl,p) -> measurePatt p >>= \(_,_,p') -> return (lbl,p')) ass
+                     return (0,Nothing,PR ass)
+    PString s  -> do let len=length s
+                     return (len,Just len,p)
+    PT t p     -> do (min,max,p') <- measurePatt p
+                     return (min,max,PT t p')
+    PAs x p    -> do (min,max,p) <- measurePatt p
+                     case p of
+                       PW -> return (0,Nothing,PV x)
+                       _  -> return (min,max,PAs x p)
+    PImplArg p -> do (min,max,p') <- measurePatt p
+                     return (min,max,PImplArg p')
+    PNeg p     -> do (_,_,p') <- measurePatt p
+                     return (0,Nothing,PNeg p')
+    PAlt p1 p2 -> do (min1,max1,p1) <- measurePatt p1
+                     (min2,max2,p2) <- measurePatt p2
+                     case (p1,p2) of
+                       (PString [c1],PString [c2]) -> return (1,Just 1,PChars [c1,c2])
+                       (PString [c], PChars cs)    -> return (1,Just 1,PChars ([c]++cs))
+                       (PChars cs,   PString [c])  -> return (1,Just 1,PChars (cs++[c]))
+                       (PChars cs1,  PChars cs2)   -> return (1,Just 1,PChars (cs1++cs2))
+                       _                           -> return (min min1 min2,liftM2 max max1 max2,PAlt p1 p2)
+    PSeq _ _ p1 _ _ p2
+               -> do (min1,max1,p1) <- measurePatt p1
+                     (min2,max2,p2) <- measurePatt p2
+                     case (p1,p2) of
+                       (PW,        PW        ) -> return (0,Nothing,PW)
+                       (PString s1,PString s2) -> return (min1+min2,liftM2 (+) max1 max2,PString (s1++s2))
+                       _                       -> return (min1+min2,liftM2 (+) max1 max2,PSeq min1 max1 p1 min2 max2 p2)
+    PRep _ _ p -> do (minp,maxp,p) <- measurePatt p
+                     case p of
+                       PW    -> return (0,Nothing,PW)
+                       PChar -> return (0,Nothing,PW)
+                       _     -> return (0,Nothing,PRep minp maxp p)
+    PChar      -> return (1,Just 1,p)
+    PChars _   -> return (1,Just 1,p)
+    _          -> return (0,Nothing,p)
+
 inferRecFields scope c ls []          = return []
 inferRecFields scope c ls ((l,t):lts)
   | elem l ls = evalError ("Repeated definition for field" <+> l)

From d6a6a352aea4dee6c244fe204d0ed7ef96d27e9b Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 13 Aug 2025 12:18:59 +0200
Subject: [PATCH 030/144] support for PChars inside pre

---
 src/compiler/api/GF/Compile/GeneratePMCFG.hs | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index ce65033fd..0ff244c3d 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -232,6 +232,7 @@ str2lin v0@(VAlts def alts)
     from_patt (PAlt p1 p2) = liftM2 (++) (from_patt p1) (from_patt p2)
     from_patt (PSeq _ _ p1 _ _ p2) = liftM2 (liftM2 (++)) (from_patt p1) (from_patt p2)
     from_patt (PString s)  = return [s]
+    from_patt (PChars cs)  = return (map (:[]) cs)
     from_patt _            = fail
 
     fail = evalError ("Complex patterns are not supported in:" $$ nest 2 (pp (showValue v0)))

From 4aa664e7aa58518dfc9726faff4552577f6f85f1 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 14 Aug 2025 12:21:45 +0200
Subject: [PATCH 031/144] fix for reverting metavariables

---
 src/compiler/api/GF/Compile/Compute/Concrete2.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index e6416b5d7..355d08b6f 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -779,9 +779,9 @@ try f select xs = EvalM (\g k state r msgs ->
     backtrack g []     state res msgs = (res,msgs)
     backtrack g (x:xs) state res msgs =
       case f x of
-        EvalM f -> case f g (\y state ys msgs -> Success (y:ys) msgs) state res msgs of
-                     Fail msg _       -> backtrack g xs state res msgs
-                     Success res msgs -> backtrack g xs state res msgs
+        EvalM f -> case f g (\y state (_,ys) msgs -> Success (state,y:ys) msgs) state (state,res) msgs of
+                     Fail msg _               -> backtrack g xs state res msgs
+                     Success (state,res) msgs -> backtrack g xs state res msgs
 
 newResiduation :: Scope -> EvalM MetaId
 newResiduation scope = EvalM (\g k (State choices metas opts) r msgs ->

From 78751395b47b0e55f92ccac7359f38c7d992fc2d Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sat, 16 Aug 2025 22:59:30 +0200
Subject: [PATCH 032/144] added mapVariantsC

---
 src/compiler/api/GF/Compile/Compute/Concrete2.hs | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index 1d19119fd..32eab30dc 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -3,7 +3,7 @@
 module GF.Compile.Compute.Concrete2
            (Env, Scope, Value(..), Variants(..), OptionInfo(..), ChoiceMap, cleanOptions,
             ConstValue(..), ConstVariants(..), Globals(..), PredefTable, EvalM,
-            mapVariants, unvariants, variants2consts, consts2variants,
+            mapVariants, mapVariantsC, unvariants, variants2consts, consts2variants,
             runEvalM, runEvalMWithOpts, stdPredef, globals,
             PredefImpl, Predef(..), ($\),
             pdCanonicalArgs, pdArity,
@@ -100,6 +100,10 @@ mapVariants :: (Value -> Value) -> Variants -> Variants
 mapVariants f (VarFree vs)   = VarFree (f <$> vs)
 mapVariants f (VarOpts n cs) = VarOpts n (second f <$> cs)
 
+mapVariantsC :: (Choice -> Value -> Value) -> Choice -> Variants -> Variants
+mapVariantsC f c (VarFree vs)   = VarFree (mapC f c vs)
+mapVariantsC f c (VarOpts n cs) = VarOpts n (mapC (\c (x,y) -> (x,f c y)) c cs)
+
 unvariants :: Variants -> [Value]
 unvariants (VarFree vs)   = vs
 unvariants (VarOpts n cs) = snd <$> cs

From bcaa0477d23e791bc66ceb5e57e57a6822ba2d64 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sun, 17 Aug 2025 08:35:43 +0200
Subject: [PATCH 033/144] pretty printing for options

---
 src/compiler/api/GF/Grammar/Printer.hs | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs
index e9947b494..078872064 100644
--- a/src/compiler/api/GF/Grammar/Printer.hs
+++ b/src/compiler/api/GF/Grammar/Printer.hs
@@ -218,6 +218,9 @@ ppTerm q d (S x y)     = case x of
                                            '}'
                            _          -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))
 ppTerm q d (ExtR x y)  = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
+ppTerm q d (Opts t opts) = "option" <+> ppTerm q 0 t <+>"of" <+> '{' $$
+                              nest 2 (vcat (punctuate ';' (map (ppOpt q) opts))) $$
+                           '}'
 ppTerm q d (App x y)   = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
 ppTerm q d (V e es)    = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
 ppTerm q d (FV es)     = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
@@ -269,6 +272,8 @@ ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
 
 ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
 
+ppOpt q (p,e) = '(' <> ppTerm q 0 p <> ')' <+> "=>" <+> ppTerm q 0 e
+
 ppControl q (id,Nothing) = pp id
 ppControl q (id,Just t ) = pp id <> ':' <+> ppTerm q 6 t
 

From 1a512473cd3385cd3f7838b1962d32300feaaaab Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sun, 17 Aug 2025 22:50:10 +0200
Subject: [PATCH 034/144] composOp of options

---
 src/compiler/api/GF/Grammar/Macros.hs | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs
index 92de22594..da68dfc97 100644
--- a/src/compiler/api/GF/Grammar/Macros.hs
+++ b/src/compiler/api/GF/Grammar/Macros.hs
@@ -404,6 +404,7 @@ composOp co trm =
    RecType r        -> liftM RecType (mapPairsM 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 (pairM co) os)
    T i cc           -> liftM2 (flip T) (mapPairsM co cc) (changeTableType co i)
    V ty vs          -> liftM2 V (co ty) (mapM co vs)
    Let (x,(mt,a)) b -> liftM3 let' (co a) (T.mapM co mt) (co b)

From cbac8b4fd2d8b33c120d318fb82d5fe36cb2f229 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 19 Aug 2025 18:01:37 +0200
Subject: [PATCH 035/144] improve the syntax for options

---
 .../api/GF/Compile/Compute/Concrete2.hs        | 13 +++++++------
 .../api/GF/Compile/TypeCheck/Concrete.hs       | 18 +++++++++++++++++-
 src/compiler/api/GF/Grammar/Grammar.hs         |  2 +-
 src/compiler/api/GF/Grammar/Macros.hs          |  4 ++--
 src/compiler/api/GF/Grammar/Parser.y           | 15 +++++----------
 src/compiler/api/GF/Grammar/Printer.hs         |  3 ++-
 6 files changed, 34 insertions(+), 21 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index 32eab30dc..8c260cc2b 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -94,7 +94,7 @@ data Value
 
 data Variants
   = VarFree [Value]
-  | VarOpts Value [(Value, Value)]
+  | VarOpts Value [(Maybe Value, Value)]
 
 mapVariants :: (Value -> Value) -> Variants -> Variants
 mapVariants f (VarFree vs)   = VarFree (f <$> vs)
@@ -138,7 +138,7 @@ data ConstValue a
 
 data ConstVariants a
   = ConstFree [ConstValue a]
-  | ConstOpts Value [(Value, ConstValue a)]
+  | ConstOpts Value [(Maybe Value, ConstValue a)]
 
 mapConstVs :: (ConstValue a -> ConstValue b) -> ConstVariants a -> ConstVariants b
 mapConstVs f (ConstFree vs)   = ConstFree (f <$> vs)
@@ -337,7 +337,8 @@ eval g env c t@(Opts n cs)  vs  = if null cs
                                            vn = eval g env c1 n []
                                            vcs = mapC evalOpt c cs
                                        in VFV c3 (VarOpts vn vcs)
-  where evalOpt c' (l,t) = let (c1,c2) = split c' in (eval g env c1 l [], eval g env c2 t vs)
+  where evalOpt c' (Just l, t) = let (c1,c2) = split c' in (Just (eval g env c1 l []), eval g env c2 t vs)
+        evalOpt c' (Nothing,t) = let (c1,c2) = split c' in (Nothing,                   eval g env c2 t vs)
 eval g env c t              vs  = VError ("Cannot reduce term" <+> pp t)
 
 evalPredef :: Globals -> Choice -> Ident -> [Value] -> Value
@@ -423,7 +424,7 @@ bubble v = snd (bubble v)
     bubble v@(VFV c (VarOpts n os))
       | null os   = (Map.empty, v)
       | otherwise = let (union,os') = mapAccumL (\acc (k,v) -> second (k,) $ descend acc v) Map.empty os
-                    in (Map.insert c (BubbleOpts n (fst <$> os),1) union, VFV c (VarOpts n os'))
+                    in (Map.insert c (BubbleOpts n (map (\(l,t) -> fromMaybe t l) os),1) union, VFV c (VarOpts n os'))
     bubble (VAlts v vs) = lift1L2 VAlts v vs
     bubble (VStrs vs) = liftL VStrs vs
     bubble (VMarkup tag attrs vs) =
@@ -508,7 +509,7 @@ bubble v = snd (bubble v)
         addVariant c (bvs,cnt) v
           | cnt > 1   = VFV c $ case bvs of
                                   BubbleFree k    -> VarFree (replicate k v)
-                                  BubbleOpts n os -> VarOpts n ((,v) <$> os)
+                                  BubbleOpts n os -> VarOpts n (map (\l -> (Just l,v)) os)
           | otherwise = v
 
     unitfy = fmap (\(n,_) -> (n,1))
@@ -924,7 +925,7 @@ value2termM flat xs (VFV i (VarOpts n os)) =
     let j = fromMaybe 0 (Map.lookup i choices)
     in case os `maybeAt` j of
          Just (l,t) -> case value2termM flat xs t of
-                         EvalM f -> let oi = OptionInfo i n (fst <$> os)
+                         EvalM f -> let oi = OptionInfo i n (map (\(l,t) -> fromMaybe t l) os)
                                     in f g k (State choices metas (oi:opts)) r msgs
          Nothing    -> Fail ("Index" <+> j <+> "out of bounds for option:" $$ ppValue Unqualified 0 n) msgs
 value2termM flat xs (VPatt min max p) = return (EPatt min max p)
diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index a4d730f3d..d85972e95 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -520,7 +520,7 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
 tcRho scope s (Opts n cs) mb_ty = do
   let (s1,s2,s3) = split3 s
   (n,_) <- tcRho scope s1 n Nothing
-  (ls,_) <- tcUnifying scope s2 (fst <$> cs) Nothing
+  (ls,_)  <- tcUnifyingMaybe scope s2 (fst <$> cs) Nothing
   (ts,ty) <- tcUnifying scope s3 (snd <$> cs) mb_ty
   return (Opts n (zip ls ts), ty)
 tcRho scope s t _ = unimplemented ("tcRho "++show t)
@@ -546,6 +546,22 @@ tcUnifying scope c ts mb_ty = do
   ts <- mapCM go c ts
   return (ts,ty)
 
+tcUnifyingMaybe :: Scope -> Choice -> [Maybe Term] -> Maybe Rho -> EvalM ([Maybe Term], Value)
+tcUnifyingMaybe scope c ts mb_ty = do
+  (ty,subsume) <-
+    case mb_ty of
+      Just ty -> do return (ty, \t ty' -> return t)
+      Nothing -> do i <- newResiduation scope
+                    let ty = VMeta i []
+                    return (ty, \t ty' -> subsCheckRho scope t ty' ty >>= \(t,_,_) -> return t)
+
+  let go c (Just t) = do (t, ty) <- tcRho scope c t mb_ty
+                         fmap Just $ subsume t ty
+      go c Nothing  = do return Nothing
+
+  ts <- mapCM go c ts
+  return (ts,ty)
+
 tcCases scope c []         (Just p_ty) (Just res_ty) = return ([],p_ty,res_ty)
 tcCases scope c ((p,t):cs) mb_p_ty     mb_res_ty     = do
   let (c1,c2,c3,c4) = split4 c
diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs
index c2ad8660a..74433c076 100644
--- a/src/compiler/api/GF/Grammar/Grammar.hs
+++ b/src/compiler/api/GF/Grammar/Grammar.hs
@@ -466,7 +466,7 @@ type Equation = ([Patt],Term)
 
 type Labelling = (Label, Type) 
 type Assign = (Label, (Maybe Type, Term)) 
-type Option = (Term, Term)
+type Option = (Maybe Term, Term)
 type Case = (Patt, Term) 
 --type Cases = ([Patt], Term) 
 type LocalDef = (Ident, (Maybe Type, Term))
diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs
index da68dfc97..4c24b9b0e 100644
--- a/src/compiler/api/GF/Grammar/Macros.hs
+++ b/src/compiler/api/GF/Grammar/Macros.hs
@@ -404,7 +404,7 @@ composOp co trm =
    RecType r        -> liftM RecType (mapPairsM 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 (pairM co) os)
+   Opts t os        -> liftM2 Opts (co t) (mapM (\(t1,t2) -> liftM2 (,) (maybe (return Nothing) (liftM Just . co) t1) (co t2)) os)
    T i cc           -> liftM2 (flip T) (mapPairsM co cc) (changeTableType co i)
    V ty vs          -> liftM2 V (co ty) (mapM co vs)
    Let (x,(mt,a)) b -> liftM3 let' (co a) (T.mapM co mt) (co b)
@@ -451,7 +451,7 @@ collectOp co trm = case trm of
   S c a        -> co c <> co a
   Table a c    -> co a <> co c
   ExtR a c     -> co a <> co c
-  Opts t os    -> co t <> mconcatMap (\(a,b) -> co a <> co b) os
+  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
   RecType r    -> mconcatMap (co . snd) r
   P t i        -> co t
diff --git a/src/compiler/api/GF/Grammar/Parser.y b/src/compiler/api/GF/Grammar/Parser.y
index 1edeaf8bb..a6e04dd3a 100644
--- a/src/compiler/api/GF/Grammar/Parser.y
+++ b/src/compiler/api/GF/Grammar/Parser.y
@@ -452,7 +452,11 @@ Exp4 :: { Term }
 Exp4
   : Exp4 Exp5                        { App $1 $2 }
   | Exp4 '{' Exp '}'                 { App $1 (ImplArg $3) } 
-  | 'option' Exp 'of' '{' ListOpt '}' { Opts $2 $5 }
+  | 'option' Exp 'of' '{' ListExp '}' { let toOption t =
+                                              case t of
+                                                Table x y -> (Just x,  y)
+                                                y         -> (Nothing, y)
+                                        in Opts $2 (map toOption $5) }
   | 'case' Exp 'of' '{' ListCase '}' { let annot = case $2 of
                                              Typed _ t -> TTyped t
                                              _         -> TRaw
@@ -608,15 +612,6 @@ ListPattTupleComp
   | Patt                       { [$1]    }
   | Patt ',' ListPattTupleComp { $1 : $3 }
 
-Opt :: { Option }
-Opt
-  : '(' Exp ')' '=>' Exp { ($2,$5) }
-
-ListOpt :: { [Option] }
-ListOpt
-  : Opt             { [$1]    }
-  | Opt ';' ListOpt { $1 : $3 }
-
 Case :: { Case }
 Case
   : Patt '=>' Exp { ($1,$3) } 
diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs
index 078872064..ef6bc9eec 100644
--- a/src/compiler/api/GF/Grammar/Printer.hs
+++ b/src/compiler/api/GF/Grammar/Printer.hs
@@ -272,7 +272,8 @@ ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
 
 ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
 
-ppOpt q (p,e) = '(' <> ppTerm q 0 p <> ')' <+> "=>" <+> ppTerm q 0 e
+ppOpt q (Just p, e) = ppTerm q 0 p <+> "=>" <+> ppTerm q 0 e
+ppOpt q (Nothing,e) = ppTerm q 0 e
 
 ppControl q (id,Nothing) = pp id
 ppControl q (id,Just t ) = pp id <> ':' <+> ppTerm q 6 t

From 8ba7d7ba48d3a770cf2a9c576c6d429dd909893e Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 21 Aug 2025 14:24:42 +0200
Subject: [PATCH 036/144] fix error for clang

---
 src/runtime/c/pgf/vector.h | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/runtime/c/pgf/vector.h b/src/runtime/c/pgf/vector.h
index dd86869b6..edf0fc6e5 100644
--- a/src/runtime/c/pgf/vector.h
+++ b/src/runtime/c/pgf/vector.h
@@ -93,8 +93,8 @@ public:
     iterator begin() { return iterator(ref<A>::from_ptr(&v()->data[0])); }
     iterator end()   { return iterator(ref<A>::from_ptr(&v()->data[v()->len])); }
 
-    bool operator ==(vector<A>& other) const { return offset==other.as_object(); }
-    bool operator !=(vector<A>& other) const { return offset!=other.as_object(); }
+    bool operator ==(vector<A>& other) const { return offset==other.offset; }
+    bool operator !=(vector<A>& other) const { return offset!=other.offset; }
     bool operator ==(object other_offset) const { return offset==other_offset; }
     bool operator !=(object other_offset) const { return offset!=other_offset; }
 

From c02a0c4159da18cc34e42bb9514542eedc490f58 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 26 Aug 2025 19:45:31 +0200
Subject: [PATCH 037/144] fix the case PType => PType

---
 src/compiler/api/GF/Compile/GeneratePMCFG.hs | 11 ++++++++++-
 1 file changed, 10 insertions(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index 0ff244c3d..383b11e41 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -131,13 +131,22 @@ type2metaTerm gr d ms r rs (RecType lbls) = do
 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)])
-  | otherwise  = do let pv    = varX (length rs+1)
+  | 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]
+    collectParams (Table _ t) = collectParams t
+    collectParams t           = collectOp collectParams t
+
     count = case allParamValues gr p of
               Ok ts   -> length ts
               Bad msg -> error msg

From d8df0a0171c2e2e23f574a048f3c0356452423dc Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sat, 30 Aug 2025 14:01:06 +0000
Subject: [PATCH 038/144] fix evaluation of options

---
 src/compiler/api/GF/Compile/Compute/Concrete2.hs | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index 8c260cc2b..2070cbe5a 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -94,7 +94,7 @@ data Value
 
 data Variants
   = VarFree [Value]
-  | VarOpts Value [(Maybe Value, Value)]
+  | VarOpts Value [(Value, Value)]
 
 mapVariants :: (Value -> Value) -> Variants -> Variants
 mapVariants f (VarFree vs)   = VarFree (f <$> vs)
@@ -138,7 +138,7 @@ data ConstValue a
 
 data ConstVariants a
   = ConstFree [ConstValue a]
-  | ConstOpts Value [(Maybe Value, ConstValue a)]
+  | ConstOpts Value [(Value, ConstValue a)]
 
 mapConstVs :: (ConstValue a -> ConstValue b) -> ConstVariants a -> ConstVariants b
 mapConstVs f (ConstFree vs)   = ConstFree (f <$> vs)
@@ -337,8 +337,8 @@ eval g env c t@(Opts n cs)  vs  = if null cs
                                            vn = eval g env c1 n []
                                            vcs = mapC evalOpt c cs
                                        in VFV c3 (VarOpts vn vcs)
-  where evalOpt c' (Just l, t) = let (c1,c2) = split c' in (Just (eval g env c1 l []), eval g env c2 t vs)
-        evalOpt c' (Nothing,t) = let (c1,c2) = split c' in (Nothing,                   eval g env c2 t vs)
+  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)
 
 evalPredef :: Globals -> Choice -> Ident -> [Value] -> Value
@@ -424,7 +424,7 @@ bubble v = snd (bubble v)
     bubble v@(VFV c (VarOpts n os))
       | null os   = (Map.empty, v)
       | otherwise = let (union,os') = mapAccumL (\acc (k,v) -> second (k,) $ descend acc v) Map.empty os
-                    in (Map.insert c (BubbleOpts n (map (\(l,t) -> fromMaybe t l) os),1) union, VFV c (VarOpts n os'))
+                    in (Map.insert c (BubbleOpts n (map fst os),1) union, VFV c (VarOpts n os'))
     bubble (VAlts v vs) = lift1L2 VAlts v vs
     bubble (VStrs vs) = liftL VStrs vs
     bubble (VMarkup tag attrs vs) =
@@ -509,7 +509,7 @@ bubble v = snd (bubble v)
         addVariant c (bvs,cnt) v
           | cnt > 1   = VFV c $ case bvs of
                                   BubbleFree k    -> VarFree (replicate k v)
-                                  BubbleOpts n os -> VarOpts n (map (\l -> (Just l,v)) os)
+                                  BubbleOpts n os -> VarOpts n (map (\l -> (l,v)) os)
           | otherwise = v
 
     unitfy = fmap (\(n,_) -> (n,1))
@@ -925,7 +925,7 @@ value2termM flat xs (VFV i (VarOpts n os)) =
     let j = fromMaybe 0 (Map.lookup i choices)
     in case os `maybeAt` j of
          Just (l,t) -> case value2termM flat xs t of
-                         EvalM f -> let oi = OptionInfo i n (map (\(l,t) -> fromMaybe t l) os)
+                         EvalM f -> let oi = OptionInfo i n (map fst os)
                                     in f g k (State choices metas (oi:opts)) r msgs
          Nothing    -> Fail ("Index" <+> j <+> "out of bounds for option:" $$ ppValue Unqualified 0 n) msgs
 value2termM flat xs (VPatt min max p) = return (EPatt min max p)

From b79a53adc5989ade1acdfc3738dde905f8728cdf Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sat, 30 Aug 2025 14:54:07 +0000
Subject: [PATCH 039/144] fix parsing NLG operations

---
 src/compiler/api/GF/Grammar/Parser.y | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Grammar/Parser.y b/src/compiler/api/GF/Grammar/Parser.y
index a6e04dd3a..b46b17a4f 100644
--- a/src/compiler/api/GF/Grammar/Parser.y
+++ b/src/compiler/api/GF/Grammar/Parser.y
@@ -720,7 +720,7 @@ NLG :: { Map.Map Ident Info }
 
 ListNLGDef :: { [(Ident,Info)] }
 ListNLGDef
-  : 'oper' NLGDef            { []       }
+  : 'oper' NLGDef            { $2       }
   | 'oper' NLGDef ListNLGDef { $2 ++ $3 }
 
 NLGDef :: { [(Ident,Info)] }

From e5a531da616641bc6955d12ed61dc56d5a4b3d1c Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sat, 30 Aug 2025 20:09:13 +0200
Subject: [PATCH 040/144] testing repl not needed anymore

---
 src/compiler/api/GF/Compile/Repl.hs | 313 ----------------------------
 src/compiler/gf-repl.hs             |  12 --
 src/compiler/gf.cabal               |   7 -
 3 files changed, 332 deletions(-)
 delete mode 100644 src/compiler/api/GF/Compile/Repl.hs
 delete mode 100644 src/compiler/gf-repl.hs

diff --git a/src/compiler/api/GF/Compile/Repl.hs b/src/compiler/api/GF/Compile/Repl.hs
deleted file mode 100644
index 7c952cd9e..000000000
--- a/src/compiler/api/GF/Compile/Repl.hs
+++ /dev/null
@@ -1,313 +0,0 @@
-{-# LANGUAGE LambdaCase, TupleSections, NamedFieldPuns #-}
-
-module GF.Compile.Repl (ReplOpts(..), defaultReplOpts, replOptDescrs, getReplOpts, runRepl, runRepl') where
-
-import Control.Monad (join, when, unless, forM_, foldM)
-import Control.Monad.IO.Class (MonadIO)
-import qualified Data.ByteString.Char8 as BS
-import Data.Char (isSpace)
-import Data.Function ((&))
-import Data.Functor ((<&>))
-import Data.List (find)
-import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
-import Text.Read (readMaybe)
-
-import System.Console.GetOpt (ArgOrder(RequireOrder), OptDescr(..), ArgDescr(..), getOpt, usageInfo)
-import System.Console.Haskeline (InputT, Settings(..), noCompletion, runInputT, getInputLine, outputStrLn)
-import System.Directory (getAppUserDataDirectory)
-
-import GF.Compile (batchCompile)
-import GF.Compile.Compute.Concrete2
-  ( Choice(..)
-  , ChoiceMap
-  , Globals(Gl)
-  , OptionInfo(..)
-  , stdPredef
-  , unit
-  , eval
-  , cleanOptions
-  , runEvalMWithOpts
-  , value2termM
-  , ppValue
-  )
-import GF.Compile.Rename (renameSourceTerm)
-import GF.Compile.TypeCheck.Concrete (inferLType)
-import GF.Data.ErrM (Err(..))
-import GF.Data.Utilities (maybeAt, orLeft)
-import GF.Grammar.Grammar
-  ( Grammar
-  , mGrammar
-  , Info
-  , Module
-  , ModuleName
-  , ModuleInfo(..)
-  , ModuleType(MTResource)
-  , ModuleStatus(MSComplete)
-  , OpenSpec(OSimple)
-  , Location (NoLoc)
-  , Term(Typed)
-  , prependModule
-  )
-import GF.Grammar.Lexer (Posn(..), Lang(..), runLangP)
-import GF.Grammar.Parser (pTerm)
-import GF.Grammar.Printer (TermPrintQual(Unqualified), ppTerm)
-import GF.Infra.CheckM (Check, runCheck)
-import GF.Infra.Ident (moduleNameS)
-import GF.Infra.Option (noOptions)
-import GF.Infra.UseIO (justModuleName)
-import GF.Text.Pretty (render)
-import Debug.Trace
-
-data ReplOpts = ReplOpts
-  { lang :: Lang
-  , noPrelude :: Bool
-  , inputFiles :: [String]
-  , evalToFlat :: Bool
-  }
-
-defaultReplOpts :: ReplOpts
-defaultReplOpts = ReplOpts
-  { lang = GF
-  , noPrelude = False
-  , inputFiles = []
-  , evalToFlat = True
-  }
-
-type Errs a = Either [String] a
-type ReplOptsOp = ReplOpts -> Errs ReplOpts
-
-replOptDescrs :: [OptDescr ReplOptsOp]
-replOptDescrs =
-  [ Option ['h'] ["help"] (NoArg $ \o -> Left [usageInfo "gfci" replOptDescrs]) "Display help."
-  , Option [] ["no-prelude"] (flag $ \o -> o { noPrelude = True }) "Don't load the prelude."
-  , Option [] ["lang"] (ReqArg (\s o -> case s of
-                                          "gf"   -> Right (o { lang = GF })
-                                          "bnfc" -> Right (o { lang = BNFC })
-                                          "nlg"  -> Right (o { lang = NLG })
-                                          _      -> Left ["Unknown language variant: " ++ s])
-                               "{gf,bnfc,nlg}")
-           "Set the active language variant."
-  , Option [] ["no-flat"] (flag $ \o -> o { evalToFlat = False }) "Do not evaluate to flat form."
-  ]
-  where
-    flag f = NoArg $ \o -> pure (f o)
-
-getReplOpts :: [String] -> Errs ReplOpts
-getReplOpts args = case errs of
-  [] -> foldM (&) defaultReplOpts flags <&> \o -> o { inputFiles = inputFiles }
-  _  -> Left errs
-  where
-    (flags, inputFiles, errs) = getOpt RequireOrder replOptDescrs args
-
-execCheck :: MonadIO m => Check a -> (a -> InputT m b) -> InputT m (Maybe b)
-execCheck c k = case runCheck c of
-  Ok (a, warn) -> do
-    unless (null warn) $ outputStrLn warn
-    Just <$> k a
-  Bad err -> do
-    outputStrLn err
-    return Nothing
-
-replModNameStr :: String
-replModNameStr = "<repl>"
-
-replModName :: ModuleName
-replModName = moduleNameS replModNameStr
-
-parseThen :: MonadIO m => Lang -> Grammar -> String -> (Term -> InputT m b) -> InputT m (Maybe b)
-parseThen l g s k = case runLangP l pTerm (BS.pack s) of
-  Left (Pn l c, err) -> do
-    outputStrLn $ err ++ " (" ++ show l ++ ":" ++ show c ++ ")"
-    return Nothing
-  Right t -> execCheck (renameSourceTerm g replModName t) $ \t -> k t
-
-data ResultState = ResultState
-  { srsResult  :: Term
-  , srsChoices :: ChoiceMap
-  , srsOptInfo :: [OptionInfo]
-  , srsOpts    :: ChoiceMap
-  }
-data OptionState = OptionState
-  { osTerm     :: Term
-  , osResults  :: [ResultState]
-  , osSelected :: Maybe ResultState
-  }
-newtype ReplState = ReplState
-  { rsOpts :: Maybe OptionState
-  }
-
-initState :: ReplState
-initState = ReplState Nothing
-
-runRepl' :: ReplOpts -> Globals -> IO ()
-runRepl' opts@ReplOpts { lang, evalToFlat } gl@(Gl g _) = do
-  historyFile <- getAppUserDataDirectory "gfci_history"
-  runInputT (Settings noCompletion (Just historyFile) True) (repl initState) -- TODO tab completion
-  where
-    repl st = do
-      getInputLine "gfci> " >>= \case
-        Nothing -> repl st
-        Just (':' : l) -> let (cmd, arg) = break isSpace l in command st cmd (dropWhile isSpace arg)
-        Just code -> evalPrintLoop st code
-
-    nlrepl st = outputStrLn "" >> repl st
-
-    -- Show help text
-    command st "?" arg = do
-      outputStrLn ":? -- show help text."
-      outputStrLn ":t <expr> -- show the inferred type of <expr>."
-      outputStrLn ":r -- show the results of the last eval."
-      outputStrLn ":s <index> -- select the result at <index>."
-      outputStrLn ":c -- show the current selected result."
-      outputStrLn ":o <choice> <value> -- set option <choice> to <value>."
-      outputStrLn ":q -- quit the REPL."
-      nlrepl st
-
-    -- Show the inferred type of an expression
-    command st "t" arg = do
-      parseThen lang g arg $ \main ->
-        execCheck (inferLType gl main) $ \(t, ty) ->
-          let t' = case t of
-                     Typed _ _ -> t
-                     t         -> Typed t ty
-          in outputStrLn $ render (ppTerm Unqualified 0 t')
-      nlrepl st
-    
-    -- Show the results of the last evaluated expression
-    command st "r" arg = do
-      case rsOpts st of
-        Nothing -> do
-          outputStrLn "No results to show!"
-        Just (OptionState t rs _) -> do
-          outputStrLn $ "> " ++ render (ppTerm Unqualified 0 t)
-          outputResults rs
-      nlrepl st
-
-    -- Select a result to "focus" by its index
-    command st "s" arg = do
-      let e = do (OptionState t rs _) <- orLeft "No results to select!" $ rsOpts st
-                 s <- orLeft "Could not parse result index!" $ readMaybe arg
-                 (ResultState r cs ois os) <- orLeft "Result index out of bounds!" $ rs `maybeAt` (s - 1)
-                 return (t, rs, r, cs, ois, os)
-      case e of
-        Left err -> do
-          outputStrLn err
-          nlrepl st
-        Right (t, rs, r, cs, ois, os) -> do
-          outputStrLn $ render (ppTerm Unqualified 0 r)
-          outputOptions ois os
-          nlrepl (st { rsOpts = Just (OptionState t rs (Just (ResultState r cs ois os))) })
-
-    -- Show the current selected result
-    command st "c" arg = do
-      let e = do (OptionState t _ sel) <- orLeft "No results to select!" $ rsOpts st
-                 (ResultState r _ ois os) <- orLeft "No result selected!" sel
-                 return (t, r, ois, os)
-      case e of
-        Left err -> outputStrLn err
-        Right (t, r, ois, os) -> do
-          outputStrLn $ "> " ++ render (ppTerm Unqualified 0 t)
-          outputStrLn $ render (ppTerm Unqualified 0 r)
-          outputOptions ois os
-      nlrepl st
-
-    -- Set an option for the selected result
-    command st "o" arg = do
-      let e = do (OptionState t _ sel) <- orLeft "No results to select!" $ rsOpts st
-                 (ResultState _ cs ois os) <- orLeft "No result selected!" sel
-                 (c, i) <- case words arg of
-                             [argc, argi] -> do
-                               c <- orLeft "Could not parse option choice!" $ readMaybe argc
-                               i <- orLeft "Could not parse option value!" $ readMaybe argi
-                               return (c, i)
-                             _ -> Left "Expected two arguments!"
-                 when (i < 1) $ Left "Option value must be positive!"
-                 oi <- orLeft "No such option!" $ find (\oi -> unchoice (optChoice oi) == c) ois
-                 when (i > length (optChoices oi)) $ Left "Option value out of bounds!"
-                 return (t, cs, ois, os, c, i)
-      case e of
-        Left err -> do
-          outputStrLn err
-          nlrepl st
-        Right (t, cs, ois, os, c, i) -> do
-          let os' = Map.insert (Choice c) (i - 1) os
-          nfs <- execCheck (doEval st t (Map.union os' cs)) pure
-          case nfs of
-            Nothing -> nlrepl st
-            Just [] -> do
-              outputStrLn "No results!"
-              nlrepl st
-            Just [(r, cs, ois')] -> do
-              outputStrLn $ render (ppTerm Unqualified 0 r)
-              let os'' = cleanOptions ois' os'
-              outputOptions ois' os''
-              let rst = ResultState r (Map.difference cs os') ois' os''
-              nlrepl (st { rsOpts = Just (OptionState t [rst] (Just rst)) })
-            Just rs -> do
-              let rsts = rs <&> \(r, cs, ois') ->
-                           ResultState r (Map.difference cs os') ois' (cleanOptions ois' os')
-              outputResults rsts
-              nlrepl (st { rsOpts = Just (OptionState t rsts Nothing) })
-    
-    -- Quit the REPL
-    command _ "q" _ = outputStrLn "Bye!"
-
-    command st cmd _ = do
-      outputStrLn $ "Unknown REPL command \"" ++ cmd ++ "\"! Use :? for help."
-      nlrepl st
-
-    evalPrintLoop st code = do -- TODO bindings
-      c <- parseThen lang g code $ \main -> do
-        rsts <- execCheck (doEval st main Map.empty) $ \nfs -> do
-          if null nfs then do
-            outputStrLn "No results!"
-            return Nothing
-          else do
-            let rsts = nfs <&> \(r, cs, ois) -> ResultState r cs ois Map.empty
-            outputResults rsts
-            return $ Just rsts
-        return $ (main,) <$> join rsts
-      case join c of
-        Just (t, rs) -> nlrepl (ReplState (Just (OptionState t rs Nothing)))
-        Nothing      -> nlrepl st
-
-    doEval st t opts = inferLType gl t >>= \case
-      (t', _) -> runEvalMWithOpts gl opts (value2termM evalToFlat [] (eval gl [] unit t' []))
-    
-    outputResults rs =
-      forM_ (zip [1..] rs) $ \(i, ResultState r _ opts _) ->
-        outputStrLn $ show i ++ (if null opts then ". " else "*. ") ++ render (ppTerm Unqualified 0 r)
-    
-    outputOptions ois os =
-      forM_ ois $ \(OptionInfo c n ls) -> do
-        outputStrLn ""
-        outputStrLn $ show (unchoice c) ++ ") " ++ render (ppValue Unqualified 0 n)
-        let sel = fromMaybe 0 (Map.lookup c os) + 1
-        forM_ (zip [1..] ls) $ \(i, l) ->
-          outputStrLn $ (if i == sel then "->" else "  ") ++ show i ++ ". " ++ render (ppValue Unqualified 0 l)
-
-runRepl :: ReplOpts -> IO ()
-runRepl opts@ReplOpts { noPrelude, inputFiles } = do
-  -- TODO accept an ngf grammar
-  let toLoad = if noPrelude then inputFiles else "prelude/Predef.gfo" : inputFiles
-  (g0, opens) <- case toLoad of
-    [] -> pure (mGrammar [], [])
-    _ -> do
-      (_, g0) <- batchCompile noOptions Nothing toLoad
-      pure (g0, OSimple . moduleNameS . justModuleName <$> toLoad)
-  let
-    modInfo = ModInfo
-      { mtype   = MTResource
-      , mstatus = MSComplete
-      , mflags  = noOptions
-      , mextend = []
-      , mwith   = Nothing
-      , mopens  = opens
-      , mexdeps = []
-      , msrc    = replModNameStr
-      , mseqs   = Nothing
-      , jments  = Map.empty
-      }
-    g = Gl (prependModule g0 (replModName, modInfo)) (if noPrelude then Map.empty else stdPredef g)
-  runRepl' opts g
diff --git a/src/compiler/gf-repl.hs b/src/compiler/gf-repl.hs
deleted file mode 100644
index 5b890fa9e..000000000
--- a/src/compiler/gf-repl.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-import GHC.IO.Encoding (setLocaleEncoding, utf8)
-
-import System.Environment (getArgs)
-import GF.Compile.Repl (getReplOpts, runRepl)
-
-main :: IO ()
-main = do
-  setLocaleEncoding utf8
-  args <- getArgs
-  case getReplOpts args of
-    Left errs  -> mapM_ putStrLn errs
-    Right opts -> runRepl opts
diff --git a/src/compiler/gf.cabal b/src/compiler/gf.cabal
index 56875c9bb..a4f6bd7cf 100644
--- a/src/compiler/gf.cabal
+++ b/src/compiler/gf.cabal
@@ -121,7 +121,6 @@ library
     GF.Compile.GrammarToCanonical
     GF.Compile.ReadFiles
     GF.Compile.Rename
-    GF.Compile.Repl
     GF.Compile.SubExOpt
     GF.Compile.Tags
     GF.Compile.ToAPI
@@ -239,12 +238,6 @@ executable gf
   build-depends: base >= 4.6 && <5, directory>=1.2, gf
   ghc-options: -threaded
 
-executable gfci
-  main-is: gf-repl.hs
-  default-language: Haskell2010
-  build-depends: base >= 4.6 && < 5, gf
-  ghc-options: -threaded
-
 test-suite gf-tests
   type: exitcode-stdio-1.0
   main-is: run.hs

From 85806752c383f6ddc7c6839b4b59e50e41482ce4 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sat, 30 Aug 2025 21:20:52 +0200
Subject: [PATCH 041/144] remove AdHocOverload

---
 src/compiler/api/GF/Grammar/Grammar.hs | 2 --
 src/compiler/api/GF/Grammar/JSON.hs    | 2 --
 src/compiler/api/GF/Grammar/Macros.hs  | 1 -
 src/compiler/api/GF/Grammar/Printer.hs | 1 -
 4 files changed, 6 deletions(-)

diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs
index 74433c076..189b3c36f 100644
--- a/src/compiler/api/GF/Grammar/Grammar.hs
+++ b/src/compiler/api/GF/Grammar/Grammar.hs
@@ -394,8 +394,6 @@ data Term =
  | ELincat Ident Term            -- ^ boxed linearization type of Ident
  | ELin Ident Term               -- ^ boxed linearization of type Ident
 
- | AdHocOverload [Term]          -- ^ ad hoc overloading generated in Rename
-
  | FV [Term]                     -- ^ alternatives in free variation: @variants { s ; ... }@
 
  | Markup Ident [(Ident,Term)] [Term]
diff --git a/src/compiler/api/GF/Grammar/JSON.hs b/src/compiler/api/GF/Grammar/JSON.hs
index ce24559bf..0ca49e15f 100644
--- a/src/compiler/api/GF/Grammar/JSON.hs
+++ b/src/compiler/api/GF/Grammar/JSON.hs
@@ -123,7 +123,6 @@ term2json (Glue t1 t2) = makeObj [("glue1",term2json t1),("glue2", term2json t2)
 term2json (EPattType t) = makeObj [("patttype",term2json t)]
 term2json (ELincat id t) = makeObj [("lincat",showJSON id), ("term",term2json t)]
 term2json (ELin id t) = makeObj [("lin",showJSON id), ("term",term2json t)]
-term2json (AdHocOverload ts) = makeObj [("overloaded",showJSON (map term2json ts))]
 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))
@@ -175,7 +174,6 @@ json2term o  = Vr      <$> o!:"vr"
     <|>      EPattType <$> o!<"patttype"
     <|>        ELincat <$> o!:"lincat" <*> o!<"term"
     <|>        ELin    <$> o!:"lin" <*> o!<"term"
-    <|>  AdHocOverload <$> (o!:"overloaded" >>= mapM json2term)
     <|>        FV      <$> (o!:"variants" >>= mapM json2term)
     <|>        Markup  <$> (o!:"tag") <*>
                            (o!:"attrs" >>= mapM (\(attr,val) -> fmap ((,)attr) (json2term val))) <*>
diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs
index 4c24b9b0e..56b755178 100644
--- a/src/compiler/api/GF/Grammar/Macros.hs
+++ b/src/compiler/api/GF/Grammar/Macros.hs
@@ -466,7 +466,6 @@ collectOp co trm = case trm of
   Strs tt      -> mconcatMap co tt
   ELincat _ t  -> co t
   ELin _ t     -> co t
-  AdHocOverload ts -> mconcatMap co ts
   Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap co cs
   Reset _ ct t _-> maybe mempty co ct <> co t
   _            -> mempty -- covers K, Vr, Cn, Sort
diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs
index ef6bc9eec..9a6283e49 100644
--- a/src/compiler/api/GF/Grammar/Printer.hs
+++ b/src/compiler/api/GF/Grammar/Printer.hs
@@ -224,7 +224,6 @@ ppTerm q d (Opts t opts) = "option" <+> ppTerm q 0 t <+>"of" <+> '{' $$
 ppTerm q d (App x y)   = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
 ppTerm q d (V e es)    = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
 ppTerm q d (FV es)     = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
-ppTerm q d (AdHocOverload es)     = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
 ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
 ppTerm q d (Strs es)   = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
 ppTerm q d (EPatt _ _ p)=prec d 4 ('#' <+> ppPatt q 2 p)

From 25b3d8026ce9f4c1d9f84368206b1370e3677a1e Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Mon, 1 Sep 2025 08:43:58 +0000
Subject: [PATCH 042/144] added value2expr

---
 src/compiler/api/GF/Compile/Compute/Concrete2.hs | 16 +++++++++++++++-
 1 file changed, 15 insertions(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index 2070cbe5a..90fa57bb6 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -8,7 +8,7 @@ module GF.Compile.Compute.Concrete2
             PredefImpl, Predef(..), ($\),
             pdCanonicalArgs, pdArity,
             normalForm, normalFlatForm,
-            eval, apply, value2term, value2termM, value2int, value2float, bubble, patternMatch, vtableSelect, State(..),
+            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
 
@@ -34,6 +34,7 @@ import Data.Functor ((<&>))
 import Data.Maybe (fromMaybe,fromJust)
 import Data.List
 import Data.Char
+import PGF2(Expr(..),Literal(..))
 
 type PredefImpl = Globals -> Choice -> [Value] -> ConstValue Value
 newtype Predef = Predef { runPredef :: PredefImpl }
@@ -1163,6 +1164,19 @@ value2float g (VFlt f)         = Const f
 value2float g (VFV s vs)       = CFV s (variants2consts (value2float g) vs)
 value2float g _                = RunTime
 
+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))
+value2expr g xs (VGen j vs)    = foldl (\e v -> fmap EApp e <*> value2expr g xs v) (pure (EVar (length xs - j - 1))) vs
+value2expr g xs (VClosure env s (Abs b x t)) =
+  let v  = eval g ((x,VGen (length xs) []):env) s t []
+      x' = mkFreshVar xs x
+  in fmap (EAbs b (showIdent x')) (value2expr g (x':xs) v)
+value2expr g xs (VInt n)       = pure (ELit (LInt n))
+value2expr g xs (VFlt f)       = pure (ELit (LFlt f))
+value2expr g xs v              = fmap (ELit . LStr) (value2string g v)
+
 newtype Choice = Choice { unchoice :: Integer }
   deriving (Eq,Ord,Pretty,Show)
 

From 4eb8ae2f850369f04c58e44fb27ca1f332129e5e Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 2 Sep 2025 12:21:18 +0000
Subject: [PATCH 043/144] refactoring bugfixing related to options

---
 .../api/GF/Compile/Compute/Concrete2.hs       | 135 ++++++++----------
 1 file changed, 60 insertions(+), 75 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index 90fa57bb6..3cfb3f772 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -1,10 +1,10 @@
 {-# LANGUAGE RankNTypes, BangPatterns, GeneralizedNewtypeDeriving, TupleSections #-}
 
 module GF.Compile.Compute.Concrete2
-           (Env, Scope, Value(..), Variants(..), OptionInfo(..), ChoiceMap, cleanOptions,
-            ConstValue(..), ConstVariants(..), Globals(..), PredefTable, EvalM,
-            mapVariants, mapVariantsC, unvariants, variants2consts, consts2variants,
-            runEvalM, runEvalMWithOpts, stdPredef, globals,
+           (Env, Scope, Value(..), Variants(..), OptionInfo(..),
+            ConstValue(..), Globals(..), PredefTable, EvalM,
+            mapVariants, mapVariantsC, unvariants,
+            runEvalM, runEvalMWithInput, stdPredef, globals,
             PredefImpl, Predef(..), ($\),
             pdCanonicalArgs, pdArity,
             normalForm, normalFlatForm,
@@ -84,7 +84,7 @@ data Value
   | VGlue Value Value
   | VPatt Int (Maybe Int) Patt
   | VPattType Value
-  | VFV Choice Variants
+  | VFV Choice (Variants Value)
   | VAlts Value [(Value, Value)]
   | VStrs [Value]
   | VMarkup Ident [(Ident,Value)] [Value]
@@ -93,19 +93,19 @@ data Value
   | VError Doc
   | VInts Integer Bool
 
-data Variants
-  = VarFree [Value]
-  | VarOpts Value [(Value, Value)]
+data Variants a
+  = VarFree [a]
+  | VarOpts Value [(Value, a)]
 
-mapVariants :: (Value -> Value) -> Variants -> Variants
+mapVariants :: (a -> b) -> Variants a -> Variants b
 mapVariants f (VarFree vs)   = VarFree (f <$> vs)
 mapVariants f (VarOpts n cs) = VarOpts n (second f <$> cs)
 
-mapVariantsC :: (Choice -> Value -> Value) -> Choice -> Variants -> Variants
+mapVariantsC :: (Choice -> a -> b) -> Choice -> Variants a -> Variants b
 mapVariantsC f c (VarFree vs)   = VarFree (mapC f c vs)
 mapVariantsC f c (VarOpts n cs) = VarOpts n (mapC (\c (x,y) -> (x,f c y)) c cs)
 
-unvariants :: Variants -> [Value]
+unvariants :: Variants a -> [a]
 unvariants (VarFree vs)   = vs
 unvariants (VarOpts n cs) = snd <$> cs
 
@@ -133,25 +133,13 @@ isCanonicalForm flat  _ = False
 data ConstValue a
   = Const a
   | CSusp MetaId (Value -> ConstValue a)
-  | CFV Choice (ConstVariants a)
+  | CFV Choice (Variants (ConstValue a))
   | RunTime
   | NonExist
 
-data ConstVariants a
-  = ConstFree [ConstValue a]
-  | ConstOpts Value [(Value, ConstValue a)]
-
-mapConstVs :: (ConstValue a -> ConstValue b) -> ConstVariants a -> ConstVariants b
-mapConstVs f (ConstFree vs)   = ConstFree (f <$> vs)
-mapConstVs f (ConstOpts n cs) = ConstOpts n (second f <$> cs)
-
-unconstVs :: ConstVariants a -> [ConstValue a]
-unconstVs (ConstFree vs)   = vs
-unconstVs (ConstOpts n cs) = snd <$> cs
-
 instance Functor ConstValue where
   fmap f (Const c) = Const (f c)
-  fmap f (CFV i vs) = CFV i (mapConstVs (fmap f) vs)
+  fmap f (CFV i vs) = CFV i (mapVariants (fmap f) vs)
   fmap f (CSusp i k) = CSusp i (fmap f . k)
   fmap f RunTime   = RunTime
   fmap f NonExist  = NonExist
@@ -160,8 +148,8 @@ instance Applicative ConstValue where
   pure = Const
 
   (Const f)     <*> (Const x)     = Const (f x)
-  (CFV s vs)    <*> v2            = CFV s (mapConstVs (<*> v2) vs)
-  v1            <*> (CFV s vs)    = CFV s (mapConstVs (v1 <*>) vs)
+  (CFV s vs)    <*> v2            = CFV s (mapVariants (<*> v2) vs)
+  v1            <*> (CFV s vs)    = CFV s (mapVariants (v1 <*>) vs)
   (CSusp i k)   <*> v2            = CSusp i (\v -> k v <*> v2)
   v1            <*> (CSusp i k)   = CSusp i (\v -> v1 <*> k v)
   NonExist      <*> _             = NonExist
@@ -169,14 +157,6 @@ instance Applicative ConstValue where
   RunTime       <*>  _            = RunTime
   _             <*>  RunTime      = RunTime
 
-variants2consts :: (Value -> ConstValue a) -> Variants -> ConstVariants a
-variants2consts f (VarFree vs)   = ConstFree (f <$> vs)
-variants2consts f (VarOpts n os) = ConstOpts n (second f <$> os)
-
-consts2variants :: (ConstValue a -> Value) -> ConstVariants a -> Variants
-consts2variants f (ConstFree vs)   = VarFree (f <$> vs)
-consts2variants f (ConstOpts n os) = VarOpts n (second f <$> os)
-
 normalForm :: Globals -> Term -> Check Term
 normalForm g t = value2term g [] (bubble (eval g [] unit t []))
 
@@ -256,7 +236,7 @@ eval g env s (S t1 t2)      vs  = let (!s1,!s2) = split s
                                       select v1               = v0
                                           
                                       -- FIXME: options=[] is definitely not correct and this shouldn't be using value2termM at all
-                                      empty = State Map.empty Map.empty []
+                                      empty = State [] Map.empty Map.empty []
 
                                 in select v1
 eval g env s (Let (x,(_,t1)) t2) vs = let (!s1,!s2) = split s
@@ -347,7 +327,7 @@ evalPredef g@(Gl gr pds) c n args =
   case Map.lookup n pds of
     Nothing  -> VApp c (cPredef,n) args
     Just def -> let valueOf (Const res) = res
-                    valueOf (CFV i vs)  = VFV i (consts2variants valueOf vs)
+                    valueOf (CFV i vs)  = VFV i (mapVariants valueOf vs)
                     valueOf (CSusp i k) = VSusp i (valueOf . k) []
                     valueOf RunTime     = VApp c (cPredef,n) args
                     valueOf NonExist    = VApp c (cPredef,cNonExist) []
@@ -625,7 +605,7 @@ vtableSelect g v0 ty cs v2 vs =
   where
     select (Const (i,_)) = cs !! i
     select (CSusp i k)   = VSusp i (\v -> select (k v)) []
-    select (CFV s vs)    = VFV s (consts2variants select vs)
+    select (CFV c vs)    = VFV c (mapVariants select vs)
     select _             = v0
 
     value2index (VMeta i vs)      ty = CSusp i (\v -> value2index (apply g v vs) ty)
@@ -665,7 +645,7 @@ vtableSelect g v0 ty cs v2 vs =
         Gl gr _ = g
     value2index (VInt n)          ty
       | Just max <- isTypeInts ty    = Const (fromIntegral n,fromIntegral max+1)
-    value2index (VFV i vs)        ty = CFV i (variants2consts (\v -> value2index v ty) vs)
+    value2index (VFV c vs)        ty = CFV c (mapVariants (\v -> value2index v ty) vs)
     value2index v ty = RunTime
 
 
@@ -683,20 +663,18 @@ data MetaState
 data OptionInfo
   = OptionInfo
       { optChoice  :: Choice
+      , optValue   :: Int
       , optLabel   :: Value
       , optChoices :: [Value]
       }
-type ChoiceMap = Map.Map Choice Int
 data State
   = State
-      { choices  :: ChoiceMap
+      { input    :: [(Choice, Int)]
+      , choices  :: Map.Map Choice Int
       , metaVars :: Map.Map MetaId MetaState
       , options  :: [OptionInfo]
       }
 
-cleanOptions :: [OptionInfo] -> ChoiceMap -> ChoiceMap
-cleanOptions opts = Map.filterWithKey (\k _ -> any (\opt -> k == optChoice opt) opts)
-
 type Cont r = State -> r -> [Message] -> CheckResult r [Message]
 newtype EvalM a = EvalM (forall r . Globals -> (a -> Cont r) -> Cont r)
 
@@ -732,15 +710,15 @@ runEvalM g (EvalM f) = Check $ \(es,ws) ->
     Fail   msg ws -> Fail msg (es,ws)
     Success xs ws -> Success (reverse xs) (es,ws)
   where
-    empty = State Map.empty Map.empty []
+    empty = State [] Map.empty Map.empty []
 
-runEvalMWithOpts :: Globals -> ChoiceMap -> EvalM a -> Check [(a, ChoiceMap, [OptionInfo])]
-runEvalMWithOpts g cs (EvalM f) = Check $ \(es,ws) ->
-  case f g (\x (State cs mvs os) xs ws -> Success ((x,cs,reverse os):xs) ws) init [] ws of
+runEvalMWithInput :: Globals -> [(Choice,Int)] -> EvalM a -> Check [(a, [OptionInfo])]
+runEvalMWithInput g input (EvalM f) = Check $ \(es,ws) ->
+  case f g (\x (State _ cs mvs os) xs ws -> Success ((x,reverse os):xs) ws) init [] ws of
     Fail   msg ws -> Fail msg (es,ws)
     Success xs ws -> Success (reverse xs) (es,ws)
   where
-    init = State cs Map.empty []
+    init = State input Map.empty Map.empty []
 
 reset :: EvalM a -> EvalM [a]
 reset (EvalM f) = EvalM $ \g k state r ws ->
@@ -752,32 +730,32 @@ globals :: EvalM Globals
 globals = EvalM (\g k -> k g)
 
 variants :: Choice -> [a] -> EvalM a
-variants c xs = EvalM (\g k state@(State choices metas opts) r msgs ->
+variants c xs = EvalM (\g k state@(State input choices metas opts) r msgs ->
   case Map.lookup c choices of
     Just j  -> k (xs !! j) state r msgs
-    Nothing -> backtrack 0 xs k choices metas opts r msgs)
+    Nothing -> backtrack 0 xs k input choices metas opts r msgs)
   where
-    backtrack j []     k choices metas opts r msgs = Success r msgs
-    backtrack j (x:xs) k choices metas opts r msgs =
-      case k x (State (Map.insert c j choices) metas opts) r msgs of
+    backtrack j []     k input choices metas opts r msgs = Success r msgs
+    backtrack j (x:xs) k input choices metas opts r msgs =
+      case k x (State input (Map.insert c j choices) metas opts) r msgs of
         Fail    msg msgs -> Fail msg msgs
-        Success r   msgs -> backtrack (j+1) xs k choices metas opts r msgs
+        Success r   msgs -> backtrack (j+1) xs k input choices metas opts r msgs
 
 variants' :: Choice -> (a -> EvalM Term) -> [a] -> EvalM Term
-variants' c f xs = EvalM (\g k state@(State choices metas opts) r msgs ->
+variants' c f xs = EvalM (\g k state@(State input choices metas opts) r msgs ->
   case Map.lookup c choices of
     Just j  -> case f (xs !! j) of
                  EvalM f -> f g k state r msgs
-    Nothing -> case backtrack g 0 xs choices metas opts [] msgs of
+    Nothing -> case backtrack g 0 xs input choices metas opts [] msgs of
                  Fail    msg msgs -> Fail msg msgs
                  Success ts  msgs -> k (FV (reverse ts)) state r msgs)
   where
-    backtrack g j []     choices metas opts ts msgs = Success ts msgs
-    backtrack g j (x:xs) choices metas opts ts msgs =
+    backtrack g j []     input choices metas opts ts msgs = Success ts msgs
+    backtrack g j (x:xs) input choices metas opts ts msgs =
       case f x of
-        EvalM f -> case f g (\t st ts msgs -> Success (t:ts) msgs) (State (Map.insert c j choices) metas opts) ts msgs of
+        EvalM f -> case f g (\t st ts msgs -> Success (t:ts) msgs) (State input (Map.insert c j choices) metas opts) ts msgs of
                      Fail    msg msgs -> Fail msg msgs
-                     Success ts  msgs -> backtrack g (j+1) xs choices metas opts ts msgs
+                     Success ts  msgs -> backtrack g (j+1) xs input choices metas opts ts msgs
 
 try :: Int -> (a -> EvalM b) -> ([b] -> EvalM b) -> [a] -> EvalM b
 try sz f select xs = EvalM (\g k state r msgs ->
@@ -801,9 +779,9 @@ try sz f select xs = EvalM (\g k state r msgs ->
                           Nothing -> ms
 
 newResiduation :: Scope -> EvalM MetaId
-newResiduation scope = EvalM (\g k (State choices metas opts) r msgs ->
+newResiduation scope = EvalM (\g k (State input choices metas opts) r msgs ->
   let meta_id = Map.size metas+1
-  in k meta_id (State choices (Map.insert meta_id (Residuation scope) metas) opts) r msgs)
+  in k meta_id (State input choices (Map.insert meta_id (Residuation scope) metas) opts) r msgs)
 
 checkpoint :: EvalM Int
 checkpoint = EvalM (\g k state r msgs ->
@@ -816,8 +794,8 @@ getMeta i = EvalM (\g k state r msgs ->
     Nothing -> Fail ("Metavariable ?"<>pp i<+>"is not defined") msgs) 
 
 setMeta :: MetaId -> MetaState -> EvalM ()
-setMeta i ms = EvalM (\g k (State choices metas opts) r msgs ->
-  let state' = State choices (Map.insert i ms metas) opts
+setMeta i ms = EvalM (\g k (State input choices metas opts) r msgs ->
+  let state' = State input choices (Map.insert i ms metas) opts
   in k () state' r msgs)
 
 value2termM :: Bool -> [Ident] -> Value -> EvalM Term
@@ -920,14 +898,20 @@ value2termM flat xs (VGlue v1 v2) = do
 value2termM True xs (VFV i (VarFree vs)) = do
   v <- variants i vs
   value2termM True xs v
-value2termM False xs (VFV i (VarFree vs)) = variants' i (value2termM False xs) vs
-value2termM flat xs (VFV i (VarOpts n os)) =
-  EvalM $ \g k (State choices metas opts) r msgs ->
-    let j = fromMaybe 0 (Map.lookup i choices)
+value2termM False xs (VFV c (VarFree vs)) = variants' c (value2termM False xs) vs
+value2termM flat xs (VFV c (VarOpts n os)) =
+  EvalM $ \g k (State input choices metas opts) r msgs ->
+    let (j,input',choices',opts') =
+          case Map.lookup c choices of
+            Just j  -> (j,input,choices,opts)
+            Nothing -> case input of
+                         (c',j):input | c == c' -> let oi = OptionInfo c j n (map fst os)
+                                                   in (j,input,Map.insert c j choices,oi:opts)
+                         _                      -> let oi = OptionInfo c 0 n (map fst os)
+                                                   in (0,[],Map.insert c 0 choices,oi:opts)
     in case os `maybeAt` j of
          Just (l,t) -> case value2termM flat xs t of
-                         EvalM f -> let oi = OptionInfo i n (map fst os)
-                                    in f g k (State choices metas (oi:opts)) r msgs
+                         EvalM f -> f g k (State input' choices' metas opts') r msgs
          Nothing    -> Fail ("Index" <+> j <+> "out of bounds for option:" $$ ppValue Unqualified 0 n) msgs
 value2termM flat xs (VPatt min max p) = return (EPatt min max p)
 value2termM flat xs (VPattType v) = do t <- value2termM flat xs v
@@ -1104,7 +1088,7 @@ value2string' g VEmpty           b ws      qs = Const (b,ws,qs)
 value2string' g (VC v1 v2)       b ws      qs = concat v1 (value2string' g v2 b ws qs)
   where
     concat v1 (Const (b,ws,qs)) = value2string' g v1 b ws qs
-    concat v1 (CFV i vs)        = CFV i (mapConstVs (concat v1) vs)
+    concat v1 (CFV c vs)        = CFV c (mapVariants (concat v1) vs)
     concat v1 res               = res
 value2string' g (VApp c q []) b   ws     qs
   | q == (cPredef,cNonExist)              = NonExist
@@ -1138,7 +1122,7 @@ value2string' g (VAlts vd vas) b  ws     qs =
       | or [startsWith s w | VStr s <- ss] = value2string' g v
       | otherwise                          = pre vd vas w
 value2string' g (VFV s vs) b      ws     qs =
-  CFV s (variants2consts (\v -> value2string' g v b ws qs) vs)
+  CFV s (mapVariants (\v -> value2string' g v b ws qs) vs)
 value2string' _ _ _ _ _ = RunTime
 
 startsWith []          _ = True
@@ -1155,13 +1139,13 @@ string2value' (w:ws) = VC (VStr w) (string2value' ws)
 value2int g (VMeta i vs)     = CSusp i (\v -> value2int g (apply g v vs))
 value2int g (VSusp i k vs)   = CSusp i (\v -> value2int g (apply g (k v) vs))
 value2int g (VInt n)         = Const n
-value2int g (VFV s vs)       = CFV s (variants2consts (value2int g) vs)
+value2int g (VFV s vs)       = CFV s (mapVariants (value2int g) vs)
 value2int g _                = RunTime
 
 value2float g (VMeta i vs)     = CSusp i (\v -> value2float g (apply g v vs))
 value2float g (VSusp i k vs)   = CSusp i (\v -> value2float g (apply g (k v) vs))
 value2float g (VFlt f)         = Const f
-value2float g (VFV s vs)       = CFV s (variants2consts (value2float g) vs)
+value2float g (VFV s vs)       = CFV s (mapVariants (value2float g) vs)
 value2float g _                = RunTime
 
 value2expr g xs (VApp _ (m,f) vs)
@@ -1175,6 +1159,7 @@ value2expr g xs (VClosure env s (Abs b x t)) =
   in fmap (EAbs b (showIdent x')) (value2expr g (x':xs) v)
 value2expr g xs (VInt n)       = pure (ELit (LInt n))
 value2expr g xs (VFlt f)       = pure (ELit (LFlt f))
+value2expr g xs (VFV s vs)     = CFV s (mapVariants (value2expr g xs) vs)
 value2expr g xs v              = fmap (ELit . LStr) (value2string g v)
 
 newtype Choice = Choice { unchoice :: Integer }

From adf042f2831295877ec75dd24b08f60b99b93ba6 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 3 Sep 2025 12:47:05 +0000
Subject: [PATCH 044/144] identification: String=Str, Int=Predef.Int,
 Float=Predef.Float

---
 src/compiler/api/GF/Grammar/Lookup.hs | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Grammar/Lookup.hs b/src/compiler/api/GF/Grammar/Lookup.hs
index c2eb5d6d1..30d581c72 100644
--- a/src/compiler/api/GF/Grammar/Lookup.hs
+++ b/src/compiler/api/GF/Grammar/Lookup.hs
@@ -68,7 +68,11 @@ lookupIdentInfo (m,ModPGF{mpgf=pgf})   i =
                 Nothing   -> notFound i
   where
     cnvType xs (PGF2.DTyp hypos cat es) =
-      appHypos hypos xs (QC (m,identS cat)) es
+      let t | cat == "String" = Sort cStr
+            | cat == "Int"    = QC (cPredef,cInt)
+            | cat == "Float"  = QC (cPredef,cFloat)
+            | otherwise       = QC (m,identS cat)
+      in appHypos hypos xs t es
 
     appHypos []                  xs t es =
       foldl (appExpr xs) t es

From 5ce60c745b1be4d2b32379406ccf3e766a67404a Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 4 Sep 2025 14:12:59 +0000
Subject: [PATCH 045/144] added minimal implementation for XML parsing

---
 src/compiler/api/GF/Data/XML.hs | 232 +++++++++++++++++++++++++++++++-
 1 file changed, 230 insertions(+), 2 deletions(-)

diff --git a/src/compiler/api/GF/Data/XML.hs b/src/compiler/api/GF/Data/XML.hs
index 933dc243a..cd9b18339 100644
--- a/src/compiler/api/GF/Data/XML.hs
+++ b/src/compiler/api/GF/Data/XML.hs
@@ -1,11 +1,13 @@
-----------------------------------------------------------------------
+    ----------------------------------------------------------------------
 -- |
 -- Module      : XML
 --
 -- Utilities for creating XML documents.
 ----------------------------------------------------------------------
-module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where
+module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML, parseXML) where
 
+import Data.Char(isSpace)
+import Numeric (readHex)
 import GF.Data.Utilities
 
 data XML = Data String | Tag String [Attr] [XML] | ETag String [Attr] | Comment String | Empty
@@ -54,3 +56,229 @@ escape = concatMap escChar
 bottomUpXML :: (XML -> XML) -> XML -> XML
 bottomUpXML f (Tag n attrs cs) = f (Tag n attrs (map (bottomUpXML f) cs))
 bottomUpXML f x = f x
+
+
+-- Lexer -----------------------------------------------------------------------
+
+type Line               = Integer
+type LChar              = (Line,Char)
+type LString            = [LChar]
+data Token              = TokStart Line String [Attr] Bool  -- is empty?
+                        | TokEnd Line String
+                        | TokCRef String
+                        | TokText String
+                          deriving Show
+
+tokens             :: String -> [Token]
+tokens = tokens' . linenumber 1
+
+tokens' :: LString -> [Token]
+tokens' ((_,'<') : c@(_,'!') : cs) = special c cs
+
+tokens' ((_,'<') : cs)   = tag (dropSpace cs) -- we are being nice here
+tokens' [] = []
+tokens' cs@((l,_):_) = let (as,bs) = breakn ('<' ==) cs
+                       in map cvt (decode_text as) ++ tokens' bs
+
+  -- XXX: Note, some of the lines might be a bit inacuarate
+  where cvt (TxtBit x)  = TokText x
+        cvt (CRefBit x) = case cref_to_char x of
+                            Just c -> TokText [c]
+                            Nothing -> TokCRef x
+
+
+special :: LChar -> LString -> [Token]
+special _ ((_,'-') : (_,'-') : cs) = skip cs
+  where skip ((_,'-') : (_,'-') : (_,'>') : ds) = tokens' ds
+        skip (_ : ds) = skip ds
+        skip [] = [] -- unterminated comment
+
+special c ((_,'[') : (_,'C') : (_,'D') : (_,'A') : (_,'T') : (_,'A') : (_,'[')
+         : cs) =
+  let (xs,ts) = cdata cs
+  in TokText xs : tokens' ts
+  where cdata ((_,']') : (_,']') : (_,'>') : ds) = ([],ds)
+        cdata ((_,d) : ds)  = let (xs,ys) = cdata ds in (d:xs,ys)
+        cdata []        = ([],[])
+
+special c cs =
+  let (xs,ts) = munch "" 0 cs
+  in TokText ('<':'!':(reverse xs)) : tokens' ts
+  where munch acc nesting ((_,'>') : ds)
+         | nesting == (0::Int) = ('>':acc,ds)
+         | otherwise           = munch ('>':acc) (nesting-1) ds
+        munch acc nesting ((_,'<') : ds)
+         = munch ('<':acc) (nesting+1) ds
+        munch acc n ((_,x) : ds) = munch (x:acc) n ds
+        munch acc _ [] = (acc,[]) -- unterminated DTD markup
+
+--special c cs = tag (c : cs) -- invalid specials are processed as tags
+
+linenumber :: Integer -> String -> LString
+linenumber n s = 
+  case s of
+    [] -> []
+    ('\r':s') -> case s' of
+                   ('\n':s'') -> next s''
+                   _          -> next s'
+    ('\n':s') -> next s'
+    (c   :s') -> (n,c) : linenumber n s'
+  where
+    next s' = n' `seq` ((n,'\n'):linenumber n' s') where n' = n + 1
+
+
+qualName           :: LString -> (String,LString)
+qualName xs         = breakn endName xs
+  where endName x = isSpace x || x == '=' || x == '>' || x == '/'
+
+
+
+
+
+tag              :: LString -> [Token]
+tag ((p,'/') : cs)    = let (n,ds) = qualName (dropSpace cs)
+                        in TokEnd p n : case (dropSpace ds) of
+                                          (_,'>') : es -> tokens' es
+                                          -- tag was not properly closed...
+                                          _        -> tokens' ds
+tag []            = []
+tag cs            = let (n,ds)  = qualName cs
+                        (as,b,ts) = attribs (dropSpace ds)
+                    in TokStart (fst (head cs)) n as b : ts
+
+attribs          :: LString -> ([Attr], Bool, [Token])
+attribs cs        = case cs of
+                      (_,'>') : ds -> ([], False, tokens' ds)
+
+                      (_,'/') : ds -> ([], True, case ds of
+                                              (_,'>') : es -> tokens' es
+                                              -- insert missing >  ...
+                                              _ -> tokens' ds)
+
+                      (_,'?') : (_,'>') : ds -> ([], True, tokens' ds)
+
+                      -- doc ended within a tag..
+                      []       -> ([],False,[])
+
+                      _        -> let (a,cs1) = attrib cs
+                                      (as,b,ts) = attribs cs1
+                                  in (a:as,b,ts)
+
+attrib             :: LString -> (Attr,LString)
+attrib cs           = let (ks,cs1)  = qualName cs
+                          (vs,cs2)  = attr_val (dropSpace cs1)
+                      in ((ks,decode_attr vs),dropSpace cs2)
+
+attr_val           :: LString -> (String,LString)
+attr_val ((_,'=') : cs) = string (dropSpace cs)
+attr_val cs         = ("",cs)
+
+
+dropSpace :: LString -> LString
+dropSpace = dropWhile (isSpace . snd)
+
+-- | Match the value for an attribute.  For malformed XML we do
+-- our best to guess the programmer's intention.
+string             :: LString -> (String,LString)
+string ((_,'"') : cs)   = break' ('"' ==) cs
+
+-- Allow attributes to be enclosed between ' '.
+string ((_,'\'') : cs)  = break' ('\'' ==) cs
+
+-- Allow attributes that are not enclosed by anything.
+string cs           = breakn eos cs
+  where eos x = isSpace x || x == '>' || x == '/'
+
+
+break' :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)])
+break' p xs         = let (as,bs) = breakn p xs
+                      in (as, case bs of
+                                [] -> []
+                                _ : cs -> cs)
+
+breakn :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)])
+breakn p l = (map snd as,bs) where (as,bs) = break (p . snd) l
+
+
+
+decode_attr :: String -> String
+decode_attr cs = concatMap cvt (decode_text cs)
+  where cvt (TxtBit x) = x
+        cvt (CRefBit x) = case cref_to_char x of
+                            Just c -> [c]
+                            Nothing -> '&' : x ++ ";"
+
+data Txt = TxtBit String | CRefBit String deriving Show
+
+decode_text :: [Char] -> [Txt]
+decode_text xs@('&' : cs) = case break (';' ==) cs of
+                              (as,_:bs) -> CRefBit as : decode_text bs
+                              _ -> [TxtBit xs]
+decode_text []  = []
+decode_text cs  = let (as,bs) = break ('&' ==) cs
+                  in TxtBit as : decode_text bs
+
+cref_to_char :: [Char] -> Maybe Char
+cref_to_char cs = case cs of
+  '#' : ds  -> num_esc ds
+  "lt"      -> Just '<'
+  "gt"      -> Just '>'
+  "amp"     -> Just '&'
+  "apos"    -> Just '\''
+  "quot"    -> Just '"'
+  _         -> Nothing
+
+num_esc :: String -> Maybe Char
+num_esc cs = case cs of
+               'x' : ds -> check (readHex ds)
+               _        -> check (reads cs)
+
+  where check [(n,"")]  = cvt_char n
+        check _         = Nothing
+
+cvt_char :: Int -> Maybe Char
+cvt_char x
+  | fromEnum (minBound :: Char) <= x && x <= fromEnum (maxBound::Char)
+                = Just (toEnum x)
+  | otherwise = Nothing
+
+
+-- Parser --------------------------------------------------------------
+
+-- | parseXML to a list of content chunks
+parseXML :: String -> [XML]
+parseXML  = parse . tokens
+
+------------------------------------------------------------------------
+
+parse      :: [Token] -> [XML]
+parse []    = []
+parse ts    = let (es,_,ts1) = nodes [] ts
+              in es ++ parse ts1
+
+nodes :: [String] -> [Token] -> ([XML], [String], [Token])
+nodes ps (TokCRef ref : ts) =
+  let (es,qs,ts1) = nodes ps ts
+  in (Data ref : es, qs, ts1)
+nodes ps (TokText txt : ts) =
+  let (es,qs,ts1) = nodes ps ts
+      (more,es1)  = case es of
+                      Data cd : es1' -> (cd,es1')
+                      _              -> ([],es)
+  in (Data (txt ++ more) : es1, qs, ts1)
+nodes ps (TokStart p t as empty : ts) = (node : siblings, open, toks)
+  where
+    (node,(siblings,open,toks))
+      | empty     = (ETag t as, nodes ps ts)
+      | otherwise = let (es1,qs1,ts1) = nodes (t:ps) ts
+                    in (Tag t as es1,
+                        case qs1 of
+                          [] -> nodes ps ts1
+                          _ : qs3 -> ([],qs3,ts1))
+nodes ps (TokEnd p t : ts)   = case break (t ==) ps of
+                                  (as,_:_) -> ([],as,ts)
+                                  -- Unknown closing tag. Insert as text.
+                                  (_,[]) ->
+                                    let (es,qs,ts1) = nodes ps ts
+                                    in (Data "" : es,qs,ts1)
+nodes ps []                 = ([],ps,[])

From 0c21b85dbb54cc027a4d07b4f56f0a6b1e07a809 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sun, 7 Sep 2025 20:44:15 +0200
Subject: [PATCH 046/144] added tabularLinearize

---
 src/runtime/python/pypgf.c | 57 ++++++++++++++++++++++++++++++++++++--
 1 file changed, 55 insertions(+), 2 deletions(-)

diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c
index 7e90c51ad..50803a58c 100644
--- a/src/runtime/python/pypgf.c
+++ b/src/runtime/python/pypgf.c
@@ -355,6 +355,59 @@ PgfLinearizationOutputIfaceVtbl pypgf_lin_out_iface_vtbl =
     (void*) pypgf_lin_out_flush
 };
 
+static PyObject*
+Concr_tabularLinearize(ConcrObject* self, PyObject *args)
+{
+	ExprObject* pyexpr;
+	if (!PyArg_ParseTuple(args, "O!", &pgf_ExprType, &pyexpr))
+        return NULL;
+
+	PgfExn err;
+	PgfText **texts =
+        pgf_tabular_linearize(self->grammar->db, self->concr, (PgfExpr) pyexpr, NULL,
+                              &marshaller, &err);
+	if (handleError(err) != PGF_EXN_NONE) {
+        return NULL;
+	}
+
+    if (texts == NULL) {
+        Py_RETURN_NONE;
+    }
+
+    PyObject *res = PyList_New(0);
+    if (!res)
+        goto fail;
+
+    while (texts[0] != NULL && texts[1] != NULL) {
+        PyObject* pyfield = PyUnicode_FromStringAndSize(texts[0]->text, texts[0]->size);
+        free(texts[0]); texts++;
+        if (!pyfield)
+            goto fail;
+
+        PyObject* pylin   = PyUnicode_FromStringAndSize(texts[0]->text, texts[0]->size);
+        free(texts[0]); texts++;
+        if (!pylin)
+            goto fail;
+
+        PyObject *tup = PyTuple_New(2);
+        PyTuple_SetItem(tup, 0, pyfield);
+        PyTuple_SetItem(tup, 1, pylin);
+        PyList_Append(res, tup);
+        Py_DECREF(tup);
+    }
+
+    return res;
+
+fail:
+    Py_XDECREF(res);
+
+    while (texts[0]) {
+        free(texts[0]); texts++;
+    }
+
+    return NULL;
+}
+
 static PyObject*
 Concr_bracketedLinearize(ConcrObject* self, PyObject *args)
 {
@@ -548,10 +601,10 @@ static PyMethodDef Concr_methods[] = {
     },
     /*{"linearizeAll", (PyCFunction)Concr_linearizeAll, METH_VARARGS | METH_KEYWORDS,
      "Takes an abstract tree and linearizes with all variants"
-    },
+    },*/
     {"tabularLinearize", (PyCFunction)Concr_tabularLinearize, METH_VARARGS,
      "Takes an abstract tree and linearizes it to a table containing all fields"
-	},*/
+	},
     {"bracketedLinearize", (PyCFunction)Concr_bracketedLinearize, METH_VARARGS,
      "Takes an abstract tree and linearizes it to a bracketed string"
     },

From 8467e2eb24173721954dedec1f7c6d77f7a22a19 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sun, 7 Sep 2025 20:46:08 +0200
Subject: [PATCH 047/144] added tabularLinearize

---
 src/runtime/python/pypgf.c | 57 ++++++++++++++++++++++++++++++++++++--
 1 file changed, 55 insertions(+), 2 deletions(-)

diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c
index 7e90c51ad..50803a58c 100644
--- a/src/runtime/python/pypgf.c
+++ b/src/runtime/python/pypgf.c
@@ -355,6 +355,59 @@ PgfLinearizationOutputIfaceVtbl pypgf_lin_out_iface_vtbl =
     (void*) pypgf_lin_out_flush
 };
 
+static PyObject*
+Concr_tabularLinearize(ConcrObject* self, PyObject *args)
+{
+	ExprObject* pyexpr;
+	if (!PyArg_ParseTuple(args, "O!", &pgf_ExprType, &pyexpr))
+        return NULL;
+
+	PgfExn err;
+	PgfText **texts =
+        pgf_tabular_linearize(self->grammar->db, self->concr, (PgfExpr) pyexpr, NULL,
+                              &marshaller, &err);
+	if (handleError(err) != PGF_EXN_NONE) {
+        return NULL;
+	}
+
+    if (texts == NULL) {
+        Py_RETURN_NONE;
+    }
+
+    PyObject *res = PyList_New(0);
+    if (!res)
+        goto fail;
+
+    while (texts[0] != NULL && texts[1] != NULL) {
+        PyObject* pyfield = PyUnicode_FromStringAndSize(texts[0]->text, texts[0]->size);
+        free(texts[0]); texts++;
+        if (!pyfield)
+            goto fail;
+
+        PyObject* pylin   = PyUnicode_FromStringAndSize(texts[0]->text, texts[0]->size);
+        free(texts[0]); texts++;
+        if (!pylin)
+            goto fail;
+
+        PyObject *tup = PyTuple_New(2);
+        PyTuple_SetItem(tup, 0, pyfield);
+        PyTuple_SetItem(tup, 1, pylin);
+        PyList_Append(res, tup);
+        Py_DECREF(tup);
+    }
+
+    return res;
+
+fail:
+    Py_XDECREF(res);
+
+    while (texts[0]) {
+        free(texts[0]); texts++;
+    }
+
+    return NULL;
+}
+
 static PyObject*
 Concr_bracketedLinearize(ConcrObject* self, PyObject *args)
 {
@@ -548,10 +601,10 @@ static PyMethodDef Concr_methods[] = {
     },
     /*{"linearizeAll", (PyCFunction)Concr_linearizeAll, METH_VARARGS | METH_KEYWORDS,
      "Takes an abstract tree and linearizes with all variants"
-    },
+    },*/
     {"tabularLinearize", (PyCFunction)Concr_tabularLinearize, METH_VARARGS,
      "Takes an abstract tree and linearizes it to a table containing all fields"
-	},*/
+	},
     {"bracketedLinearize", (PyCFunction)Concr_bracketedLinearize, METH_VARARGS,
      "Takes an abstract tree and linearizes it to a bracketed string"
     },

From d42e351fde5f5efdf22694766e503ac8330e1859 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 9 Sep 2025 19:34:20 +0200
Subject: [PATCH 048/144] fix space leak in functionsByCat

---
 src/runtime/python/pypgf.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c
index 50803a58c..020171991 100644
--- a/src/runtime/python/pypgf.c
+++ b/src/runtime/python/pypgf.c
@@ -945,8 +945,8 @@ _collect_funs(PgfItor *fn, PgfText *key, object value, PgfExn *err)
 
     if (PyList_Append((PyObject*) clo->collection, py_name) != 0) {
         err->type = PGF_EXN_OTHER_ERROR;
-        Py_DECREF(py_name);
     }
+    Py_DECREF(py_name);
 }
 
 static PyObject *

From cc0a56cc480b1915e3926e0d8ba2dcce390e2a38 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 9 Sep 2025 19:35:32 +0200
Subject: [PATCH 049/144] fix space leak in functions and functionsByCat

---
 src/runtime/python/pypgf.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c
index 50803a58c..020171991 100644
--- a/src/runtime/python/pypgf.c
+++ b/src/runtime/python/pypgf.c
@@ -945,8 +945,8 @@ _collect_funs(PgfItor *fn, PgfText *key, object value, PgfExn *err)
 
     if (PyList_Append((PyObject*) clo->collection, py_name) != 0) {
         err->type = PGF_EXN_OTHER_ERROR;
-        Py_DECREF(py_name);
     }
+    Py_DECREF(py_name);
 }
 
 static PyObject *

From 570d223302ede41affbbaa44ed9d311eccbfb5d7 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 9 Sep 2025 19:48:38 +0200
Subject: [PATCH 050/144] space leak in _collect_cats

---
 src/runtime/python/pypgf.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c
index 020171991..44f42ff22 100644
--- a/src/runtime/python/pypgf.c
+++ b/src/runtime/python/pypgf.c
@@ -859,8 +859,8 @@ _collect_cats(PgfItor *fn, PgfText *key, object value, PgfExn *err)
 
     if (PyList_Append((PyObject*) clo->collection, py_name) != 0) {
         err->type = PGF_EXN_OTHER_ERROR;
-        Py_DECREF(py_name);
     }
+    Py_DECREF(py_name);
 }
 
 static PyObject *

From 0f54675a918ddebdcc643370db8c46fba00e5bb7 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 12 Sep 2025 07:18:38 +0000
Subject: [PATCH 051/144] added the filter construction

---
 src/compiler/api/GF/Compile/Compute/Concrete2.hs  | 10 ++++++++++
 src/compiler/api/GF/Compile/TypeCheck/Concrete.hs | 13 +++++++++++++
 src/compiler/api/GF/Grammar/Predef.hs             |  4 ++++
 3 files changed, 27 insertions(+)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index 3cfb3f772..c7c7daf42 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -973,6 +973,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
diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index d85972e95..0c609e2bb 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -487,6 +487,19 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
                  Nothing -> evalError (pp "[select: .. | ..] requires an integer argument")
       (t,_) <- tcRho scope c1 t (Just rec_ty)
       return (Reset ctl mb_ct t qid,ty)
+  | ctl == cFilter = do
+      ty <- case mb_ty of
+              Just ty -> return ty
+              Nothing -> do i <- newResiduation scope
+                            return (VMeta i [])
+      let rec_ty = VRecType [ (ident2label cp1, True, ty)
+                            , (ident2label cp2, True, VApp poison (cPredef,cBool) [])
+                            ] False
+      case mb_ct of
+        Just ct -> evalError (pp "[filter | ..] cannot take an argument")
+        Nothing -> return ()
+      (t,_) <- tcRho scope c t (Just rec_ty)
+      return (Reset ctl mb_ct t qid,ty)
   | ctl == cDefault = do
       let (c1,c2) = split c
       (t,ty)     <- tcRho scope c1 t mb_ty
diff --git a/src/compiler/api/GF/Grammar/Predef.hs b/src/compiler/api/GF/Grammar/Predef.hs
index f807d762a..c284d9033 100644
--- a/src/compiler/api/GF/Grammar/Predef.hs
+++ b/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,6 +69,7 @@ cConcat = identS "concat"
 cConcat' = identS "concat'"
 cOne = identS "one"
 cSelect = identS "select"
+cFilter = identS "filter"
 cDefault = identS "default"
 cList = identS "list"
 cLen = identS "len"

From ae9ac01e00933e43030e5404333f71fb9e1878ae Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 16 Sep 2025 19:47:34 +0200
Subject: [PATCH 052/144] remove deprecated module

---
 src/compiler/api/GF/Grammar/PatternMatch.hs | 183 --------------------
 src/compiler/gf.cabal                       |   1 -
 2 files changed, 184 deletions(-)
 delete mode 100644 src/compiler/api/GF/Grammar/PatternMatch.hs

diff --git a/src/compiler/api/GF/Grammar/PatternMatch.hs b/src/compiler/api/GF/Grammar/PatternMatch.hs
deleted file mode 100644
index 53a99fe56..000000000
--- a/src/compiler/api/GF/Grammar/PatternMatch.hs
+++ /dev/null
@@ -1,183 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : PatternMatch
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/10/12 12:38:29 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.7 $
---
--- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
------------------------------------------------------------------------------
-
-module GF.Grammar.PatternMatch (
-                                matchPattern,
-                                testOvershadow,
-                                findMatch
-                               ) where
-
-import GF.Data.Operations
-import GF.Grammar.Grammar
-import GF.Infra.Ident
-import GF.Grammar.Macros
---import GF.Grammar.Printer
-
-import Data.Maybe(fromMaybe)
-import Control.Monad
-import GF.Text.Pretty
---import Debug.Trace
-
-matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
-matchPattern pts term =
-  if not (isInConstantForm term)
-    then raise (render ("variables occur in" <+> pp term))
-  else do
-    term' <- mkK term
-    errIn (render ("trying patterns" <+> hsep (punctuate ',' (map fst pts)))) $
-      findMatch [([p],t) | (p,t) <- pts] [term']
- where
-  -- to capture all Str with string pattern matching
-  mkK s = case s of
-    C _ _ -> do
-      s' <- getS s
-      return (K (unwords s'))
-    _ -> return s
-
-  getS s = case s of
-    K w -> return [w]
-    C v w -> liftM2 (++) (getS v) (getS w)
-    Empty -> return []
-    _ -> raise (render ("cannot get string from" <+> s))
-
-testOvershadow :: ErrorMonad m => [Patt] -> [Term] -> m [Patt]
-testOvershadow pts vs = do
-  let numpts = zip pts [0..]
-  let cases  = [(p,EInt i) | (p,i) <- numpts]
-  ts <- mapM (liftM fst . matchPattern cases) vs
-  return [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ]
-
-findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
-findMatch cases terms = case cases of
-   [] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms)))
-   (patts,_):_ | length patts /= length terms ->
-       raise (render ("wrong number of args for patterns :" <+> hsep patts <+>
-                    "cannot take" <+> hsep terms))
-   (patts,val):cc -> case mapM tryMatch (zip patts terms) of
-       Ok substs -> return (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' =
-    case (p,t') of
---    (_,(x,Typed e ty,y)) -> trym p (x,e,y) -- Add this? /TH 2013-09-05
-      (_,(x,Empty,y)) -> trym p (x,K [],y)   -- because "" = [""] = []
-      (PW, _) -> return [] -- optimization with wildcard
-      (PV x,([],K s,[])) -> return [(x,words2term (words s))]
-      (PV x,  _) -> 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?
-      (PC p pp, ([], Con f, tt)) |
-            p `eqStrIdent` f && length pp == length tt ->
-         do matches <- mapM tryMatch (zip pp tt)
-            return (concat matches)
-
-      (PP (q,p) pp, ([], QC (r,f), tt)) |
-            -- q `eqStrIdent` r &&  --- not for inherited AR 10/10/2005
-            p `eqStrIdent` f && length pp == length tt ->
-         do matches <- mapM tryMatch (zip pp tt)
-            return (concat matches)
-      ---- hack for AppPredef bug
-      (PP (q,p) pp, ([], Q (r,f), tt)) |
-            -- q `eqStrIdent` r && ---
-            p `eqStrIdent` f && length pp == length tt ->
-         do matches <- mapM tryMatch (zip pp tt)
-            return (concat matches)
-
-      (PR r, ([],R r',[])) |
-            all (`elem` map fst r') (map fst r) ->
-         do matches <- mapM tryMatch
-                            [(p,snd a) | (l,p) <- r, let Just a = lookup l r']
-            return (concat matches)
-      (PT _ p',_) -> trym p' t'
-
-      (PAs x p',([],K s,[])) -> do
-         subst <- trym p' t'
-         return $ (x,words2term (words s)) : subst
-
-      (PAs x p',_) -> do
-         subst <- trym p' t'
-         return $ (x,t) : subst
-
-      (PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t']
-
-      (PNeg p',_) -> case tryMatch (p',t) of
-        Bad _ -> return []
-        _ -> raise (render ("no match with negative pattern" <+> p))
-
-      (PSeq min1 max1 p1 min2 max2 p2, ([],K s, [])) -> matchPSeq min1 max1 p1 min2 max2 p2 s
-
-      (PRep _ _ p1, ([],K s, [])) -> checks [
-         trym (foldr (const (PSeq 0 Nothing p1 0 Nothing)) (PString "")
-           [1..n]) t' | n <- [0 .. length s]
-        ] >>
-        return []
-
-      (PChar,  ([],K [_], [])) -> return []
-      (PChars cs, ([],K [c], [])) | elem c cs -> return []
-
-      _ -> raise (render ("no match in case expr for" <+> t))
-
-  words2term []     = Empty
-  words2term [w]    = K w
-  words2term (w:ws) = C (K w) (words2term ws)
-
-matchPSeq min1 max1 p1 min2 max2 p2 s =
-  do let n = length s
-         lo = min1 `max` (n-fromMaybe n max2)
-         hi = (n-min2) `min` (fromMaybe n max1)
-         cuts = [splitAt i s | i <- [lo..hi]]
-     matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
-     return (concat matches)
-
-isInConstantForm :: Term -> Bool
-isInConstantForm trm = case trm of
-    Cn _     -> True
-    Con _    -> True
-    Q _      -> True
-    QC _     -> True
-    Abs _ _ _ -> True
-    C c a    -> isInConstantForm c && isInConstantForm a
-    App c a  -> isInConstantForm c && isInConstantForm a
-    R r      -> all (isInConstantForm . snd . snd) r
-    K _      -> True
-    Empty    -> True
-    EInt _   -> True
-    V ty ts  -> isInConstantForm ty && all isInConstantForm ts -- TH 2013-09-05
---  Typed e t-> isInConstantForm e && isInConstantForm t -- Add this? TH 2013-09-05
-
-    _       -> False ---- isInArgVarForm trm
-{- -- unused and suspicuous, see contP in GF.Compile.Compute.Concrete instead
-varsOfPatt :: Patt -> [Ident]
-varsOfPatt p = case p of
-  PV x -> [x]
-  PC _ ps -> concat $ map varsOfPatt ps
-  PP _ ps -> concat $ map varsOfPatt ps
-  PR r    -> concat $ map (varsOfPatt . snd) r
-  PT _ q -> varsOfPatt q
-  _ -> []
-
--- | to search matching parameter combinations in tables
-isMatchingForms :: [Patt] -> [Term] -> Bool
-isMatchingForms ps ts = all match (zip ps ts') where
-  match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds
-  match _ = True
-  ts' = map appForm ts
-
--}
diff --git a/src/compiler/gf.cabal b/src/compiler/gf.cabal
index a4f6bd7cf..e79a7fdad 100644
--- a/src/compiler/gf.cabal
+++ b/src/compiler/gf.cabal
@@ -146,7 +146,6 @@ library
     GF.Grammar.Lookup
     GF.Grammar.Macros
     GF.Grammar.Parser
-    GF.Grammar.PatternMatch
     GF.Grammar.Predef
     GF.Grammar.Printer
     GF.Grammar.ShowTerm

From cd5ef68b4da595c2b19aa767dfb49924212923f4 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 16 Sep 2025 19:52:04 +0200
Subject: [PATCH 053/144] Variants is a functor

---
 .../api/GF/Compile/Compute/Concrete2.hs       | 50 +++++++++----------
 1 file changed, 25 insertions(+), 25 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index 3cfb3f772..1af64bf83 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -3,7 +3,7 @@
 module GF.Compile.Compute.Concrete2
            (Env, Scope, Value(..), Variants(..), OptionInfo(..),
             ConstValue(..), Globals(..), PredefTable, EvalM,
-            mapVariants, mapVariantsC, unvariants,
+            mapVariantsC, unvariants,
             runEvalM, runEvalMWithInput, stdPredef, globals,
             PredefImpl, Predef(..), ($\),
             pdCanonicalArgs, pdArity,
@@ -97,9 +97,9 @@ data Variants a
   = VarFree [a]
   | VarOpts Value [(Value, a)]
 
-mapVariants :: (a -> b) -> Variants a -> Variants b
-mapVariants f (VarFree vs)   = VarFree (f <$> vs)
-mapVariants f (VarOpts n cs) = VarOpts n (second f <$> cs)
+instance Functor Variants where
+    fmap f (VarFree vs)   = VarFree (f <$> vs)
+    fmap f (VarOpts n cs) = VarOpts n (second f <$> cs)
 
 mapVariantsC :: (Choice -> a -> b) -> Choice -> Variants a -> Variants b
 mapVariantsC f c (VarFree vs)   = VarFree (mapC f c vs)
@@ -139,7 +139,7 @@ data ConstValue a
 
 instance Functor ConstValue where
   fmap f (Const c) = Const (f c)
-  fmap f (CFV i vs) = CFV i (mapVariants (fmap f) vs)
+  fmap f (CFV i vs) = CFV i (fmap (fmap f) vs)
   fmap f (CSusp i k) = CSusp i (fmap f . k)
   fmap f RunTime   = RunTime
   fmap f NonExist  = NonExist
@@ -148,8 +148,8 @@ instance Applicative ConstValue where
   pure = Const
 
   (Const f)     <*> (Const x)     = Const (f x)
-  (CFV s vs)    <*> v2            = CFV s (mapVariants (<*> v2) vs)
-  v1            <*> (CFV s vs)    = CFV s (mapVariants (v1 <*>) vs)
+  (CFV s vs)    <*> v2            = CFV s (fmap (<*> v2) vs)
+  v1            <*> (CFV s vs)    = CFV s (fmap (v1 <*>) vs)
   (CSusp i k)   <*> v2            = CSusp i (\v -> k v <*> v2)
   v1            <*> (CSusp i k)   = CSusp i (\v -> v1 <*> k v)
   NonExist      <*> _             = NonExist
@@ -192,7 +192,7 @@ eval g env s (P t lbl)      vs  = let project (VR as)        = case lookup lbl a
                                                                  Nothing -> VError ("Missing value for label" <+> pp lbl $$
                                                                                     "in" <+> pp (P t lbl))
                                                                  Just v  -> apply g v vs
-                                      project (VFV s fvs)    = VFV s (mapVariants project fvs)
+                                      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 v              = VP v lbl vs
@@ -201,8 +201,8 @@ eval g env s (ExtR t1 t2)   []  = let (s1,s2) = split s
 
                                       extend (VR       as1) (VR       as2)   = VR       (foldl (\as (lbl,v) -> update lbl v as) as1 as2)
                                       extend (VRecType as1 e1) (VRecType as2 e2)=VRecType (foldl (\as (lbl,o,v) -> update3 lbl o v as) as1 as2) (e1 || e2)
-                                      extend (VFV i fvs)    v2               = VFV i (mapVariants (`extend` v2) fvs)
-                                      extend v1             (VFV i fvs)      = VFV i (mapVariants (v1 `extend`) fvs)
+                                      extend (VFV i fvs)    v2               = VFV i (fmap (`extend` v2) fvs)
+                                      extend v1             (VFV i fvs)      = VFV i (fmap (v1 `extend`) fvs)
                                       extend (VMeta i vs)   v2               = VSusp i (\v -> extend (apply g v vs) v2) []
                                       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) []
@@ -230,7 +230,7 @@ eval g env s (S t1 t2)      vs  = let (!s1,!s2) = split s
                                                                                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 (mapVariants select fvs)
+                                      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 v1               = v0
@@ -253,8 +253,8 @@ eval g env s (C t1 t2)      []  = let (!s1,!s2) = split s
 
                                       concat v1           VEmpty = v1
                                       concat VEmpty           v2 = v2
-                                      concat (VFV i fvs)      v2 = VFV i (mapVariants (`concat` v2) fvs)
-                                      concat v1      (VFV i fvs) = VFV i (mapVariants (v1 `concat`) fvs)
+                                      concat (VFV i fvs)      v2 = VFV i (fmap (`concat` v2) fvs)
+                                      concat v1      (VFV i fvs) = VFV i (fmap (v1 `concat`) fvs)
                                       concat (VMeta i vs)     v2 = VSusp i (\v -> concat (apply g v vs) v2) []
                                       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) []
@@ -276,8 +276,8 @@ eval g env s (Glue t1 t2)   []  = let (!s1,!s2) = split s
                                       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
                                       glue (VAlts d vas) v             = glue d v
-                                      glue (VFV i fvs)   v2            = VFV i (mapVariants (`glue` v2) fvs)
-                                      glue v1            (VFV i fvs)   = VFV i (mapVariants (v1 `glue`) fvs)
+                                      glue (VFV i fvs)   v2            = VFV i (fmap (`glue` v2) fvs)
+                                      glue v1            (VFV i fvs)   = VFV i (fmap (v1 `glue`) fvs)
                                       glue (VMeta i vs)  v2            = VSusp i (\v -> glue (apply g v vs) v2) []
                                       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) []
@@ -327,7 +327,7 @@ evalPredef g@(Gl gr pds) c n args =
   case Map.lookup n pds of
     Nothing  -> VApp c (cPredef,n) args
     Just def -> let valueOf (Const res) = res
-                    valueOf (CFV i vs)  = VFV i (mapVariants valueOf vs)
+                    valueOf (CFV i vs)  = VFV i (fmap valueOf vs)
                     valueOf (CSusp i k) = VSusp i (valueOf . k) []
                     valueOf RunTime     = VApp c (cPredef,n) args
                     valueOf NonExist    = VApp c (cPredef,cNonExist) []
@@ -362,7 +362,7 @@ apply g (VApp c f@(m,n)  vs0)           vs
   | m == cPredef                            = evalPredef g c n (vs0++vs)
   | otherwise                               = VApp c f (vs0++vs)
 apply g (VGen i  vs0)                   vs  = VGen i (vs0++vs)
-apply g (VFV i fvs)                     vs  = VFV i (mapVariants (\v -> apply g v vs) fvs)
+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 v                               []  = v
@@ -546,7 +546,7 @@ patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
         (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 (mapVariants (\arg -> match' env p ps eqs arg args) vs)
+        (p,           VFV s vs) -> VFV s (fmap (\arg -> match' env p ps eqs arg args) vs)
         (PP q qs,  VApp c r vs)
           | q == r              -> match env (qs++ps) eqs (vs++args)
         (PR pas,  VR as)        -> matchRec env (reverse pas) as ps eqs args
@@ -605,7 +605,7 @@ vtableSelect g v0 ty cs v2 vs =
   where
     select (Const (i,_)) = cs !! i
     select (CSusp i k)   = VSusp i (\v -> select (k v)) []
-    select (CFV c vs)    = VFV c (mapVariants select 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)
@@ -645,7 +645,7 @@ vtableSelect g v0 ty cs v2 vs =
         Gl gr _ = g
     value2index (VInt n)          ty
       | Just max <- isTypeInts ty    = Const (fromIntegral n,fromIntegral max+1)
-    value2index (VFV c vs)        ty = CFV c (mapVariants (\v -> value2index v ty) vs)
+    value2index (VFV c vs)        ty = CFV c (fmap (\v -> value2index v ty) vs)
     value2index v ty = RunTime
 
 
@@ -1088,7 +1088,7 @@ value2string' g VEmpty           b ws      qs = Const (b,ws,qs)
 value2string' g (VC v1 v2)       b ws      qs = concat v1 (value2string' g v2 b ws qs)
   where
     concat v1 (Const (b,ws,qs)) = value2string' g v1 b ws qs
-    concat v1 (CFV c vs)        = CFV c (mapVariants (concat v1) vs)
+    concat v1 (CFV c vs)        = CFV c (fmap (concat v1) vs)
     concat v1 res               = res
 value2string' g (VApp c q []) b   ws     qs
   | q == (cPredef,cNonExist)              = NonExist
@@ -1122,7 +1122,7 @@ value2string' g (VAlts vd vas) b  ws     qs =
       | or [startsWith s w | VStr s <- ss] = value2string' g v
       | otherwise                          = pre vd vas w
 value2string' g (VFV s vs) b      ws     qs =
-  CFV s (mapVariants (\v -> value2string' g v b ws qs) vs)
+  CFV s (fmap (\v -> value2string' g v b ws qs) vs)
 value2string' _ _ _ _ _ = RunTime
 
 startsWith []          _ = True
@@ -1139,13 +1139,13 @@ string2value' (w:ws) = VC (VStr w) (string2value' ws)
 value2int g (VMeta i vs)     = CSusp i (\v -> value2int g (apply g v vs))
 value2int g (VSusp i k vs)   = CSusp i (\v -> value2int g (apply g (k v) vs))
 value2int g (VInt n)         = Const n
-value2int g (VFV s vs)       = CFV s (mapVariants (value2int g) vs)
+value2int g (VFV s vs)       = CFV s (fmap (value2int g) vs)
 value2int g _                = RunTime
 
 value2float g (VMeta i vs)     = CSusp i (\v -> value2float g (apply g v vs))
 value2float g (VSusp i k vs)   = CSusp i (\v -> value2float g (apply g (k v) vs))
 value2float g (VFlt f)         = Const f
-value2float g (VFV s vs)       = CFV s (mapVariants (value2float g) vs)
+value2float g (VFV s vs)       = CFV s (fmap (value2float g) vs)
 value2float g _                = RunTime
 
 value2expr g xs (VApp _ (m,f) vs)
@@ -1159,7 +1159,7 @@ value2expr g xs (VClosure env s (Abs b x t)) =
   in fmap (EAbs b (showIdent x')) (value2expr g (x':xs) v)
 value2expr g xs (VInt n)       = pure (ELit (LInt n))
 value2expr g xs (VFlt f)       = pure (ELit (LFlt f))
-value2expr g xs (VFV s vs)     = CFV s (mapVariants (value2expr g xs) vs)
+value2expr g xs (VFV s vs)     = CFV s (fmap (value2expr g xs) vs)
 value2expr g xs v              = fmap (ELit . LStr) (value2string g v)
 
 newtype Choice = Choice { unchoice :: Integer }

From 6e529e74d9e1460df393e550aef897a6f6c581f1 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 16 Oct 2025 09:20:21 +0000
Subject: [PATCH 054/144] added the const control

---
 src/compiler/api/GF/Compile/Compute/Concrete2.hs  | 5 +++++
 src/compiler/api/GF/Compile/TypeCheck/Concrete.hs | 8 ++++++++
 src/compiler/api/GF/Grammar/Predef.hs             | 1 +
 3 files changed, 14 insertions(+)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index b2c711f9b..eda69b78b 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -1004,6 +1004,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)
diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index 0c609e2bb..dce428643 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -529,6 +529,14 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
                          (ct,_) <- tcRho scope c2 ct (Just (VProd Explicit identW vtypeInt res_ty))
                          return (Reset ctl (Just ct) t Nothing, res_ty)
            Nothing -> instSigma scope c2 (Reset ctl Nothing t Nothing) vtypeInt mb_ty
+  | ctl == cConst = do
+      let (c1,c2) = split c
+      (t,_)      <- tcRho scope c1 t Nothing
+      (mb_ct,ty) <- case mb_ct of
+                      Just ct -> do (ct,ty) <- tcRho scope c2 ct mb_ty
+                                    return (Just ct,ty)
+                      Nothing -> evalError (pp "[list: .. | ..] requires an argument")
+      return (Reset ctl mb_ct t qid,ty)
   | otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
 tcRho scope s (Opts n cs) mb_ty = do
   let (s1,s2,s3) = split3 s
diff --git a/src/compiler/api/GF/Grammar/Predef.hs b/src/compiler/api/GF/Grammar/Predef.hs
index c284d9033..fd80cc5b6 100644
--- a/src/compiler/api/GF/Grammar/Predef.hs
+++ b/src/compiler/api/GF/Grammar/Predef.hs
@@ -73,6 +73,7 @@ cFilter = identS "filter"
 cDefault = identS "default"
 cList = identS "list"
 cLen = identS "len"
+cConst = identS "const"
 
 cp1 = identS "p1"
 cp2 = identS "p2"

From bd26b24aed52050ccc3707f0225c587243866eed Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sun, 19 Oct 2025 14:41:29 +0000
Subject: [PATCH 055/144] retain source location for the children of a Markup

---
 .../api/GF/Compile/Compute/Concrete.hs        |  4 ++--
 .../api/GF/Compile/Compute/Concrete2.hs       | 18 +++++++++------
 .../api/GF/Compile/TypeCheck/Concrete.hs      |  4 ++--
 src/compiler/api/GF/Data/XML.hs               | 13 ++++++++++-
 src/compiler/api/GF/Grammar/Grammar.hs        |  2 +-
 src/compiler/api/GF/Grammar/JSON.hs           |  4 ++--
 src/compiler/api/GF/Grammar/Macros.hs         |  4 ++--
 src/compiler/api/GF/Grammar/Parser.y          | 22 ++++++++++---------
 src/compiler/api/GF/Grammar/Printer.hs        |  4 ++--
 src/compiler/api/GF/Infra/Location.hs         |  6 ++++-
 10 files changed, 51 insertions(+), 30 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete.hs b/src/compiler/api/GF/Compile/Compute/Concrete.hs
index 7306fab4f..35e98b612 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete.hs
@@ -285,7 +285,7 @@ eval env (Strs ts)      []  = do vs <- mapM (\t -> eval env t []) ts
                                  return (VStrs vs)
 eval env (Markup tag as ts) [] =
                               do as <- mapM (\(id,t) -> eval env t [] >>= \v -> return (id,v)) as
-                                 vs <- mapM (\t -> eval env t []) ts
+                                 vs <- mapM (\t -> eval env (unLoc t) []) ts
                                  return (VMarkup tag as vs)
 eval env (TSymCat d r rs) []= do rs <- forM rs $ \(i,(pv,ty)) ->
                                          case lookup pv env of
@@ -638,7 +638,7 @@ value2term flat xs (VStrs vs) = do
 value2term flat xs (VMarkup tag as vs) = do
   as <- mapM (\(id,v) -> value2term flat xs v >>= \t -> return (id,t)) as
   ts <- mapM (value2term flat xs) vs
-  return (Markup tag as ts)
+  return (Markup tag as (map noLoc ts))
 value2term flat xs (VCInts (Just i) Nothing) = return (App (Q (cPredef,cInts)) (EInt i))
 value2term flat xs (VCInts Nothing (Just j)) = return (App (Q (cPredef,cInts)) (EInt j))
 value2term flat xs (VCRecType lctrs) = do
diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index eda69b78b..ff3610a15 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -87,7 +87,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 +126,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
 
@@ -308,7 +308,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]
@@ -410,7 +410,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 +481,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'))
@@ -928,7 +932,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)
@@ -942,7 +946,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)
@@ -951,7 +955,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
diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index dce428643..933b09dda 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -452,8 +452,8 @@ tcRho scope c (Markup tag attrs children) mb_ty = do
                        (t,_) <- tcRho scope c t Nothing
                        return (id,t))
                  c1 attrs
-  res <- mapCM (\c child -> tcRho scope c child Nothing) c2 children
-  instSigma scope c3 (Markup tag attrs (map fst res)) vtypeMarkup mb_ty
+  res <- mapCM (\c (L loc child) -> fmap (L loc . fst) (tcRho scope c child Nothing)) c2 children
+  instSigma scope c3 (Markup tag attrs res) vtypeMarkup mb_ty
 tcRho scope c (Reset ctl mb_ct t qid) mb_ty
   | ctl == cConcat || ctl == cConcat' = do
       let (c1,c23) = split c
diff --git a/src/compiler/api/GF/Data/XML.hs b/src/compiler/api/GF/Data/XML.hs
index cd9b18339..a1a8aa4af 100644
--- a/src/compiler/api/GF/Data/XML.hs
+++ b/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
 
diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs
index 189b3c36f..64f8d64ea 100644
--- a/src/compiler/api/GF/Grammar/Grammar.hs
+++ b/src/compiler/api/GF/Grammar/Grammar.hs
@@ -396,7 +396,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 ; ...}@
diff --git a/src/compiler/api/GF/Grammar/JSON.hs b/src/compiler/api/GF/Grammar/JSON.hs
index 0ca49e15f..7cb76054c 100644
--- a/src/compiler/api/GF/Grammar/JSON.hs
+++ b/src/compiler/api/GF/Grammar/JSON.hs
@@ -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,7 +177,7 @@ 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)))
diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs
index 56b755178..ad3adfd5d 100644
--- a/src/compiler/api/GF/Grammar/Macros.hs
+++ b/src/compiler/api/GF/Grammar/Macros.hs
@@ -418,7 +418,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
@@ -466,7 +466,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
 
diff --git a/src/compiler/api/GF/Grammar/Parser.y b/src/compiler/api/GF/Grammar/Parser.y
index b46b17a4f..4bd597592 100644
--- a/src/compiler/api/GF/Grammar/Parser.y
+++ b/src/compiler/api/GF/Grammar/Parser.y
@@ -714,9 +714,11 @@ ERHS3 :: { ERHS }
   | '(' ERHS0 ')'         { $2         }
 
 NLG :: { Map.Map Ident Info }
-  : ListNLGDef             { Map.fromList $1 }
-  | 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)))) }
+  : ListNLGDef            { Map.fromList $1 }
+  | Posn Exp Posn         { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $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 +732,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 }
-  | Exp ';' { $1 }
+  : Posn Tag Posn     { mkL $1 $3 $2 }
+  | Posn Exp Posn ';' { mkL $1 $3 $2 }
 
 Tag :: { Term }
 Tag
@@ -742,12 +744,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 }
 
@@ -889,7 +891,7 @@ 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
 
 }
diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs
index 9a6283e49..88c45095f 100644
--- a/src/compiler/api/GF/Grammar/Printer.hs
+++ b/src/compiler/api/GF/Grammar/Printer.hs
@@ -365,8 +365,8 @@ ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
 ppMarkupAttr q (id,e) =
   id <> pp '=' <> ppTerm q 5 e
 
-ppMarkupChildren q [t]    = ppTerm q 0 t
-ppMarkupChildren q (t:ts) =
+ppMarkupChildren q [L _ t]    = ppTerm q 0 t
+ppMarkupChildren q (L _ t:ts) =
   (case t of
      Markup {} -> ppTerm q 0 t
      _         -> ppTerm q 0 t <> ';') $$
diff --git a/src/compiler/api/GF/Infra/Location.hs b/src/compiler/api/GF/Infra/Location.hs
index 1d9a41ab6..d153d651f 100644
--- a/src/compiler/api/GF/Infra/Location.hs
+++ b/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
 

From 54839a97966736ec500d093cff29466c63268000 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 13 Nov 2025 11:02:40 +0100
Subject: [PATCH 056/144] first draft for Diophantine grammars

---
 src/compiler/api/GF/Command/Importing.hs      |   2 +-
 .../api/GF/Compile/Compute/Concrete2.hs       |   2 +-
 src/compiler/api/GF/Compile/Export.hs         |   1 -
 src/compiler/api/GF/Compile/GeneratePMCFG.hs  | 747 +++++++++++-------
 .../api/GF/Compile/GrammarToCanonical.hs      |  11 +-
 src/compiler/api/GF/Compile/GrammarToPGF.hs   |  50 +-
 .../api/GF/Compile/TypeCheck/Concrete.hs      |   2 +-
 src/compiler/api/GF/Compile/Update.hs         |   8 +-
 src/compiler/api/GF/Compiler.hs               |   5 +-
 src/compiler/api/GF/Grammar/Binary.hs         |  15 +-
 src/compiler/api/GF/Grammar/Grammar.hs        |   9 +-
 src/compiler/api/GF/Grammar/Lookup.hs         |   2 +-
 src/compiler/api/GF/Grammar/Parser.y          |  10 +-
 src/compiler/api/GF/Grammar/Printer.hs        |  47 +-
 src/compiler/api/GF/Infra/Option.hs           |   4 +-
 src/compiler/api/GF/Interactive.hs            |  13 +-
 16 files changed, 528 insertions(+), 400 deletions(-)

diff --git a/src/compiler/api/GF/Command/Importing.hs b/src/compiler/api/GF/Command/Importing.hs
index ec2070605..5944e22f7 100644
--- a/src/compiler/api/GF/Command/Importing.hs
+++ b/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)
diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
index a8dfbaaa4..a4edbeb8f 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
@@ -658,7 +658,7 @@ value2term g xs v = do
 
 data MetaState
   = Bound Scope Value
-  | Narrowing   Type
+  | Narrowing   Choice Type
   | Residuation Scope
 data OptionInfo
   = OptionInfo
diff --git a/src/compiler/api/GF/Compile/Export.hs b/src/compiler/api/GF/Compile/Export.hs
index 1b1b0be4f..f126fb84e 100644
--- a/src/compiler/api/GF/Compile/Export.hs
+++ b/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)
 
diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index 383b11e41..ce6f07029 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -1,316 +1,110 @@
-{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
-----------------------------------------------------------------------
--- |
--- Maintainer  : Krasimir Angelov
--- Stability   : (stable)
--- Portability : (portable)
---
--- Convert PGF grammar to PMCFG grammar.
---
------------------------------------------------------------------------------
-
+{-# LANGUAGE RankNTypes #-}
 module GF.Compile.GeneratePMCFG
     (generatePMCFG, pmcfgForm, type2fields
     ) where
 
-import GF.Grammar hiding (VApp,VRecType)
-import GF.Grammar.Predef
-import GF.Grammar.Lookup
-import GF.Infra.CheckM
+import GF.Infra.Ident
 import GF.Infra.Option
-import GF.Text.Pretty
-import GF.Compile.Compute.Concrete
-import GF.Data.Operations(Err(..))
-import PGF2.Transactions
-import Control.Monad
-import Control.Monad.State
-import Control.Monad.ST
-import qualified Data.Map.Strict as Map
-import qualified Data.Sequence as Seq
-import Data.List(mapAccumL,sortOn,sortBy)
-import Data.Maybe(fromMaybe,isNothing)
-import Data.STRef
+import GF.Infra.CheckM
+import GF.Data.Operations
+import GF.Grammar.Grammar
+import GF.Grammar.Lookup
+import GF.Grammar.Macros
+import GF.Grammar.Predef
+import GF.Grammar.Printer hiding (ppValue)
+import GF.Text.Pretty hiding (empty)
+import GF.Compile.Compute.Concrete2 hiding ( getMeta, setMeta, globals, variants )
+import qualified GF.Text.Pretty as PP
+import qualified Data.Map as Map
+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,intersperse)
+import Prelude hiding ((<>))
+import System.Environment
+
 
 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
-                   return (cm,cmi{jments = js, mseqs=Just (mapToSequence seqs)})
+                       g   = Gl gr' (stdPredef g)
+                   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 opts cwd gr cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) seqs = do
-  (defs,seqs) <-
-          case mdef of
-            Nothing           -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
-                                   term <- mkLinDefault gr ty
-                                   pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs
-            Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
-                                   pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs
-  (refs,seqs) <- 
-          case mref of
-            Nothing           -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
-                                   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
+addPMCFG cwd g cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) = do
+  defs <- case mdef of
+            Nothing        -> checkInModule cwd cmi loc ("Happened in the rule generation for the lindef of" <+> id) $ do
+                                t <- mkLinDefault sgr ty
+                                pmcfgForm g t [(Explicit,identW,Sort cStr)] ty
+            Just (L loc t) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
+                                pmcfgForm g t [(Explicit,identW,Sort cStr)] ty
+  refs <- case mref of
+            Nothing        -> checkInModule cwd cmi loc ("Happened in the rule generation for the linref of" <+> id) $ do
+                                t <- mkLinReference sgr ty
+                                pmcfgForm g t [(Explicit,identW,ty)] (Sort cStr)
+            Just (L loc t) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
+                                pmcfgForm g t [(Explicit,identW,ty)] (Sort cStr)
   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)
-addPMCFG opts cwd gr cmi id (CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) seqs = do
-  (rules,seqs) <-
-           checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $
-             pmcfgForm gr term ctxt val seqs
+  return (CncCat mty mdef mref mprn (Just (defs,refs)))
+  where
+    Gl sgr _ = g
+addPMCFG cwd g cmi id (CncFun (Just lty@(cats,cat,ctxt,ty)) mlin@(Just (L loc term)) mprn Nothing) = do
+  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)
-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)
+  return (CncFun (Just lty) mlin mprn (Just rules))
   where
-    tnk2lparam tnk (_,_,ty) = do
-      v <- force tnk
-      (_,params) <- flatten v ty ([],[])
-      (r,rs,_) <- compute params
-      return (PArg [] (LParam r (order rs)))
+    Gl sgr _ = g
 
-    compute []              = return (0,[],1)
-    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')
+addPMCFG cwd g cmi id info = return info
 
-    mkProduction (vars,args,res,lins) = do
-      lins <- mapM getSeqId lins
-      return (Production vars args res lins)
+pmcfgForm g t ctxt ty = do
+  let (ms,s',t',arg_params) = apply 0 Map.empty unit ctxt t []
+  let v = eval g [] s' t' []
+  (ms,_,_,fn) <- breakDown g ms unit 0 [] v ty (return []) empty
+  runGenM g ms [] $ do
+    (r,rs,v,res_params) <- fn
+    arg_params <- mapM params2int arg_params
+    res_params <- params2int res_params
+    lin_idx    <- params2int' r rs
+    seq        <- flatten v
+    qs <- quantifiers (arg_params++[res_params,lin_idx])
+    return (Rule qs res_params arg_params lin_idx seq)
+  where
+    Gl sgr _ = g
+
+    quantifiers params = GenM (\(Gl sgr _) k svs ms ->
+      k ((Set.toList . Set.fromList)
+            [(variable,boundsOf sgr ms variable) | LParam _ terms <- params, (factor,variable) <- terms])
+        svs ms)
       where
-        getSeqId :: [Symbol] -> State (Map.Map [Symbol] SeqId) SeqId
-        getSeqId lin = state $ \m ->
-          case Map.lookup lin m of
-            Just seqid -> (seqid,m)
-            Nothing    -> let seqid = Map.size m
-                          in (seqid,Map.insert lin seqid m)
+        boundsOf sgr ms i =
+          case Map.lookup (i+1) ms of
+            Just (Narrowing _ pty) -> case allParamValues sgr pty of
+                                        Ok ps   -> length ps
+                                        Bad msg -> error msg
+            _                      -> 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)
-type2metaTerm gr d ms r rs (Sort s) | s == cStr =
-  return (ms,r+1,TSymCat d r rs)
-type2metaTerm gr d ms r rs (RecType lbls) = do
-  ((ms',r'),ass) <- mapAccumM (\(ms,r) (lbl,ty) -> case lbl of
-                                                        LVar j -> return ((ms,r),(lbl,(Just ty,TSymVar d j)))
-                                                        lbl    -> do (ms',r',t) <- type2metaTerm gr d ms r rs ty
-                                                                     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]
-    collectParams (Table _ t) = collectParams t
-    collectParams t           = collectOp collectParams t
+    apply d ms s []              t args = (ms,s,t,reverse args)
+    apply d ms s ((_,_,ty):ctxt) t args =
+       let (ms',s',_,t2,params) = type2metaTerm sgr d ms s 0 [] ty []
+       in apply (d+1) ms' s' ctxt (App t t2) (params:args)
 
-    count = case allParamValues gr p of
-              Ok ts   -> length ts
-              Bad msg -> error msg
-type2metaTerm gr d ms r rs ty@(QC q) = do
-  let i = Map.size ms + 1
-  tnk <- newSTRef (Narrowing i ty)
-  return (Map.insert i tnk ms,r,Meta i)
-type2metaTerm gr d ms r rs ty
-  | Just n <- isTypeInts ty = do
-      let i = Map.size ms + 1
-      tnk <- newSTRef (Narrowing i ty)
-      return (Map.insert i tnk ms,r,Meta i)
-
-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
-deepForce (VApp q tnks)    = mapM_ (\tnk -> force tnk >>= deepForce) tnks
-deepForce (VC v1 v2)       = deepForce v1 >> deepForce v2
-deepForce (VAlts def alts) = do deepForce def
-                                mapM_ (\(v,_) -> deepForce v) alts
-deepForce (VSymCat d r rs) = mapM_ (\(_,(tnk,_)) -> force tnk >>= deepForce) rs
-deepForce _                = return ()
-
-str2lin (VApp q [])
-  | 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',[])
-    compute r' ((cnt',(tnk,ty)):tnks) = do
-      v <- force tnk
-      (r, rs, cnt) <- param2int v ty
-      (r',rs') <- compute r' tnks
-      return (r*cnt'+r',combine cnt' rs rs')
-str2lin (VSymVar d r)    = return [SymVar d r]
-str2lin VEmpty           = return []
-str2lin (VC v1 v2)       = liftM2 (++) (str2lin v1) (str2lin v2)
-str2lin v0@(VAlts def alts)
-                         = do def <- str2lin def
-                              alts <- forM alts $ \(v1,v2) -> do
-                                lin <- str2lin v1
-                                ss  <- to_strs v2
-                                return (lin,ss)
-                              return [SymKP def alts]
-  where
-    to_strs (VStrs vs)    = mapM to_str vs
-    to_strs (VPatt _ _ p) = from_patt p
-    to_strs v             = fail
-
-    to_str (VStr s) = return s
-    to_str _        = fail
-
-    from_patt (PAlt p1 p2) = liftM2 (++) (from_patt p1) (from_patt p2)
-    from_patt (PSeq _ _ p1 _ _ p2) = liftM2 (liftM2 (++)) (from_patt p1) (from_patt p2)
-    from_patt (PString s)  = return [s]
-    from_patt (PChars cs)  = return (map (:[]) cs)
-    from_patt _            = fail
-
-    fail = evalError ("Complex patterns are not supported in:" $$ nest 2 (pp (showValue v0)))
-str2lin v                = do t <- value2term False [] v
-                              evalError ("the string:" <+> ppTerm Unqualified 0 t $$
-                                         "cannot be evaluated at compile time.")
-
-param2int (VR as) (RecType lbls) = compute lbls
-  where
-    compute []              = return (0,[],1)
-    compute ((lbl,ty):lbls) = do
-      case lookup lbl as of
-        Just tnk -> do v <- force tnk
-                       (r, rs ,cnt ) <- param2int v ty
-                       (r',rs',cnt') <- compute lbls
-                       return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
-        Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
-                               "among" <+> hsep (punctuate (pp ',') (map fst as)))
-param2int (VApp q tnks) ty = do
-  (r ,    ctxt,cnt ) <- getIdxCnt q
-  (r',rs',     cnt') <- compute ctxt tnks
-  return (r+r',rs',cnt)
-  where
-    getIdxCnt q = do
-      (_,ResValue (L _ ty) idx) <- getInfo q
-      let (ctxt,QC p) = typeFormCnc ty
-      (_,ResParam _ (Just (_,cnt))) <- getInfo p
-      return (idx,ctxt,cnt)
-
-    compute []              []         = return (0,[],1)
-    compute ((_,_,ty):ctxt) (tnk:tnks) = do
-      v <- force tnk
-      (r, rs ,cnt ) <- param2int v ty
-      (r',rs',cnt') <- compute ctxt tnks
-      return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
-param2int (VInt n)        ty
-  | Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1)
-param2int (VMeta tnk _) ty = do
-  tnk_st <- getRef tnk
-  case tnk_st of
-    Evaluated _ v  -> param2int v ty
-    Narrowing j ty -> do ts <- getAllParamValues ty
-                         return (0,[(1,j-1)],length ts)
-param2int v ty = do t <- value2term True [] v
-                    evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
-                               "cannot be evaluated at compile time.")
-
-combine' 1   rs 1    rs' = []
-combine' 1   rs cnt' rs' = rs'
-combine' cnt rs 1    rs' = rs
-combine' cnt rs cnt' rs' = combine cnt' rs rs'
-
-combine cnt'          []            rs' = rs'
-combine cnt'          rs             [] = [(r*cnt',pv) | (r,pv) <- rs]
-combine cnt' ((r,pv):rs) ((r',pv'):rs') =
-  case compare pv pv' of
-    LT -> (r*cnt',   pv ) : combine cnt' rs ((r',pv'):rs')
-    EQ -> (r*cnt'+r',pv ) : combine cnt' rs ((r',pv'):rs')
-    GT -> (       r',pv') : combine cnt' ((r,pv):rs) rs'
-
-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
+type2fields gr = map show . type2fields PP.empty
   where
     type2fields d (Sort s) | s == cStr = [show d]
     type2fields d (RecType lbls) =
@@ -320,6 +114,7 @@ type2fields gr = type2fields empty
       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
@@ -347,18 +142,388 @@ mkLinReference gr typ = do
   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
+        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
-        _ -> checkError ("a field in a linearization type cannot be" <+> typ)
+        _ -> 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) [(PW,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 allParamValues gr p of
+              Ok ts   -> length ts
+              Bad msg -> error msg
+type2metaTerm gr d ms c r rs ty@(QC q) params =
+  let i = Map.size ms + 1
+      (c1,c2) = split c
+  in (Map.insert i (Narrowing c1 ty) ms,c2,r,Meta i,(VMeta i [],ty):params)
+type2metaTerm gr d ms c r rs ty params
+  | Just n <- isTypeInts ty =
+      let i = Map.size ms + 1
+          (c1,c2) = split c
+      in (Map.insert i (Narrowing c1 ty) ms,c2,r,Meta i,(VMeta i [],ty):params)
+
+
+breakDown g ms s r rs v (Sort sort)    fn0 fn
+  | sort == cStr                              =
+      let fn' = do params <- fn0
+                   v      <- force v
+                   return (r,rs,v,params)
+                <|>
+                do fn
+      in return (ms,r+1,fn0,fn')
+breakDown g ms s r rs v (RecType lbls) fn0 fn = traverse ms r rs lbls fn0 fn
+  where
+    traverse ms r rs []              fn0 fn = return (ms,r,fn0,fn)
+    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
+                                                 traverse ms r rs lbls fn0 fn
+      where
+        project (VR as)       = case lookup lbl as of
+                                  Nothing -> error (render ("Missing value for label" <+> pp lbl $$
+                                                            "in" <+> ppValue Unqualified 0 (VR as)))
+                                  Just v  -> v
+        project (VFV c fvs)   = VFV c (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 v             = VP v lbl []
+breakDown g ms c r rs v (Table p q) fn0 fn = do
+  let i  = Map.size ms + 1
+      v2 = VMeta i []
+      v0 = VS v v2 []
+      (c1,c2) = split c
+      Gl gr _ = g
+  cnt <- fmap length $ allParamValues 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 p 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 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 c q vs) = do
+  vs <- mapM force vs
+  return (VApp c 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 v = compileError ("Cannot evaluate" <+> ppValue Unqualified 0 v)
+
+
+flatten (VStr s) = return [SymKS s]
+flatten (VSymCat d r rs) = do
+  lin_index <- params2int' r rs
+  return [SymCat d lin_index]
+flatten (VApp _ (m,id) [])
+  | m == cPredef && id == cBIND       = return [SymBIND]
+  | m == cPredef && id == cSOFT_BIND  = return [SymSOFT_BIND]
+  | m == cPredef && id == cSOFT_SPACE = return [SymSOFT_SPACE]
+  | m == cPredef && id == cNonExist   = return [SymNE]
+  | m == cPredef && id == cCAPIT      = return [SymCAPIT]
+  | m == cPredef && id == cALL_CAPIT  = return [SymALL_CAPIT]
+flatten v0@(VAlts def alts) = do
+  def <- flatten def
+  alts <- forM alts $ \(alt,ps) -> do
+    alt <- flatten alt
+    ps  <- to_strs ps
+    return (alt,ps)
+  return [SymKP def alts]
+  where
+    to_strs (VStrs vs)    = mapM to_str vs
+    to_strs (VPatt _ _ p) = from_patt p
+    to_strs v             = fail
+
+    to_str (VStr s) = return s
+    to_str _        = fail
+
+    from_patt (PAlt p1 p2) = liftM2 (++) (from_patt p1) (from_patt p2)
+    from_patt (PSeq _ _ p1 _ _ p2) = liftM2 (liftM2 (++)) (from_patt p1) (from_patt p2)
+    from_patt (PString s)  = return [s]
+    from_patt (PChars cs)  = return (map (:[]) cs)
+    from_patt _            = fail
+
+    fail = compileError ("Complex patterns are not supported in:" $$ nest 2 (ppValue Unqualified 0 v0))
+flatten VEmpty     = return []
+flatten (VC v1 v2) = do
+  s1 <- flatten v1
+  s2 <- flatten v2
+  return (s1++s2)
+flatten (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 (apply g (k v) vs)
+flatten (VFV c vs) = do
+  v <- variants c (unvariants vs)
+  flatten v
+flatten v = compileError ("Cannot evaluate" <+> ppValue Unqualified 0 v  <+> "to a string")
+
+
+params2int rs = do
+  (r,rs,_) <- compute rs
+  return (LParam r (order rs))
+  where
+    compute []              = return (0,[],1)
+    compute ((v,ty):params) = do
+      (r, rs, cnt ) <- param2int v ty
+      (r',rs',cnt') <- compute params
+      return (r*cnt'+r',combine cnt' rs rs',cnt*cnt')
+
+params2int' r0 rs = do
+  (r,rs) <- compute rs
+  return (LParam (r0+r) (order rs))
+  where
+    compute []                     = return (0,[])
+    compute ((cnt',(v,ty)):params) = do
+      (r, rs, cnt) <- param2int v ty
+      (r',rs')     <- compute params
+      return (r*cnt'+r',combine cnt' rs rs')
+
+param2int (VR as) (RecType lbls) = compute lbls
+  where
+    compute []              = return (0,[],1)
+    compute ((lbl,ty):lbls) = do
+      case lookup lbl as of
+        Just v   -> do (r, rs ,cnt ) <- param2int v ty
+                       (r',rs',cnt') <- compute lbls
+                       return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
+        Nothing  -> compileError ("Missing value for label" <+> pp lbl $$
+                                  "among" <+> hsep (punctuate (pp ',') (map fst as)))
+param2int (VApp _ q vs) ty = do
+  (r ,    ctxt,cnt ) <- getIdxCnt q
+  (r',rs',     cnt') <- compute ctxt vs
+  return (r+r',rs',cnt)
+  where
+    compute []              []     = return (0,[],1)
+    compute ((_,_,ty):ctxt) (v:vs) = do
+      (r, rs ,cnt ) <- param2int v ty
+      (r',rs',cnt') <- compute ctxt vs
+      return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
+param2int (VInt n) ty
+  | Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1)
+param2int (VMeta i _) ty = do
+  st <- getMeta i
+  case st of
+    Narrowing c ty -> do count <- getCnt ty
+                         return (0,[(1,i-1)],count)
+    Bound _ v      -> param2int v ty
+param2int (VSusp i k vs) ty = 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
+  param2int (apply g (k v) vs) ty
+param2int (VFV c vs) ty = do
+  v <- variants c (unvariants vs)
+  param2int v ty
+param2int 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'
+combine' cnt rs 1    rs' = rs
+combine' cnt rs cnt' rs' = combine cnt' rs rs'
+
+combine cnt'          []            rs' = rs'
+combine cnt'          rs             [] = [(r*cnt',pv) | (r,pv) <- rs]
+combine cnt' ((r,pv):rs) ((r',pv'):rs') =
+  case compare pv pv' of
+    LT -> (r*cnt',   pv ) : combine cnt' 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 allParamValues gr ty of
+    Ok ts   -> k (length ts) 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 poison (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)
diff --git a/src/compiler/api/GF/Compile/GrammarToCanonical.hs b/src/compiler/api/GF/Compile/GrammarToCanonical.hs
index 94dcd0387..c251c933e 100644
--- a/src/compiler/api/GF/Compile/GrammarToCanonical.hs
+++ b/src/compiler/api/GF/Compile/GrammarToCanonical.hs
@@ -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
       }
 
@@ -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))
-    convInfo g ((mn,id), CncFun mb_ty@(Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn mb_prods) = do
+      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 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
diff --git a/src/compiler/api/GF/Compile/GrammarToPGF.hs b/src/compiler/api/GF/Compile/GrammarToPGF.hs
index a0854d297..e5ab011ac 100644
--- a/src/compiler/api/GF/Compile/GrammarToPGF.hs
+++ b/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 id_prod = Production [] [PArg [] (LParam 0 [])] (LParam 0 []) [0]
-                          prods   = ([id_prod],[id_prod])
-                      in [(cInt,   CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
-                         ,(cString,CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
-                         ,(cFloat, CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
+        let infos = ( let z       = LParam 0 []
+                          id_rule = Rule [] z [z] z [SymCat 0 z]
+                          rules   = ([id_rule],[id_rule])
+                      in [((cm,cInt),   CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules))
+                         ,((cm,cString),CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules))
+                         ,((cm,cFloat), CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules))
                          ]
                     )
-                    : prepareSeqTbls (Look.allOrigInfos gr cm)
-        infos <- processInfos createCncCats infos
-        infos <- processInfos createCncFuns infos
-        return ()
+                    ++ Look.allOrigInfos gr cm
+        mapM_ createCncCats infos
+        mapM_ createCncFuns infos
   return pgf
   where
     aflags = err (const noOptions) mflags (lookupModule gr am)
@@ -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 = 
-       (map addSeqTable . Map.toList . Map.fromListWith (++))
-               [(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
+    createCncCats ((_,c),CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do
+      createLincat (i2i c) (type2fields gr ty) lindefs linrefs
       case mprn of
         Nothing        -> return ()
         Just (L _ prn) -> setPrintName (i2i c) (unwords (term2tokens prn))
-      return seqtbl
-    createCncCats seqtbl _ = return seqtbl
+    createCncCats _ = return ()
 
-    createCncFuns seqtbl (f,CncFun _ _ mprn (Just prods)) = do
-      seqtbl <- createLin (i2i f) prods seqtbl
+    createCncFuns ((_,f),CncFun _ _ mprn (Just rules)) = do
+      createLin (i2i f) rules
       case mprn of
         Nothing        -> return ()
         Just (L _ prn) -> setPrintName (i2i f) (unwords (term2tokens prn))
-      return seqtbl
-    createCncFuns seqtbl _ = return seqtbl
+    createCncFuns _ = return ()
 
     term2tokens (K tok)     = [tok]
     term2tokens (C t1 t2)   = term2tokens t1 ++ term2tokens t2
diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index d85972e95..1819e34e6 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -1063,7 +1063,7 @@ subsCheckRho scope t ty1@(VRecType rs1 ext1) ty2@(VRecType rs2 ext2) = do      -
   (scope,mkProj,wrap) <- mkAccess scope t
 
   let fields = [(l,o2,ty2,lookup3 l rs1) | (l,o2,ty2) <- rs2]
-  case [l | (l,_,_,Nothing) <- fields, not ext1 && not (isLockLabel l)] of
+  case [l | (l,_,_,Nothing) <- fields, not ext1] of
     []      -> return ()
     missing -> evalError ("In the term" <+> pp t $$
                           "there are no values for fields:" <+> hsep missing)
diff --git a/src/compiler/api/GF/Compile/Update.hs b/src/compiler/api/GF/Compile/Update.hs
index 67688f279..9355c3bf2 100644
--- a/src/compiler/api/GF/Compile/Update.hs
+++ b/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')
 
@@ -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)
 
diff --git a/src/compiler/api/GF/Compiler.hs b/src/compiler/api/GF/Compiler.hs
index d046063c8..b352d586e 100644
--- a/src/compiler/api/GF/Compiler.hs
+++ b/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
diff --git a/src/compiler/api/GF/Grammar/Binary.hs b/src/compiler/api/GF/Grammar/Binary.hs
index 1c1960076..128b652f1 100644
--- a/src/compiler/api/GF/Grammar/Binary.hs
+++ b/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)
-  get    = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get
-              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments)
+  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,jments) <- get
+              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc jments)
 
 instance Binary ModuleType where
   put MTAbstract       = putWord8 0
@@ -100,9 +99,9 @@ instance Binary PArg where
   put (PArg x y) = put (x,y)
   get = get >>= \(x,y) -> return (PArg x y)
 
-instance Binary Production where
-  put (Production ps args res rules) = put (ps,args,res,rules)
-  get = get >>= \(ps,args,res,rules) -> return (Production ps args res rules)
+instance Binary Rule where
+  put (Rule v w x y z) = put (v,w,x,y,z)
+  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
@@ -369,7 +368,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)
diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs
index 1a4f2ed3a..2cfaeca58 100644
--- a/src/compiler/api/GF/Grammar/Grammar.hs
+++ b/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,7 +75,7 @@ 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.Array.IArray(Array)
 import Data.Array.Unboxed(UArray)
@@ -103,7 +103,6 @@ data ModuleInfo
     mopens  :: [OpenSpec],
     mexdeps :: [ModuleName],
     msrc    :: FilePath,
-    mseqs   :: Maybe (Seq.Seq [Symbol]),
     jments  :: Map.Map Ident Info
    }
  | ModPGF {
@@ -336,8 +335,8 @@ 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, 
- | CncFun  (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term))                  (Maybe (L Term)) (Maybe [Production]) -- ^ (/CNC/) type info added at 'TC'
+ | 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 [Rule]) -- ^ (/CNC/) type info added at 'TC'
 
 -- indirection to module Ident
  | AnyInd Bool ModuleName                        -- ^ (/INDIR/) the 'Bool' says if canonical
diff --git a/src/compiler/api/GF/Grammar/Lookup.hs b/src/compiler/api/GF/Grammar/Lookup.hs
index 30d581c72..b756a2abb 100644
--- a/src/compiler/api/GF/Grammar/Lookup.hs
+++ b/src/compiler/api/GF/Grammar/Lookup.hs
@@ -110,7 +110,7 @@ lookupResDef gr (m,c)
         ResOper _ (Just (L _ t)) -> return t
         ResOper _ Nothing  -> return (Q (m,c))
         CncCat (Just (L _ ty)) _ _ _ _ -> lock c ty
-        CncCat _ _ _ _ _         -> lock c defLinType
+        CncCat _ _ _ _ _        -> lock c defLinType
 
         CncFun (Just (_,cat,_,_)) (Just (L _ tr)) _ _ -> unlock cat tr
         CncFun _                  (Just (L _ tr)) _ _ -> return tr
diff --git a/src/compiler/api/GF/Grammar/Parser.y b/src/compiler/api/GF/Grammar/Parser.y
index b46b17a4f..ddd493682 100644
--- a/src/compiler/api/GF/Grammar/Parser.y
+++ b/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 
@@ -481,7 +481,7 @@ Exp6 :: { Term }
 Exp6 
   : Ident                 { Vr $1 } 
   | Sort                  { Sort $1 }
-  | String                { K $1 }
+  | String                { words2term (words $1) }
   | Integer               { EInt $1 }
   | Double                { EFloat $1 }
   | '?'                   { Meta 0 }
@@ -892,4 +892,8 @@ mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) x
 mkMarkup [t] = t
 mkMarkup ts  = Markup identW [] ts
 
+words2term []     = Empty
+words2term [w]    = K w
+words2term (w:ws) = C (K w) (words2term ws)
+
 }
diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs
index 9a6283e49..cc84c1a97 100644
--- a/src/compiler/api/GF/Grammar/Printer.hs
+++ b/src/compiler/api/GF/Grammar/Printer.hs
@@ -21,12 +21,12 @@ module GF.Grammar.Printer
            , 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
@@ -49,11 +49,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)) $$
-            maybe empty (ppSequences q) mseqs) $$
+            vcat (map (ppJudgement q) (Map.toList jments))) $$
     ftr
     where
       hdr = complModDoc <+> modTypeDoc <+> '=' <+>
@@ -142,9 +141,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" <+> '{' $$
-                       nest 2 (vcat (map (ppPmcfgRule (identS "lindef") [cString] id) lindefs)  $$
-                               vcat (map (ppPmcfgRule (identS "linref") [id] cString) linrefs)) $$
+                    -> "rules" <+> '{' $$
+                       nest 2 (vcat (map (ppPmcfgRule (identS "lindef") [cString] id) lindefs)) $$
+                       nest 2 (vcat (map (ppPmcfgRule (identS "linref") [id] cString) linrefs)) $$
                        '}'
      _              -> empty)
 ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) =
@@ -157,7 +156,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 +165,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 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)
@@ -372,18 +373,6 @@ ppMarkupChildren q (t:ts) =
      _         -> 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
diff --git a/src/compiler/api/GF/Infra/Option.hs b/src/compiler/api/GF/Infra/Option.hs
index 0f902f723..992c9596d 100644
--- a/src/compiler/api/GF/Infra/Option.hs
+++ b/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"),
-     (("lr",           FmtLR),"LR(0) automaton for PMCFG in graphviz format")
+     (("fa",           FmtFA),"finite automaton in graphviz format")
      ]
 
 instance Show OutputFormat where
diff --git a/src/compiler/api/GF/Interactive.hs b/src/compiler/api/GF/Interactive.hs
index 895229d94..802c914e5 100644
--- a/src/compiler/api/GF/Interactive.hs
+++ b/src/compiler/api/GF/Interactive.hs
@@ -301,9 +301,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
@@ -327,10 +327,9 @@ transactionCommand (CreateLin opts f mb_t is_alter) pgf mb_txnid = do
                                              return (t,ty)
                                Bad msg -> fail msg
       let (ctxt,res_ty) = typeFormCnc ty
-      (prods,seqs) <- pmcfgForm sgr t ctxt res_ty Map.empty
-      return (prods,mapToSequence seqs,type2fields sgr res_ty)
-      where
-        mapToSequence m = Seq.fromList (map (Left . fst) (sortOn snd (Map.toList m)))
+      let g = Gl sgr (stdPredef g)
+      rules <- pmcfgForm g t ctxt res_ty
+      return (rules,type2fields sgr res_ty)
 
 transactionCommand (CreateLincat opts c mb_t) pgf mb_txnid = do
   sgr <- getGrammar
@@ -339,7 +338,7 @@ 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

From cb6bace896ba8d6a57198e0cfa395f1c62191ee6 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 13 Nov 2025 11:17:16 +0100
Subject: [PATCH 057/144] Diophantine grammars in the runtime

---
 src/runtime/c/pgf/data.cxx                |   55 +-
 src/runtime/c/pgf/data.h                  |  173 +-
 src/runtime/c/pgf/linearizer.cxx          |  383 ++-
 src/runtime/c/pgf/linearizer.h            |   65 +-
 src/runtime/c/pgf/parser.cxx              | 3486 ++++++++-------------
 src/runtime/c/pgf/parser.h                |  433 ++-
 src/runtime/c/pgf/pgf.cxx                 |  576 ++--
 src/runtime/c/pgf/pgf.h                   |   61 +-
 src/runtime/c/pgf/phrasetable.cxx         |  906 +++---
 src/runtime/c/pgf/phrasetable.h           |  204 +-
 src/runtime/c/pgf/printer.cxx             |   92 +-
 src/runtime/c/pgf/printer.h               |    4 +-
 src/runtime/c/pgf/reader.cxx              |  124 +-
 src/runtime/c/pgf/reader.h                |   13 +-
 src/runtime/c/pgf/writer.cxx              |   73 +-
 src/runtime/c/pgf/writer.h                |   12 +-
 src/runtime/haskell/PGF2.hsc              |   54 +-
 src/runtime/haskell/PGF2/FFI.hsc          |   19 +-
 src/runtime/haskell/PGF2/Transactions.hsc |   72 +-
 19 files changed, 3003 insertions(+), 3802 deletions(-)

diff --git a/src/runtime/c/pgf/data.cxx b/src/runtime/c/pgf/data.cxx
index 982db8de2..0799b8a32 100644
--- a/src/runtime/c/pgf/data.cxx
+++ b/src/runtime/c/pgf/data.cxx
@@ -40,7 +40,6 @@ 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);
     PgfDB::free(concr, concr->name.size+1);
 }
@@ -52,17 +51,10 @@ void PgfConcrLincat::release(ref<PgfConcrLincat> lincat)
     }
     vector<ref<PgfText>>::release(lincat->fields);
 
-	for (size_t i = 0; i < lincat->args.size(); i++) {
-        PgfLParam::release(lincat->args[i].param);
+    for (ref<PgfConcrRule> rule : lincat->rules) {
+        PgfConcrRule::release(rule);
     }
-    vector<PgfPArg>::release(lincat->args);
-
-    for (ref<PgfPResult> res : lincat->res) {
-        PgfPResult::release(res);
-    }
-    vector<ref<PgfPResult>>::release(lincat->res);
-
-    vector<ref<PgfSequence>>::release(lincat->seqs);
+    vector<ref<PgfConcrRule>>::release(lincat->rules);
 
     PgfDB::free(lincat, lincat->name.size+1);
 }
@@ -79,9 +71,9 @@ void PgfPResult::release(ref<PgfPResult> res)
     PgfDB::free(res, res->param.n_terms*sizeof(res->param.terms[0]));
 }
 
-void PgfSequence::release(ref<PgfSequence> seq)
+static void symbols_release(vector<PgfSymbol> syms)
 {
-	for (PgfSymbol sym : seq->syms) {
+	for (PgfSymbol sym : syms) {
         switch (ref<PgfSymbol>::get_tag(sym)) {
         case PgfSymbolCat::tag: {
             auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
@@ -103,9 +95,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 +118,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<PgfVariableRange>::release(rule->vars);
+
+    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++) {
-        PgfLParam::release(lin->args[i].param);
+    for (ref<PgfConcrRule> rule : lin->rules) {
+        PgfConcrRule::release(rule);
     }
-    vector<PgfPArg>::release(lin->args);
-
-    for (ref<PgfPResult> res : lin->res) {
-        PgfPResult::release(res);
-    }
-    vector<ref<PgfPResult>>::release(lin->res);
-
-    vector<ref<PgfSequence>>::release(lin->seqs);
+    vector<ref<PgfConcrRule>>::release(lin->rules);
 
     PgfDB::free(lin, lin->name.size+1);
 }
diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h
index 99ee8a427..a96e45eaf 100644
--- a/src/runtime/c/pgf/data.h
+++ b/src/runtime/c/pgf/data.h
@@ -87,7 +87,6 @@ struct PgfConcr;
 #include "text.h"
 #include "vector.h"
 #include "namespace.h"
-#include "phrasetable.h"
 #include "probspace.h"
 #include "expr.h"
 
@@ -155,12 +154,6 @@ struct PGF_INTERNAL_DECL PgfPResult {
 
 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 +182,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 +192,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 +220,24 @@ struct PGF_INTERNAL_DECL PgfSymbolALLCAPIT {
     static const uint8_t tag = 10;
 };
 
+struct PGF_INTERNAL_DECL PgfConcrRule {
+    vector<PgfVariableRange> vars;
+    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<PgfPResult>> res;
-    vector<ref<PgfSequence>> seqs;
+    vector<ref<PgfConcrRule>> rules;
     vector<ref<PgfText>> fields;
 
     PgfText name;
@@ -249,15 +251,25 @@ struct PGF_INTERNAL_DECL PgfConcrLin {
     ref<PgfAbsFun> absfun;
     ref<PgfConcrLincat> lincat;
 
-    vector<PgfPArg> args;
-    vector<ref<PgfPResult>> res;
-    vector<ref<PgfSequence>> seqs;
+    vector<ref<PgfConcrRule>> rules;
 
     PgfText name;
 
     static void release(ref<PgfConcrLin> lin);
 };
 
+struct PGF_INTERNAL_DECL PgfSymbolACat {
+    static const uint8_t tag = 11;
+    PgfText name;
+};
+
+struct PGF_INTERNAL_DECL PgfSymbolCCat {
+    static const uint8_t tag = 12;
+    ref<PgfConcrLincat> lincat;
+    size_t value;
+    size_t lin_idx;
+};
+
 struct PGF_INTERNAL_DECL PgfConcrPrintname {
     ref<PgfText> printname;
     PgfText name;
@@ -267,134 +279,7 @@ struct PGF_INTERNAL_DECL PgfConcrPrintname {
 
 #define containerof(T,field,p) (T*) (((char*) p)-offsetof(T,field))
 
-struct PGF_INTERNAL_DECL PgfLCEdge {
-    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;
-};
+#include "phrasetable.h"
 
 struct PGF_INTERNAL_DECL PgfConcr {
     Namespace<PgfFlag> cflags;
@@ -403,8 +288,6 @@ struct PGF_INTERNAL_DECL PgfConcr {
     PgfPhrasetable phrasetable;
     Namespace<PgfConcrPrintname> printnames;
 
-    vector<PgfLRState> lrtable;
-
     PgfText name;
 
     static void release(ref<PgfConcr> pgf);
diff --git a/src/runtime/c/pgf/linearizer.cxx b/src/runtime/c/pgf/linearizer.cxx
index 8591bc718..ee02d237f 100644
--- a/src/runtime/c/pgf/linearizer.cxx
+++ b/src/runtime/c/pgf/linearizer.cxx
@@ -2,6 +2,59 @@
 #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];
+        for (size_t k = 0; k < vars.size(); k++) {
+            if (rule->vars[k].var == t.var) {
+                if (vars[k] > 0) {
+                    if (value < vars[k]-1)
+                        return false;
+                    value -= vars[k]-1;
+                }
+                break;
+            }
+        }
+    }
+
+    for (size_t j = 0; j < lparam->n_terms; j++) {
+        term t = lparam->terms[j];
+        for (size_t k = 0; k < vars.size(); k++) {
+            if (rule->vars[k].var == t.var) {
+                if (vars[k] == 0) {
+                    size_t v_val = value / t.factor;
+                    if (v_val >= rule->vars[k].range)
+                        return false;
+                    vars[k] = v_val + 1;
+                    value %= t.factor;
+                }
+                break;
+            }
+        }
+    }
+
+    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++) {
+        for (size_t j = 0; j < rule->vars.size(); j++) {
+            if (lparam->terms[i].var == rule->vars[j].var) {
+                value += lparam->terms[i].factor * (vars[j]-1);
+                break;
+            }
+        }
+    }
+    return value;
+}
+
 PgfLinearizer::TreeNode::TreeNode(PgfLinearizer *linearizer)
 {
     this->next     = linearizer->prev;
@@ -11,8 +64,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,7 +71,7 @@ PgfLinearizer::TreeNode::TreeNode(PgfLinearizer *linearizer)
     linearizer->prev = this;
 }
 
-void PgfLinearizer::TreeNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r)
+void PgfLinearizer::TreeNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r)
 {
     TreeNode *arg = args;
     while (d > 0) {
@@ -31,8 +82,7 @@ void PgfLinearizer::TreeNode::linearize_arg(PgfLinearizationOutputIface *out, Pg
     }
     if (arg == 0)
         throw pgf_error("Missing argument");
-    size_t lindex = eval_param(r);
-    arg->linearize(out, linearizer, lindex);
+    arg->linearize(out, linearizer, r);
 }
 
 void PgfLinearizer::TreeNode::linearize_var(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r)
@@ -52,20 +102,22 @@ 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)
+void PgfLinearizer::TreeNode::linearize_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item)
 {
-    for (size_t i = 0; i < seq->syms.size(); i++) {
-        PgfSymbol sym = seq->syms[i];
+    for (size_t i = 0; i < item->rule->syms.size(); i++) {
+        PgfSymbol sym = item->rule->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));
+            linearize_arg(out, linearizer, sym_cat->d, r);
             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));
+            linearize_arg(out, linearizer, sym_lit->d, r);
             break;
         }
         case PgfSymbolVar::tag: {
@@ -169,113 +221,68 @@ void PgfLinearizer::TreeNode::linearize_seq(PgfLinearizationOutputIface *out, Pg
     }
 }
 
-size_t PgfLinearizer::TreeNode::eval_param(PgfLParam *param)
-{
-    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_index = 0;
+    this->lin        = lin;
+    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;
-    size_t n_args = lin->args.size() / lin->res.size();
 
-    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;
-        }
+    while (rule_index < lin->rules.size()) {
+        Item *item = new (lin->rules[rule_index]) Item();
 
         int i = 0;
         TreeNode *arg = args;
         while (arg != NULL) {
-            ref<PgfPArg> parg = lin->args.elem(offset+i);
             arg->check_category(linearizer, &hypos[i].type->name);
 
-            if (arg->value < parg->param->i0)
+            if (!item->instantiate(item->rule->args[i], arg->value))
                 break;
 
-            size_t value = arg->value - parg->param->i0;
-            for (size_t j = 0; j < parg->param->n_terms; j++) {
-                size_t factor    = parg->param->terms[j].factor;
-                size_t var       = parg->param->terms[j].var;
-                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;
-            }
-
-            if (value != 0)
-                break;
-
-            arg = arg->next_arg;
-            i++;
+            arg = arg->next_arg;  i++;
         }
 
-        lin_index++;
+        size_t max_value = 1;
+        for (size_t i = 0; i < item->vars.size(); i++) {
+            if (item->vars[i] == 0)
+                max_value *= item->rule->vars[i].range;
+        }
 
-        if (arg == NULL) {
-            value = eval_param(&pres->param);
-            return true;
+        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->vars[i].range;
+                    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++;
+    }
+
+    for (size_t i = 0; i < lin->lincat->fields.size(); i++) {
+        if (items[i] == NULL) {
+            rule_index = 0;
+            return false;
         }
     }
 
-    lin_index = 0;
-    return false;
+    return true;
 }
 
 void PgfLinearizer::TreeLinNode::check_category(PgfLinearizer *linearizer, PgfText *cat)
@@ -302,9 +309,7 @@ void PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, Pgf
         linearizer->pre_stack->bracket_stack = bracket;
     }
 
-    size_t n_seqs = lin->seqs.size() / lin->res.size();
-    ref<PgfSequence> seq = lin->seqs[(lin_index-1)*n_seqs + lindex];
-    linearize_seq(out, linearizer, seq);
+    linearize_item(out, linearizer, items[lindex]);
 
     if (linearizer->pre_stack == NULL)
         out->end_phrase(cat, fid, field, &lin->name);
@@ -325,11 +330,21 @@ 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++) {
+        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,17 +370,46 @@ PgfLinearizer::TreeLindefNode::TreeLindefNode(PgfLinearizer *linearizer, PgfText
 
 bool PgfLinearizer::TreeLindefNode::resolve(PgfLinearizer *linearizer)
 {
-    if (lincat == 0) {
-        return (lin_index = !lin_index);
-    } else {
-        ref<PgfPResult> pres = lincat->res[lin_index];
-        value = eval_param(&pres->param);
-        lin_index++;
-        if (lin_index <= lincat->n_lindefs)
-            return true;
-        lin_index = 0;
-        return false;
+/*    while (rule_index < lincat->n_lindefs2) {
+        ref<PgfConcrRule> rule = lincat->rules[rule_index];
+        Item *item = new (rule) Item();
+
+        size_t max_value = 1;
+        for (size_t i = 0; i < item->vars.size(); i++) {
+            if (item->vars[i] == 0)
+                max_value *= item->rule->vars[i].range;
+        }
+
+        for (size_t value = 0; value < max_value; value++) {
+            size_t v = value;
+            for (size_t i = 0; i < item->vars.size(); i++) {
+                if (item->vars[i] == 0) {
+                    size_t range = item->rule->vars[i].range;
+                    item->vars[i] = v % range;
+                    v = v / range;
+                }
+            }
+
+            Item *new_item = new (item) Item;
+
+            size_t lin_idx = item->eval(new_item->rule->lin_idx);
+            items[lin_idx] = new_item;
+
+            this->value = item->eval(new_item->rule->res);
+        }
+        delete item;
+
+        rule_index++;
     }
+
+    for (size_t i = 0; i < lincat->fields.size(); i++) {
+        if (items[i] == NULL) {
+            rule_index = 0;
+            return false;
+        }
+    }
+*/
+    return true;
 }
 
 void PgfLinearizer::TreeLindefNode::check_category(PgfLinearizer *linearizer, PgfText *cat)
@@ -373,6 +417,7 @@ void PgfLinearizer::TreeLindefNode::check_category(PgfLinearizer *linearizer, Pg
     lincat = namespace_lookup(linearizer->concr->lincats, cat);
     if (lincat == 0)
         throw pgf_error("Cannot find a lincat for a category");
+    this->items = new Item*[lincat->fields.size()]();
 }
 
 void PgfLinearizer::TreeLindefNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r)
@@ -389,7 +434,7 @@ void PgfLinearizer::TreeLindefNode::linearize_arg(PgfLinearizationOutputIface *o
 
 void PgfLinearizer::TreeLindefNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
 {
-    if (lincat != 0) {
+/*    if (lincat != 0) {
         PgfText *field = &*lincat->fields[lindex];
         if (linearizer->pre_stack == NULL)
             out->begin_phrase(&lincat->name, fid, field, fun);
@@ -404,8 +449,8 @@ void PgfLinearizer::TreeLindefNode::linearize(PgfLinearizationOutputIface *out,
             linearizer->pre_stack->bracket_stack = bracket;
         }
 
-        ref<PgfSequence> seq = lincat->seqs[(lin_index-1)*lincat->fields.size() + lindex];
-        linearize_seq(out, linearizer, seq);
+        ref<PgfSequence> seq = lincat->seqs[(rule_index-1)*lincat->fields.size() + lindex];
+//        linearize_seq(out, linearizer, seq);
 
         if (linearizer->pre_stack == NULL)
             out->end_phrase(&lincat->name, fid, field, fun);
@@ -421,7 +466,7 @@ void PgfLinearizer::TreeLindefNode::linearize(PgfLinearizationOutputIface *out,
         }
     } else {
         linearize_arg(out, linearizer, 0, NULL);
-    }
+    }*/
 }
 
 ref<PgfConcrLincat> PgfLinearizer::TreeLindefNode::get_lincat(PgfLinearizer *linearizer)
@@ -429,11 +474,26 @@ ref<PgfConcrLincat> PgfLinearizer::TreeLindefNode::get_lincat(PgfLinearizer *lin
     return lincat;
 }
 
+PgfLinearizer::TreeLindefNode::~TreeLindefNode()
+{
+    if (lincat) {
+        size_t n_fields = lincat->fields.size();
+        for (size_t i = 0; i < n_fields; i++) {
+            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,81 +501,53 @@ 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()) {
-        // Unbind all variables
-        for (size_t j = 0; j < var_count; j++) {
-            var_values[j] = (size_t) -1;
+    while (rule_index < lincat->rules.size()) {
+        Item *item = new (lincat->rules[lincat->n_lindefs+rule_index]) Item();
+
+        if (!item->instantiate(item->rule->args[0], root->value)) {
+            rule_index++;
+            continue;
         }
 
-        ref<PgfPResult> pres = lincat->res[lincat->n_lindefs+lin_index];
-        ref<PgfPArg> parg = lincat->args.elem(lincat->n_lindefs+lin_index);
+        size_t max_value = 1;
+        for (size_t i = 0; i < item->vars.size(); i++) {
+            if (item->vars[i] == 0)
+                max_value *= item->rule->vars[i].range;
+        }
 
-        if (root->value < parg->param->i0)
-            break;
-
-        size_t value = root->value - parg->param->i0;
-        for (size_t j = 0; j < parg->param->n_terms; j++) {
-            size_t factor    = parg->param->terms[j].factor;
-            size_t var       = parg->param->terms[j].var;
-            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;
-                    }
+        for (size_t value = 0; value < max_value; value++) {
+            size_t v = value;
+            for (size_t i = 0; i < item->vars.size(); i++) {
+                if (item->vars[i] == 0) {
+                    size_t range = item->rule->vars[i].range;
+                    item->vars[i] = v % range;
+                    v = v / range;
                 }
-                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++;
-        if (value == 0) {
-            value = eval_param(&pres->param);
-            return true;
-        }
+        break;
     }
 
-    lin_index = 0;
-    return false;
+    if (item == NULL) {
+        rule_index = 0;
+        return false;
+    }
+
+    return true;
 }
 
 void 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);
-        ref<PgfSequence> seq = lincat->seqs[i];
-        linearize_seq(out, linearizer, seq);
+        linearize_item(out, linearizer, item);
     } else {
         args->linearize(out, linearizer, lindex);
     }
@@ -526,6 +558,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)
 {
@@ -663,14 +700,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_seq(out, this, alt->form);
                         goto done;
                     }
                 }
             }
         }
 
-        pre->node->linearize_seq(out, this, pre->sym_kp->default_form);
+//        pre->node->linearize_seq(out, this, pre->sym_kp->default_form);
 
     done:
         if (pre->bracket_stack != NULL)
diff --git a/src/runtime/c/pgf/linearizer.h b/src/runtime/c/pgf/linearizer.h
index f72224f0d..af54030ef 100644
--- a/src/runtime/c/pgf/linearizer.h
+++ b/src/runtime/c/pgf/linearizer.h
@@ -26,6 +26,49 @@ 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->vars.size();
+            }
+        } vars;
+
+        void *operator new(size_t sz, ref<PgfConcrRule> rule)
+        {
+            size_t sz2 = rule->vars.size()*sizeof(size_t);
+            Item *new_item = (Item *) malloc(sz+sz2);
+            memset(new_item, 0, sz+sz2);
+            new_item->rule = rule;
+            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,8 +77,6 @@ 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;
@@ -43,29 +84,31 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
         TreeNode(PgfLinearizer *linearizer);
         virtual bool resolve(PgfLinearizer *linearizer) { return true; };
         virtual void check_category(PgfLinearizer *linearizer, PgfText *cat)=0;
-        virtual void linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r);
+        virtual void 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 void linearize_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item);
         virtual void 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 void 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;
 
@@ -75,17 +118,19 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
         virtual void linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r);
         virtual void 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 void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
+        ~TreeLinrefNode();
     };
 
     struct TreeLitNode : public TreeNode {
diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index 261d53b3d..894d69e25 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -1,2362 +1,1480 @@
 #include "data.h"
 #include "printer.h"
 #include "parser.h"
-#include <algorithm>
 
-//#define DEBUG_STATE_CREATION
-//#define DEBUG_AUTOMATON
-//#define DEBUG_PARSER
-//#define DEBUG_GENERATOR
+// #define DEBUG_PARSER
+// #define DEBUG_EXPRS
 
-struct PgfLRTableMaker::CCat {
-    CCat *parent;
-    size_t lin_idx;
-    ref<PgfConcrLincat> lincat;
+PgfAbstractParser::PgfAbstractParser(ref<PgfConcr> concr)
+{
+    this->concr = concr;
 
-    size_t id;
-    bool productive;                 // true if it has non epsilon rules
-    std::vector<Item*> items;        // productive items
-	std::vector<Item*> suspended;    // items that can progress on epsilon
-    std::vector<Production*> prods;  // epsilon productions
-
-    ref<PgfLRReduceArg> persistant;
-
-    CCat(size_t id, CCat *parent, size_t lin_idx) {
-        this->parent     = parent;
-        this->lin_idx    = lin_idx;
-        this->lincat     = (parent != NULL) ? parent->lincat : 0;
-        this->id         = id;
-        this->productive = false;
-        this->persistant = 0;
-    }
-
-    ref<PgfLRReduceArg> persist();
-
-    void suspend_item(Item *item);
-    void register_item(Item *item);
-
-    ~CCat();
-};
-
-#define container(T,field,p) ((T*) (((char*) p) - offsetof(T, field)))
-
-struct PgfLRTableMaker::Production {
-    ref<PgfConcrLin> lin;
-    size_t index;
-
-    struct {
-        // After the Production there is an array of arguments
-        size_t count;
-        CCat *&operator [](int i) {
-            return ((CCat **) (container(Production,args,this)+1))[i];
-        }
-    } args;
-
-    struct {
-        // After the array of arguments there is an array of variables
-        size_t count;
-        size_t &operator [](int i) {
-            Production *prod = container(Production,vals,this);
-            return ((size_t *) (((CCat**) (prod+1)) + prod->args.count))[i];
-        }
-    } vals;
-
-    void *operator new(size_t size, Item *item);
-
-    Production() {
-        // If there is no constructor, GCC will zero the object,
-        // while it has already been initialized in the new operator.
-    }
-
-    void operator delete(void *p) {
-        free(p);
-    }
-};
-
-struct PgfLRTableMaker::Item {
-    size_t ref_cnt;   // how many CCat:s contain the item?
-    CCat* ccat;
-    object lin_obj;
-    ref<PgfSequence> seq;
-    size_t seq_idx;
-    size_t sym_idx;
-    size_t stk_size;
-
-    struct Arg {
-        CCat *ccat;
-        size_t stk_idx;
-    };
-
-    struct {
-        // After the Item there is an array of arguments
-        size_t count;
-        Arg &operator [](int i) const {
-            return ((Arg*) (container(Item,args,this)+1))[i];
-        }
-    } args;
-
-    struct {
-        // After the array of arguments there is an array of variables
-        size_t count;
-        size_t &operator [](int i) const {
-            Item *item = container(Item,vals,this);
-            return ((size_t *) (((Arg*) (item+1)) + item->args.count))[i];
-        }
-    } vals;
-
-    void *operator new(size_t size, CCat* ccat, ref<PgfConcrLin> lin, size_t seq_idx);
-    void *operator new(size_t size, ref<PgfConcrLincat> lincat, size_t index);
-    void *operator new(size_t size, CCat* ccat, Production *prod, size_t lin_idx);
-    void *operator new(size_t size, Item *item, CCat *ccat);
-    void *operator new(size_t size, Item *item, size_t lin_idx);
-    void *operator new(size_t size, Item *item);
-
-    Item() {
-        // If there is no constructor, GCC will zero the object,
-        // while it has already been initialized in the new operator.
-    }
-
-    void operator delete(void *p) {
-        if (((Item *) p)->ref_cnt == 0)
-            free(p);
-    }
-};
-
-struct PgfLRTableMaker::CompareItem : std::less<Item*> {
-    bool operator() (const Item *item1, const Item *item2) const {
-        if (item1->lin_obj < item2->lin_obj)
-            return true;
-        else if (item1->lin_obj > item2->lin_obj)
-            return false;
-
-        if (item1->seq_idx < item2->seq_idx)
-            return true;
-        else if (item1->seq_idx > item2->seq_idx)
-            return false;
-
-        if (item1->sym_idx < item2->sym_idx)
-            return true;
-        else if (item1->sym_idx > item2->sym_idx)
-            return false;
-
-        for (size_t i = 0; i < item1->args.count; i++) {
-            if (item1->args[i].ccat < item2->args[i].ccat)
-                return true;
-            else if (item1->args[i].ccat > item2->args[i].ccat)
-                return false;
-            if (item1->args[i].stk_idx < item2->args[i].stk_idx)
-                return true;
-            else if (item1->args[i].stk_idx > item2->args[i].stk_idx)
-                return false;
-        }
-
-        return false;
-    }
-};
-
-const PgfLRTableMaker::CompareItem PgfLRTableMaker::compare_item;
-
-ref<PgfLRReduceArg> PgfLRTableMaker::CCat::persist() {
-    if (persistant != 0)
-        return persistant;
-
-    size_t n_prods = prods.size();
-    persistant = PgfDB::malloc<PgfLRReduceArg>(n_prods*sizeof(PgfLRReduce));
-    persistant->n_prods = n_prods;
-    for (size_t i = 0; i < n_prods; i++) {
-        Production *prod = prods[i];
-        persistant->prods[i].lin   = prod->lin;
-        persistant->prods[i].index = prod->index;
-        auto children = vector<ref<PgfLRReduceArg>>::alloc(prod->args.count);
-        for (size_t j = 0; j < prod->args.count; j++) {
-            if (prod->args[j] == NULL) {
-                children[j] = 0;
-            } else {
-                ref<PgfLRReduceArg> child_arg = prod->args[j]->persist();
-                children[j] = child_arg;
-            }
-        }
-        persistant->prods[i].args = children;
-    }
-
-    return persistant;
+    this->first_state = NULL;
+    this->current_state = NULL;
+    this->last_fid = 0;
 }
 
-void PgfLRTableMaker::CCat::suspend_item(Item *item) {
-    suspended.push_back(item);
-    if (item != NULL)
-        item->ref_cnt++;
-}
-
-void PgfLRTableMaker::CCat::register_item(Item *item) {
-    items.push_back(item); item->ref_cnt++;
-}
-
-PgfLRTableMaker::CCat::~CCat() {
-    for (Item *item : items) {
-        item->ref_cnt--;
-        delete item;
-    }
-    for (Item *item : suspended) {
-        item->ref_cnt--;
-        delete item;
-    }
+PgfAbstractParser::CCat::~CCat()
+{
     for (Production *prod : prods) {
         delete prod;
     }
+    for (ExprState *estate : pending) {
+        delete estate;
+    }
 }
 
-void *PgfLRTableMaker::Production::operator new(size_t size, Item *item) {
-    ref<PgfConcrLin> lin = ref<PgfConcrLin>::untagged(item->lin_obj);
-
-    size_t n_fields = lin->seqs.size() / lin->res.size();
-    size_t ex_size = sizeof(CCat*)*item->args.count+sizeof(size_t)*item->vals.count;
-
-    Production *prod = (Production *) malloc(size+ex_size);
-    prod->lin = lin;
-    prod->index = item->seq_idx / n_fields;
-    prod->args.count = item->args.count;
-    prod->vals.count = item->vals.count;
-
-    for (size_t i = 0; i < item->args.count; i++) {
-        prod->args[i] = item->args[i].ccat;
-    }
-    for (size_t i = 0; i < item->vals.count; i++) {
-        prod->vals[i] = item->vals[i];
-    }
-
-    return prod;
-}
-
-void *PgfLRTableMaker::Item::operator new(size_t size, CCat* ccat, ref<PgfConcrLin> lin, size_t seq_idx) {
-    size_t n_args = lin->absfun->type->hypos.size();
-    size_t n_fields = lin->seqs.size() / lin->res.size();
-    ref<PgfPResult> res = lin->res[seq_idx / n_fields];
-    size_t n_vars = res->vars.size();
-    size_t ex_size = sizeof(Arg)*n_args+sizeof(size_t)*n_vars;
-
-    Item *item = (Item *) malloc(size+ex_size);
-    item->ref_cnt = 0;
-    item->ccat = ccat;
-    item->lin_obj = lin.tagged();
-    item->seq = lin->seqs[seq_idx];
-    item->seq_idx = seq_idx;
-    item->sym_idx = 0;
-    item->stk_size = 0;
-    item->args.count = n_args;
-    item->vals.count = n_vars;
-    memset(item+1, 0, ex_size);
-
-    return item;
-}
-
-void *PgfLRTableMaker::Item::operator new(size_t size, ref<PgfConcrLincat> lincat, size_t index) {
-    size_t n_args = 1;
-    ref<PgfPResult> res = lincat->res[lincat->n_lindefs+index];
-    size_t n_vars = res->vars.size();
-    size_t ex_size = sizeof(Arg)*n_args+sizeof(size_t)*n_vars;
-
-    size_t seq_idx =
-        lincat->n_lindefs*lincat->fields.size() + index;
-
-    Item *item = (Item *) malloc(size+ex_size);
-    item->ref_cnt = 0;
-    item->ccat = NULL;
-    item->lin_obj = lincat.tagged();
-    item->seq = lincat->seqs[seq_idx];
-    item->seq_idx = seq_idx;
-    item->sym_idx = 0;
-    item->stk_size = 0;
-    item->args.count = n_args;
-    item->vals.count = n_vars;
-    memset(item+1, 0, ex_size);
-
-    return item;
-}
-
-void *PgfLRTableMaker::Item::operator new(size_t size, CCat* ccat, Production *prod, size_t lin_idx) {
-    size_t n_fields = prod->lin->seqs.size() / prod->lin->res.size();
-    ref<PgfPResult> res = prod->lin->res[prod->index];
-    size_t ex_size = sizeof(Arg)*prod->args.count+sizeof(size_t)*prod->vals.count;
-
-    Item *item = (Item *) malloc(size+ex_size);
-    item->ref_cnt = 0;
-    item->ccat = ccat;
-    item->lin_obj = prod->lin.tagged();
-    item->seq_idx = prod->index*n_fields+lin_idx;
-    item->seq = prod->lin->seqs[item->seq_idx];
-    item->sym_idx = 0;
-    item->stk_size = 0;
-    item->args.count = prod->args.count;
-    item->vals.count = prod->vals.count;
-
-    for (size_t i = 0; i < item->args.count; i++) {
-        item->args[i].ccat    = prod->args[i];
-        item->args[i].stk_idx = 0;
-    }
-    for (size_t i = 0; i < item->vals.count; i++) {
-        item->vals[i] = prod->vals[i];
-    }
-
-    return item;
-}
-
-void *PgfLRTableMaker::Item::operator new(size_t size, Item *item, CCat *ccat) {
-    size_t ex_size = sizeof(Arg)*item->args.count+sizeof(size_t)*item->vals.count;
-
-    Item *new_item = (Item *) malloc(size+ex_size);
-    new_item->ref_cnt = 0;
-    new_item->ccat = item->ccat;
-    new_item->lin_obj = item->lin_obj;
-    new_item->seq = item->seq;
-    new_item->seq_idx = item->seq_idx;
-    new_item->sym_idx = item->sym_idx+1;
-    new_item->stk_size = item->stk_size;
-    new_item->args.count = item->args.count;
-    new_item->vals.count = item->vals.count;
-    memcpy(new_item+1,item+1,ex_size);
-
-    ref<PgfSymbolCat> scat =
-        ref<PgfSymbolCat>::untagged(item->seq->syms[item->sym_idx]);
-    new_item->args[scat->d].ccat = ccat;
-
-    return new_item;
-}
-
-void *PgfLRTableMaker::Item::operator new(size_t size, Item *item, size_t lin_idx) {
-    size_t ex_size = sizeof(Arg)*item->args.count+sizeof(size_t)*item->vals.count;
-
-    Item *new_item = (Item *) malloc(size+ex_size);
-    new_item->ref_cnt = 0;
-    new_item->ccat = item->ccat;
-    new_item->lin_obj = item->lin_obj;
-    new_item->seq = item->seq;
-    new_item->seq_idx = item->seq_idx;
-    new_item->sym_idx = item->sym_idx+1;
-    new_item->stk_size = item->stk_size;
-    new_item->args.count = item->args.count;
-    new_item->vals.count = item->vals.count;
-    memcpy(new_item+1,item+1,ex_size);
-
-    ref<PgfSymbolCat> scat =
-        ref<PgfSymbolCat>::untagged(item->seq->syms[item->sym_idx]);
-    new_item->args[scat->d].stk_idx = ++new_item->stk_size;
-
-    return new_item;
-}
-
-void *PgfLRTableMaker::Item::operator new(size_t size, Item *item) {
-    size_t ex_size = sizeof(Arg)*item->args.count+sizeof(size_t)*item->vals.count;
-
-    Item *new_item = (Item *) malloc(size+ex_size);
-    memcpy(new_item,item,size+ex_size);
-    new_item->ref_cnt = 0;
-
-    return new_item;
-}
-
-bool PgfLRTableMaker::CompareKey3::operator() (const Key3& k1, const Key3& k2) const {
-    size_t i = k1.second;
-    size_t j = k2.second;
-    for (;;) {
-        if (i >= k1.first->syms.size() || ref<PgfSymbol>::get_tag(k1.first->syms[i]) != PgfSymbolKS::tag)
-            return (j < k2.first->syms.size() && ref<PgfSymbol>::get_tag(k2.first->syms[j]) == PgfSymbolKS::tag);
-
-        if (j >= k2.first->syms.size() || ref<PgfSymbol>::get_tag(k2.first->syms[j]) != PgfSymbolKS::tag)
-            return false;
-
-        auto symks1 = ref<PgfSymbolKS>::untagged(k1.first->syms[i]);
-        auto symks2 = ref<PgfSymbolKS>::untagged(k2.first->syms[j]);
-
-        int res[2] = {0,0};
-        texticmp(&symks1->token, &symks2->token, res);
-        if (res[0] < 0)
-            return true;
-        if (res[0] > 0)
-            return false;
-
-        i++; j++;
-    }
-
-    return false;
-}
-
-struct PgfLRTableMaker::State {
-    size_t id;
-    std::vector<Item*> items;       // The seed items for this state
-    std::vector<Item*> completed;   // Completed items that will become reductions
-    std::map<Key1,State*,CompareKey1> ccats1;
-    std::map<Key2,State*,CompareKey2> ccats2;
-    std::map<Key3,State*,CompareKey3> tokens;
-    State *bind_state;
-
-    State() {
-        this->id = 0;
-        this->bind_state = NULL;
-    }
-
-    ~State() {
-        for (Item *item : items) {
-            item->ref_cnt--;
-            delete item;
-        }
-
-        for (Item *item : completed) {
-            item->ref_cnt--;
-            delete item;
-        }
-    }
-
-    void push_item(Item *item) {
-        items.push_back(item); item->ref_cnt++;
-        push_heap(items.begin(), items.end(), compare_item);
-    }
-
-    Item *pop_item() {
-        Item *item = items.back(); items.pop_back();
-        item->ref_cnt--;
-        return item;
-    }
-};
-
-PgfLRTableMaker::PgfLRTableMaker(ref<PgfAbstr> abstr, ref<PgfConcr> concr)
+PgfAbstractParser::Cont::~Cont()
 {
-    this->abstr = abstr;
-    this->concr = concr;
-    this->ccat_id = 0;
-    this->state_id = 0;
+    for (Item *item : suspended) {
+        delete item;
+    }
+}
 
-    PgfText *startcat = (PgfText *)
-        alloca(sizeof(PgfText)+9);
-    startcat->size = 8;
-    strcpy(startcat->text, "startcat");
-
-    ref<PgfFlag> flag =
-        namespace_lookup(abstr->aflags, startcat);
-
-    ref<PgfConcrLincat> lincat = 0;
-    if (flag != 0) {
-        switch (ref<PgfLiteral>::get_tag(flag->value)) {
-        case PgfLiteralStr::tag: {
-            auto lstr = ref<PgfLiteralStr>::untagged(flag->value);
-
-            State *state = new State();
-
-            lincat =
-                namespace_lookup(concr->lincats, &lstr->val);
-
-            MD5Context ctxt;
-
-            for (size_t i = 0; i < lincat->res.size()-lincat->n_lindefs; i++) {
-                Item *item = new(lincat, i) Item;
-
-                ctxt.update(item->lin_obj);
-                ctxt.update(item->seq_idx);
-                ctxt.update(item->sym_idx);
-                ctxt.update(item->args[0].ccat);
-                ctxt.update(item->args[0].stk_idx);
-                for (size_t i = 0; i < item->vals.count; i++) {
-                    ctxt.update(item->vals[i]);
+PgfAbstractParser::~PgfAbstractParser()
+{
+    State *state = first_state;
+    while (state != NULL) {
+        for (auto it1 : state->completed) {
+            for (auto it2 : it1.second) {
+                for (auto it3 : it2.second) {
+                    delete it3.second;
                 }
-
-                state->push_item(item);
             }
-
-            MD5Digest digest;
-            ctxt.finalize(&digest);
-
-            states[digest] = state;
-            todo.push(state);
         }
+        for (auto it : state->conts1) {
+            delete it.second;
         }
-    }
-}
-
-PgfLRTableMaker::~PgfLRTableMaker()
-{
-    for (auto p : states) {
-        delete p.second;
-    }
-
-    for (auto p : ccats1) {
-        delete p.second;
-    }
-
-    for (auto p : ccats2) {
-        delete p.second;
-    }
-}
-
-#if defined(DEBUG_STATE_CREATION) || defined(DEBUG_AUTOMATON)
-void PgfLRTableMaker::print_production(CCat *ccat, Production *prod)
-{
-    PgfPrinter printer(NULL, 0, NULL);
-
-    ref<PgfPResult> res = *vector_elem(prod->lin->res, prod->index);
-    if (res->vars != 0) {
-        printer.lvar_ranges(res->vars, &prod->vals[0]);
-        printer.puts(" ");
-    }
-
-    ref<PgfDTyp> type = prod->lin->absfun->type;
-    printer.nprintf(37, "?%zu -> ", ccat->id);
-    printer.puts(&prod->lin->name);
-    printer.nprintf(37, "/%zu[", prod->index);
-    PgfDBMarshaller m;
-    size_t args_start = type->hypos->len * prod->index;
-    for (size_t i = 0; i < type->hypos->len; i++) {
-        if (i > 0)
-            printer.puts(",");
-
-        if (prod->args[i] == NULL) {
-            ref<PgfPArg> arg = vector_elem(prod->lin->args, args_start + i);
-            m.match_type(&printer, vector_elem(type->hypos, i)->type.as_object());
-            printer.puts("(");
-            printer.lparam(arg->param);
-            printer.puts(")");
-        } else {
-            printer.nprintf(32, "?%zu", prod->args[i]->id);
-        }
-    }
-    printer.puts("]\n");
-
-    PgfText *text = printer.get_text();
-    fputs(text->text, stderr);
-    free(text);
-}
-
-void PgfLRTableMaker::print_item(Item *item)
-{
-    PgfPrinter printer(NULL, 0, NULL);
-
-    switch (ref<PgfConcrLin>::get_tag(item->lin_obj)) {
-    case PgfConcrLin::tag: {
-        auto lin =
-            ref<PgfConcrLin>::untagged(item->lin_obj);
-
-        size_t index = item->seq_idx / lin->lincat->fields->len;
-        size_t r     = item->seq_idx % lin->lincat->fields->len;
-        ref<PgfPResult> res = *vector_elem(lin->res, index);
-        if (res->vars != 0) {
-            printer.lvar_ranges(res->vars, &item->vals[0]);
-            printer.puts(" ");
-        }
-
-        if (item->ccat->parent == NULL) {
-            printer.puts(&item->ccat->lincat->name);
-            printer.puts("(");
-            printer.lparam(ref<PgfLParam>::from_ptr(&res->param));
-            printer.puts(") -> ");
-        } else {
-            printer.nprintf(32,"?%zu -> ",item->ccat->parent->id);
-        }
-
-        printer.puts(&lin->name);
-        printer.nprintf(32, "/%zd[", index);
-        PgfDBMarshaller m;
-        ref<PgfDTyp> type = lin->absfun->type;
-        size_t args_start = type->hypos->len * index;
-        for (size_t i = 0; i < type->hypos->len; i++) {
-            if (i > 0)
-                printer.puts(",");
-
-            if (item->args[i].ccat == NULL) {
-                ref<PgfPArg> arg = vector_elem(lin->args, args_start + i);
-                m.match_type(&printer, vector_elem(type->hypos, i)->type.as_object());
-                printer.puts("(");
-                printer.lparam(arg->param);
-                printer.puts(")");
-            } else {
-                printer.nprintf(32, "?%zu", item->args[i].ccat->id);
+        for (auto it1 : state->conts2) {
+            for (auto it2 : it1.second) {
+                delete it2.second;
             }
-            if (item->args[i].stk_idx > 0)
-                printer.nprintf(32, "$%zd", item->args[i].stk_idx);
-        }
-        printer.nprintf(32, "]; %zu : ", r);
-        break;
-    }
-    case PgfConcrLincat::tag: {
-        auto lincat =
-            ref<PgfConcrLincat>::untagged(item->lin_obj);
-
-        size_t index = item->seq_idx - lincat->n_lindefs*lincat->fields->len;
-        ref<PgfPResult> res = *vector_elem(lincat->res, lincat->n_lindefs+index);
-        if (res->vars != 0) {
-            printer.lvar_ranges(res->vars, &item->vals[0]);
-            printer.puts(" ");
         }
 
-        printer.puts("linref ");
-        printer.puts(&lincat->name);
-        printer.nprintf(32, "/%zd[", index);
-        if (item->args[0].ccat == NULL) {
-            printer.puts(&lincat->name);
-            printer.puts("(");
-            printer.lparam(vector_elem(lincat->args, lincat->n_lindefs+index)->param);
-            printer.puts(")");
-        } else {
-            printer.nprintf(32, "?%zu", item->args[0].ccat->id);
-        }
-        if (item->args[0].stk_idx > 0)
-            printer.nprintf(32, "$%zd", item->args[0].stk_idx);
-        printer.puts("]; 0 : ");
-        break;
+        State *next = state->next;
+        delete state;
+        state = next;
     }
-    }
-
-    if (item->sym_idx == 0)
-        printer.puts(". ");
-
-    for (size_t i = 0; i < item->seq->syms.len; i++) {
-        PgfSymbol sym = item->seq->syms.data[i];
-        printer.symbol(sym);
-
-        if (i+1 == item->sym_idx)
-            printer.puts(" . ");
-    }
-    printer.puts("\n");
-
-    PgfText *text = printer.get_text();
-    fputs(text->text, stderr);
-    free(text);
 }
+
+void PgfAbstractParser::process(Item *item, const PgfTextSpot &spot, bool bind)
+{
+#ifdef DEBUG_PARSER
+    print_item(item,spot);
 #endif
 
-void PgfLRTableMaker::process(State *state, Fold fold, Item *item)
-{
-#if defined(DEBUG_STATE_CREATION)
-    if (fold == PROBE)
-        fprintf(stderr, "PROBE  ");
-    else if (fold == INIT)
-        fprintf(stderr, "INIT   ");
-    else if (fold == REPEAT)
-        fprintf(stderr, "REPEAT ");
-    print_item(item);
-#endif
-
-    if (item->sym_idx < item->seq->syms.size()) {
-        PgfSymbol sym = item->seq->syms[item->sym_idx];
-        symbol(state, fold, item, sym);
+    if (item->dot < item->syms.size()) {
+        symbol(item,spot,bind,item->syms[item->dot]);
+    } else if (item->pre_alt > 0) {
+        item->dot     = item->pre_dot+1;
+        item->pre_alt = 0;
+        item->pre_dot = 0;
+        item->syms    = item->rule->syms.as_vector();
+        process(item,spot,bind);
     } else {
-        complete(state, fold, item);
+        complete(item,spot,bind);
     }
 }
 
-void PgfLRTableMaker::symbol(State *state, Fold fold, Item *item, PgfSymbol sym)
+PGF_INTERNAL_DECL
+int text_symbol_cmp(PgfTextSpot *spot, const uint8_t *end,
+                    PgfSymbol sym, bool case_sensitive);
+
+void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym)
 {
     switch (ref<PgfSymbol>::get_tag(sym)) {
     case PgfSymbolCat::tag: {
         auto symcat = ref<PgfSymbolCat>::untagged(sym);
 
-        switch (ref<PgfConcrLin>::get_tag(item->lin_obj)) {
-        case PgfConcrLin::tag: {
-            auto lin =
-                ref<PgfConcrLin>::untagged(item->lin_obj);
-            ref<PgfPResult> res = lin->res[item->seq_idx / lin->lincat->fields.size()];
-            auto arg = item->args[symcat->d];
-            if (arg.ccat != NULL) {
-                predict(state, fold, item, arg.ccat, res->vars, &symcat->r);
-            } else {
-                ref<PgfHypo> hypo = lin->absfun->type->hypos.elem(symcat->d);
-                predict(state, fold, item, ref<PgfText>::from_ptr(&hypo->type->name), res->vars, &symcat->r);
+        State *state = new_state(spot);
+
+        CCat *ccat = item->args[symcat->d];
+        if (ccat == NULL) {
+            ref<PgfConcrLincat> lincat = 0;
+            switch (ref<object>::get_tag(item->rule->container)) {
+            case PgfConcrLin::tag: {
+                auto lin = ref<PgfConcrLin>::untagged(item->rule->container);
+                lincat =
+                    namespace_lookup(concr->lincats,
+                                     &lin->absfun->type->hypos[symcat->d].type->name);
+                break;
             }
-            break;
-        }
-        case PgfConcrLincat::tag: {
-            auto lincat =
-                ref<PgfConcrLincat>::untagged(item->lin_obj);
-            ref<PgfPResult> res =
-                lincat->res[lincat->n_lindefs + item->seq_idx - lincat->n_lindefs*lincat->fields.size()];
-            auto arg = item->args[symcat->d];
-            if (arg.ccat != NULL) {
-                predict(state, fold, item, arg.ccat, res->vars, &symcat->r);
-            } else {
-                predict(state, fold, item, ref<PgfText>::from_ptr(&lincat->name), res->vars, &symcat->r);
+            case PgfConcrLincat::tag: {
+                lincat = ref<PgfConcrLincat>::untagged(item->rule->container);
+                break;
+            }
+            }
+
+            if (lincat != 0) {
+                suspend(state,lincat,item);
+            }
+        } else {
+            size_t max_value = 1;
+            for (size_t i = 0; i < symcat->r.n_terms; i++) {
+                size_t var = symcat->r.terms[i].var;
+                for (size_t j = 0; j < item->vars.size(); j++) {
+                    if (item->rule->vars[j].var == var && item->vars[j] == 0) {
+                        max_value *= item->rule->vars[j].range;
+                        break;
+                    }
+                }
+            }
+
+            for (size_t value = 0; value < max_value; value++) {
+                Item *new_item = new (item) Item;
+
+                size_t value_ = value;
+                size_t lin_idx = symcat->r.i0;
+                for (size_t i = 0; i < symcat->r.n_terms; i++) {
+                    size_t var = symcat->r.terms[i].var;
+                    for (size_t j = 0; j < new_item->vars.size(); j++) {
+                        if (new_item->rule->vars[j].var == var) {
+                            if (new_item->vars[j] == 0) {
+                                size_t range = new_item->rule->vars[j].range;
+                                new_item->vars[j] = (value_ % range) + 1;
+                                value_ = value_ / range;
+                            }
+                            lin_idx += symcat->r.terms[i].factor * (new_item->vars[j]-1);
+                            break;
+                        }
+                    }
+                }
+
+                Cont *&cont = state->conts2[ccat][lin_idx];
+                if (cont == NULL) {
+                    cont = new Cont;
+                    cont->ccat = ccat;
+                    cont->lincat = ccat->cont->lincat;
+                    cont->state = state;
+                }
+
+                cont->suspended.push_back(item);
+
+                if (cont->suspended.size() == 1) {
+                    for (Production *prod : cont->ccat->prods) {
+                        td_predict(state,cont,prod,lin_idx);
+                    }
+                } else {
+                    State *next = state;
+                    while (next != NULL) {
+                        
+                        auto it1 = next->completed.find(cont);
+                        if (it1 != next->completed.end()) {
+                            auto it2 = it1->second.find(ccat->value);
+                            if (it2 != it1->second.end()) {
+                                auto it3 = it2->second.find(lin_idx);
+                                if (it3 != it2->second.end()) {
+                                    CCat *arg = it3->second;
+                                    Item *new_item = new (item) Item;
+                                    combine(next, new_item, arg);
+                                }
+                            }
+                        }
+                        next = next->next;
+                    }
+                }
             }
-            break;
-        }
         }
         break;
     }
     case PgfSymbolKS::tag: {
-        auto symks = ref<PgfSymbolKS>::untagged(sym);
-
-        size_t sym_idx_2 = item->sym_idx+1;
-        while (sym_idx_2 < item->seq->syms.size()) {
-            if (ref<PgfSymbol>::get_tag(item->seq->syms[sym_idx_2]) != PgfSymbolKS::tag)
-                break;
-            sym_idx_2++;
-        }
-
-        if (fold == PROBE) {
-            item->ccat->productive = true;
-            if (item->sym_idx > 0 || sym_idx_2 < item->seq->syms.size()) {
-                item->ccat->register_item(item);
-            }
-        } else {
-            auto &next_state = state->tokens[Key3(item->seq,item->sym_idx)];
-            if (next_state == NULL) {
-                next_state = new State;
-            }
-            item = new (item) Item;
-            item->sym_idx = sym_idx_2;
-            item->stk_size++;
-            next_state->push_item(item);
-        }
+        symbol_token(item, spot, bind, sym);
         break;
     }
     case PgfSymbolKP::tag: {
-        if (fold == PROBE) {
-            item->ccat->productive = true;
-            item->ccat->register_item(item);
-        } else {
-            auto symkp = ref<PgfSymbolKP>::untagged(sym);
-            Item *new_item1 = NULL;
-            Item *new_item2 = NULL;
-            for (size_t i = 0; i < symkp->alts.size(); i++) {
-                ref<PgfSequence> form = symkp->alts[i].form;
-                if (form->syms.size() == 0) {
-                    if (!new_item1) {
-                        new_item1 = new (item) Item;
-                        new_item1->sym_idx++;
-                    }
-                    process(state, fold, new_item1);
-                } else {
-                    auto &next_state = state->tokens[Key3(form,0)];
-                    if (next_state == NULL) {
-                        next_state = new State;
-                    }
-                    if (!new_item2) {
-                        new_item2 = new (item) Item;
-                        new_item2->sym_idx++;
-                        new_item2->stk_size++;
-                    }
-                    next_state->push_item(new_item2);
-                }
-            }
+        auto symkp = ref<PgfSymbolKP>::untagged(sym);
 
-            ref<PgfSequence> form = symkp->default_form;
-            if (form->syms.size() == 0) {
-                if (!new_item1) {
-                    new_item1 = new (item) Item;
-                    new_item1->sym_idx++;
-                }
-                process(state, fold, new_item1);
-            } else {
-                auto &next_state = state->tokens[Key3(form,0)];
-                if (next_state == NULL) {
-                    next_state = new State;
-                }
-                if (!new_item2) {
-                    new_item2 = new (item) Item;
-                    new_item2->sym_idx++;
-                    new_item2->stk_size++;
-                }
-                next_state->push_item(new_item2);
-            }
+        Item *new_item = new(item) Item;
+        new_item->pre_alt = 1;
+        new_item->pre_dot = item->dot;
+        new_item->dot     = 0;
+        new_item->syms    = symkp->default_form;
+        new_item->rule    = item->rule;
+        process(new_item, spot, bind);
 
-            // If the items are not owned by anyone, we must delete them
-            if (new_item1 != NULL)
-                delete new_item1;
-            if (new_item2 != NULL)
-                delete new_item2;
+        for (size_t i = 0; i < symkp->alts.size(); i++) {
+            Item *new_item = new(item) Item;
+            new_item->pre_alt = i+2;
+            new_item->pre_dot = item->dot;
+            new_item->dot     = 0;
+            new_item->syms    = symkp->alts[i].form;
+            new_item->rule    = item->rule;
+            process(new_item, spot, bind);
         }
+
+        // delete item;
+        break;
     }
     case PgfSymbolBIND::tag: {
-        if (fold == PROBE) {
-            item->ccat->productive = true;
-            item->ccat->register_item(item);
-        } else {
-            if (state->bind_state == NULL) {
-                state->bind_state = new State;
-            }
-            item = new (item) Item;
-            item->sym_idx++;
-            item->stk_size++;
-            state->bind_state->push_item(item);
-        }
+        symbol_bind(item, spot, sym);
         break;
     }
     case PgfSymbolSOFTBIND::tag:
     case PgfSymbolSOFTSPACE::tag: {
-        if (fold == PROBE) {
-            item->ccat->productive = true;
-            item->ccat->register_item(item);
-        } else {
-            // SOFT_BIND && SOFT_SPACE also allow a space
-            Item *new_item = new (item) Item();
-            new_item->sym_idx++;
-            process(state,fold,new_item);
-            delete new_item;
-
-            // Now we handle the case where there is no space.
-            if (state->bind_state == NULL) {
-                state->bind_state = new State;
-            }
-            new_item = new (item) Item();
-            new_item->stk_size++;
-            state->bind_state->push_item(new_item);
-            delete new_item;
-        }
+        item->dot++;
+        process(item, spot, true);
+        process(item, spot, false);
         break;
     }
     case PgfSymbolCAPIT::tag:
-    case PgfSymbolALLCAPIT::tag: {
-        // We just ignore CAPIT && ALLCAPIT during parsing
-        item = new (item) Item(); item->sym_idx++;
-        process(state,fold,item);
-        delete item;
+    case PgfSymbolALLCAPIT::tag:
+        item->dot++;
+        process(item, spot, bind);
+        break;
+    }
+}
+
+void PgfAbstractParser::complete(Item *item, const PgfTextSpot &spot, bool bind)
+{
+    State *state = new_state(spot);
+
+    switch (ref<object>::get_tag(item->rule->container)) {
+    case PgfConcrLin::tag: {
+        auto lin = ref<PgfConcrLin>::untagged(item->rule->container);
+
+        size_t max_value = 1;
+
+        size_t n_inst_vars = 0;
+        size_t *inst_vars  = (size_t*)
+            alloca(sizeof(size_t)*item->vars.size());
+
+        // Compute which variables to assign to get determinate
+        // values of res and lin_idx
+        for (size_t i = 0; i < item->vars.size(); i++) {
+            if (item->vars[i] != 0)
+                continue;
+
+            size_t var = item->rule->vars[i].var;
+            for (size_t j = 0; j < item->rule->res->n_terms; j++) {
+                if (item->rule->res->terms[j].var == var) {
+                    goto found;
+                }
+            }
+            for (size_t j = 0; j < item->rule->lin_idx->n_terms; j++) {
+                if (item->rule->lin_idx->terms[j].var == var) {
+                    goto found;
+                }
+            }
+
+            continue;
+
+        found:
+            inst_vars[n_inst_vars++] = i;
+            max_value *= item->rule->vars[i].range;
+        }
+
+        // Go through all possible assignments and create a production
+        for (size_t value = 0; value < max_value; value++) {
+            size_t value_ = value;
+            for (size_t i = 0; i < n_inst_vars; i++) {
+                size_t var   = inst_vars[i];
+                size_t range = item->rule->vars[var].range;
+                item->vars[var] = (value_ % range) + 1;
+                value_ = value_ / range;
+            }
+
+            size_t res = item->rule->res->i0;
+            for (size_t i = 0; i < item->rule->res->n_terms; i++) {
+                term t = item->rule->res->terms[i];
+                for (size_t j = 0; j < item->vars.size(); j++) {
+                    if (t.var == item->rule->vars[j].var) {
+                        res += t.factor * (item->vars[j]-1);
+                        break;
+                    }
+                }
+            }
+            size_t lin_idx = item->rule->lin_idx->i0;
+            for (size_t i = 0; i < item->rule->lin_idx->n_terms; i++) {
+                term t = item->rule->lin_idx->terms[i];
+                for (size_t j = 0; j < item->vars.size(); j++) {
+                    if (t.var == item->rule->vars[j].var) {
+                        lin_idx += t.factor * (item->vars[j]-1);
+                        break;
+                    }
+                }
+            }
+
+            CCat *&ccat = state->completed[item->cont][res][lin_idx];
+            if (ccat == NULL) {
+                ccat = new CCat;
+                ccat->fid = (++last_fid);
+                ccat->cont  = item->cont;
+                ccat->state = state;
+                ccat->lin_idx = lin_idx;
+                ccat->value = res;
+                ccat->covered = false;
+
+#ifdef DEBUG_PARSER
+                {
+                    PgfPrinter printer(NULL,0,NULL);
+                    printer.nprintf(64,"[%zd-%zd; ",item->cont->state->end.pos,state->start.pos);
+                    if (ccat->cont->ccat == NULL) {
+                        printer.efun(&ccat->cont->lincat->name);
+                        printer.nprintf(64,"(%zd)",ccat->value);
+                    } else {
+                        printer.emeta(ccat->cont->ccat->fid);
+                    }
+                    printer.nprintf(64,"; %zd; ",ccat->lin_idx);
+                    printer.emeta(ccat->fid);
+                    printer.puts("]");
+                    PgfText *text = printer.get_text();
+                    fprintf(stderr, "%s\n", text->text);
+                    free(text);
+                }
+#endif
+            }
+
+            auto prod = new(item) Production;
+            prod->rule = item->rule;
+            for (size_t i = 0; i < prod->args.size(); i++) {
+                if (prod->args[i] != NULL && prod->args[i] != ccat)
+                    prod->args[i]->covered = true;
+            }
+            ccat->prods.push_back(prod);
+            
+#ifdef DEBUG_PARSER
+            print_prod(ccat, prod);
+#endif
+            final_item(state, item, res, lin_idx);
+
+            if (ccat->prods.size() == 1) {
+                if (ccat->cont->ccat == NULL)
+                    bu_predict(concr->phrasetable, state, ccat);
+                size_t n_items = item->cont->suspended.size();
+                for (size_t i = 0; i < n_items; i++) {
+                    Item *new_item = new (item->cont->suspended[i]) Item;
+                    combine(state,new_item,ccat);
+                };
+            } else {
+                State *next = state;
+                while (next != NULL) {
+                    for (auto it : next->conts2[ccat]) {
+                        size_t lin_idx = it.first;
+                        Cont  *cont    = it.second;
+                        if (cont != NULL) {
+                            size_t n_items = cont->suspended.size();
+                            for (size_t i = 0; i < n_items; i++) {
+                                td_predict(next,cont,prod,lin_idx);
+                            }
+                        }
+                    }
+                    next = next->next;
+                }
+            }
+        }
+        break;
+    }
+    case PgfConcrLincat::tag: {
+        auto lincat = ref<PgfConcrLincat>::untagged(item->rule->container);
+        final_item(state, item, 0, 0);
         break;
     }
     }
 }
 
-struct PGF_INTERNAL_DECL PgfVariableValue {
-    size_t range;
-    size_t factor;
-    size_t value;
-    size_t j;
-};
-
-template<class T>
-void PgfLRTableMaker::predict(State *state, Fold fold, Item *item, T cat,
-                              vector<PgfVariableRange> vars, PgfLParam *r)
+bool PgfAbstractParser::Item::instantiate(ref<PgfLParam> lparam,size_t value)
 {
-    size_t index   = r->i0;
-    size_t n_terms = 0;
-
-    PgfVariableValue *values = (PgfVariableValue *)
-        alloca(sizeof(PgfVariableValue)*r->n_terms);
-    for (size_t i = 0; i < r->n_terms; i++)
-    {
-        size_t var = r->terms[i].var;
-        for (size_t j = 0; j < vars.size(); j++)
-        {
-            ref<PgfVariableRange> range = vars.elem(j);
-            if (range->var == var) {
-                if (item->vals[j] == 0) {
-                    values[n_terms].range  = range->range;
-                    values[n_terms].factor = r->terms[i].factor;
-                    values[n_terms].value  = 0;
-                    values[n_terms].j      = j;
-                    n_terms++;
-                } else {
-                    index += (item->vals[j]-1) * r->terms[i].factor;
-                }
-                break;
-            }
-        }
-    }
-
-    for (;;) {
-        Item *new_item = new (item) Item();
-        for (size_t i = 0; i < n_terms; i++) {
-            new_item->vals[values[i].j] = values[i].value+1;
-        }
-
-        predict(state, fold, new_item, cat, index);
-
-        delete new_item;
-
-        size_t i = n_terms;
-        while (i > 0) {
-            i--;
-            values[i].value++;
-            if (values[i].value < values[i].range) {
-                index += values[i].factor;
-                i++;
-                break;
-            }
-
-            index -= (values[i].value-1) * values[i].factor;
-            values[i].value = 0;
-        }
-
-        if (i == 0) {
-            break;
-        }
-    }
-}
-
-void PgfLRTableMaker::predict(State *state, Fold fold, Item *item, ref<PgfText> cat, size_t lin_idx)
-{
-    CCat *&ccat = ccats1[Key0(cat,lin_idx)];
-    CCat *tmp = ccat;
-    if (tmp == NULL) {
-        ccat = new CCat(++ccat_id, NULL, lin_idx);
-    }
-    if (fold == PROBE) {
-        ccat->suspend_item(item);
-    }
-    if (tmp == NULL) {
-        std::function<bool(ref<PgfAbsFun>)> f =
-            [this,ccat](ref<PgfAbsFun> fun) {
-                predict(fun, ccat);
-                return true;
-            };
-        probspace_iter(abstr->funs_by_cat, cat, f, false);
-    } else if (fold == PROBE && ccat->prods.size() > 0) {
-        Item *new_item = new(item,ccat) Item;
-        process(state,fold,new_item);
-        delete new_item;
-    }
-
-    if (fold == PROBE) {
-        if (item->ccat != NULL && ccat->productive) {
-            item->ccat->productive = true;
-            item->ccat->register_item(item);
-        }
-    } else {
-        if (ccat->productive) {
-            auto &next_state = state->ccats1[Key1(ccat->lincat,lin_idx)];
-            if (next_state == NULL) {
-                next_state = new State;
-            }
-            next_state->push_item(new(item,lin_idx) Item);
-
-            if (next_state->items.size() == 1) {
-                for (size_t i = 0; i < ccat->items.size(); i++) {
-                    process(state, REPEAT, ccat->items[i]);
-                }
-            }
-        }
-
-        if (fold == INIT && ccat->prods.size() > 0) {
-            Item *new_item = new (item, ccat) Item;
-            process(state, fold, new_item);
-            delete new_item;
-        }
-    }
-}
-
-void PgfLRTableMaker::predict(State *state, Fold fold, Item *item, CCat *ccat, size_t lin_idx)
-{
-    CCat *&new_ccat = ccats2[Key2(ccat,lin_idx)];
-    CCat *tmp = new_ccat;
-    if (new_ccat == NULL) {
-        new_ccat = new CCat(++ccat_id, ccat, lin_idx);
-    }
-    if (fold == PROBE) {
-        new_ccat->suspend_item(item);
-    }
-    if (tmp == NULL) {
-        size_t n_prods = ccat->prods.size();
-        for (size_t i = 0; i < n_prods; i++) {
-            Production *prod = ccat->prods[i];
-            Item *item = new(new_ccat, prod, lin_idx) Item;
-            process(NULL, PROBE, item);
-            delete item;
-        }
-    }
-
-    if (fold == PROBE) {
-        if (item->ccat != NULL && new_ccat->productive) {
-            item->ccat->productive = true;
-            item->ccat->register_item(item);
-        }
-    } else {
-        if (new_ccat->productive) {
-            auto &next_state = state->ccats2[Key2(new_ccat,lin_idx)];
-            if (next_state == NULL) {
-                next_state = new State;
-            }
-            next_state->push_item(new(item,lin_idx) Item);
-
-            if (next_state->items.size() == 1) {
-                for (size_t i = 0; i < new_ccat->items.size(); i++) {
-                    process(state, REPEAT, new_ccat->items[i]);
-                }
-            }
-        }
-        if (fold == INIT && new_ccat->prods.size() > 0) {
-            Item *new_item = new (item, new_ccat) Item;
-            process(state, fold, new_item);
-            delete new_item;
-        }
-    }
-}
-
-void PgfLRTableMaker::predict(ref<PgfAbsFun> absfun, CCat *ccat)
-{
-    ref<PgfConcrLin> lin =
-        namespace_lookup(concr->lins, &absfun->name);
-
-    if (lin != 0) {
-        ccat->lincat = lin->lincat;
-
-        size_t n_fields = lin->seqs.size() / lin->res.size();
-        for (size_t i = 0; i < lin->res.size(); i++) {
-            size_t seq_idx = n_fields * i + ccat->lin_idx;
-            Item *item = new(ccat, lin, seq_idx) Item;
-            process(NULL, PROBE, item);
-            delete item;
-        }
-    }
-}
-
-void PgfLRTableMaker::complete(State *state, Fold fold, Item *item)
-{
-    if (fold == PROBE) {
-        Production *prod = new(item) Production;
-        item->ccat->prods.push_back(prod);
-
-#if defined(DEBUG_STATE_CREATION) || defined(DEBUG_AUTOMATON)
-        print_production(item->ccat, prod);
-#endif
-
-        if (item->ccat->prods.size() == 1) {
-            // If this is the first epsilon production,
-            // resume the suspended items.
-
-            // We don't use an iterator here since the vector suspended,
-            // may get updated in the recursion.
-            size_t n_susp = item->ccat->suspended.size();
-            for (size_t i = 0; i < n_susp; i++) {
-                Item *susp = item->ccat->suspended[i];
-                if (susp != NULL) {
-                    Item *new_item = new (susp, item->ccat) Item;
-                    process(state, PROBE, new_item);
-                    delete new_item;
-                }
-            }
-        }
-    } else {
-        state->completed.push_back(item); item->ref_cnt++;
-
-#if defined(DEBUG_AUTOMATON)
-        fprintf(stderr, "reduce ");
-        print_item(item);
-#endif
-    }
-}
-
-void PgfLRTableMaker::internalize_state(State *&state)
-{
-    MD5Context ctxt;
-    auto begin = state->items.begin();
-    auto end   = state->items.end();
-    while (begin != end) {
-        Item *item = *(--end);
-        ctxt.update(item->lin_obj);
-        ctxt.update(item->seq_idx);
-        ctxt.update(item->sym_idx);
-        for (size_t i = 0; i < item->args.count; i++) {
-            ctxt.update(item->args[i].ccat);
-            ctxt.update(item->args[i].stk_idx);
-        }
-        for (size_t i = 0; i < item->vals.count; i++) {
-            ctxt.update(item->vals[i]);
-        }
-
-        pop_heap(begin,end,compare_item);
-    }
-
-    MD5Digest digest;
-    ctxt.finalize(&digest);
-
-    State *&next_state = states[digest];
-    if (next_state == NULL) {
-        next_state = state;
-        next_state->id = ++state_id;
-        todo.push(next_state);
-    } else {
-        delete state;
-        state = next_state;
-    }
-}
-
-vector<PgfLRState> PgfLRTableMaker::make()
-{
-    while (!todo.empty()) {
-        State *state = todo.front(); todo.pop();
-
-#if defined(DEBUG_AUTOMATON) || defined(DEBUG_STATE_CREATION)
-        fprintf(stderr, "--------------- state %ld ---------------\n", state->id);
-#endif
-
-        while (!state->items.empty()) {
-            Item *item = state->pop_item();
-
-#if defined(DEBUG_AUTOMATON) && !defined(DEBUG_STATE_CREATION)
-            // The order in which we process the items should not matter,
-            // For debugging however it is useful to see them in the same order.
-            pop_heap(state->items.begin(),state->items.end(),compare_item);
-            print_item(item);
-#endif
-
-            process(state, INIT, item);
-
-            delete item;
-        }
-
-        for (auto &i : state->ccats1) {
-            internalize_state(i.second);
-#if defined(DEBUG_AUTOMATON)
-            fprintf(stderr, "%s.%zu: state %ld\n",
-                    i.first.first->name.text, i.first.second, i.second->id);
-#endif
-        }
-        for (auto &i : state->ccats2) {
-            internalize_state(i.second);
-#if defined(DEBUG_AUTOMATON)
-            fprintf(stderr, "%s.%zu: state %ld\n",
-                    i.first.first->lincat->name.text, i.first.second, i.second->id);
-#endif
-        }
-        for (auto &i : state->tokens) {
-            internalize_state(i.second);
-#if defined(DEBUG_AUTOMATON)
-            PgfPrinter printer(NULL, 0, NULL);
-            size_t sym_idx = i.first.second;
-            ref<PgfSequence> seq = i.first.first;
-            while (sym_idx < seq->syms.len) {
-                PgfSymbol sym = seq->syms.data[sym_idx];
-                if (ref<PgfSymbol>::get_tag(sym) != PgfSymbolKS::tag)
-                    break;
-                printer.symbol(sym);
-                sym_idx++;
-            }
-            printer.nprintf(64, ": state %ld\n", i.second->id);
-
-            PgfText *text = printer.get_text();
-            fputs(text->text, stderr);
-            free(text);
-#endif
-        }
-        if (state->bind_state != NULL) {
-            internalize_state(state->bind_state);
-#if defined(DEBUG_AUTOMATON)
-            fprintf(stderr, "BIND: state %ld\n", state->bind_state->id);
-#endif
-        }
-
-    }
-
-    vector<PgfLRState> lrtable = vector<PgfLRState>::alloc(states.size());
-    for (auto v : states) {
-        State *state = v.second;
-
-        size_t index = 0;
-        auto shifts = vector<PgfLRShift>::alloc(state->ccats1.size()+state->ccats2.size());
-        for (auto i : state->ccats1) {
-            ref<PgfLRShift> shift = shifts.elem(index++);
-            shift->lincat = i.first.first;
-            shift->r = i.first.second;
-            shift->next_state = i.second->id;
-        }
-        for (auto i : state->ccats2) {
-            ref<PgfLRShift> shift = shifts.elem(index++);
-            shift->lincat = i.first.first->lincat;
-            shift->r = i.first.second;
-            shift->next_state = i.second->id;
-        }
-
-        vector<PgfLRShiftKS> tokens = 0;
-        if (state->tokens.size() > 0) {
-            size_t index = 0;
-            tokens = vector<PgfLRShiftKS>::alloc(state->tokens.size());
-            for (auto i : state->tokens) {
-                ref<PgfLRShiftKS> shift = tokens.elem(index++);
-                shift->seq = i.first.first;
-                shift->sym_idx = i.first.second;
-                shift->next_state = i.second->id;
-            }
-        }
-
-        size_t next_bind_state = 0;
-        if (state->bind_state != NULL) {
-            next_bind_state = state->bind_state->id;
-        }
-
-        auto reductions = vector<PgfLRReduce>::alloc(state->completed.size());
-        for (size_t i = 0; i < state->completed.size(); i++) {
-            Item *item = state->completed[i];
-            ref<PgfLRReduce> reduction = reductions.elem(i);
-            reduction->lin_obj = item->lin_obj;
-            reduction->seq_idx = item->seq_idx;
-            reduction->depth = item->stk_size;
-
-            auto args = vector<PgfLRReduce::Arg>::alloc(item->args.count);
-            for (size_t j = 0; j < item->args.count; j++) {
-                ref<PgfLRReduceArg> arg = 0;
-                if (item->args[j].ccat != NULL) {
-                    arg = item->args[j].ccat->persist();
-                }
-                args[j].arg     = arg;
-                args[j].stk_idx = item->args[j].stk_idx;
-            }
-            reduction->args = args;
-        }
-
-        ref<PgfLRState> lrstate = lrtable.elem(state->id);
-        lrstate->shifts = shifts;
-        lrstate->tokens = tokens;
-        lrstate->next_bind_state = next_bind_state;
-        lrstate->reductions = reductions;
-    }
-    return lrtable;
-}
-
-PgfLCTableMaker::PgfLCTableMaker(ref<PgfAbstr> abstr, ref<PgfConcr> concr)
-{
-    this->abstr = abstr;
-    this->concr = concr;
-}
-
-PgfLCTableMaker::~PgfLCTableMaker()
-{
-}
-
-static bool edge_match(ref<PgfLCEdge> edge1, ref<PgfLCEdge> edge2)
-{
-    size_t sz1 = sizeof(PgfLCEdge) + sizeof(term)*edge1->n_terms + sizeof(PgfVariableRange)*edge1->vars.size();
-    size_t sz2 = sizeof(PgfLCEdge) + sizeof(term)*edge2->n_terms + sizeof(PgfVariableRange)*edge2->vars.size();
-    
-    if (sz1 != sz2)
+    if (value < lparam->i0)
         return false;
-    return (memcmp(&*edge1,&*edge2,sz1) == 0);
-}
+    value -= lparam->i0;
 
-int comp (const void * elem1, const void * elem2) 
-{
-    int f = *((int*)elem1);
-    int s = *((int*)elem2);
-    if (f > s) return  1;
-    if (f < s) return -1;
-    return 0;
-}
-
-void PgfLCTableMaker::rename(ref<PgfLCEdge> edge)
-{
-    size_t next_var = 0;
-    std::map<size_t,size_t> subst;
-    for (size_t i = 0; i < edge->n_terms; i++) {
-        auto it = subst.find(edge->terms[i].var);
-        if (it == subst.end()) {
-            subst[edge->terms[i].var] = next_var;
-            edge->terms[i].var = next_var++;
-        } else {
-            edge->terms[i].var = it->second;
-        }
-    }
-
-    for (size_t i = 0; i < edge->vars.size(); i++) {
-        edge->vars[i].var = subst[edge->vars[i].var];
-    }
-    qsort (&edge->vars[0], edge->vars.size(), sizeof(PgfVariableRange), comp);
-}
-
-void PgfLCTableMaker::add_edge(ref<PgfLCEdge> edge)
-{
-    bool found = false;
-    for (ref<PgfLCEdge> xedge : forwards[edge->from.lincat]) {
-        if (edge_match(edge,xedge)) {
-            found = true;
-            break;
-        }
-    }
-
-    if (!found) {
-        print_edge(edge);
-        forwards[edge->from.lincat].push_back(edge);
-        backwards[edge->to.lincat].push_back(edge);
-        update_closure(edge);
-    }
-}
-
-void PgfLCTableMaker::update_closure(ref<PgfLCEdge> edge)
-{
-    auto &incoming = backwards[edge->from.lincat];
-    size_t n_incoming = incoming.size();
-    for (size_t i = 0; i < n_incoming; i++) {
-        ref<PgfLCEdge> xedge = compute_unifier(incoming[i],edge);
-        if (xedge != 0) {
-            rename(xedge);
-            add_edge(xedge);
-        }
-    }
-
-    auto &outgoing = forwards[edge->to.lincat];
-    size_t n_outgoing = outgoing.size();
-    for (size_t i = 0; i < n_outgoing; i++) {
-        ref<PgfLCEdge> xedge = compute_unifier(edge,outgoing[i]);
-        if (xedge != 0) {
-            rename(xedge);
-            add_edge(xedge);
-        }
-    }
-}
-
-typedef std::pair<size_t,std::vector<term>> Param;
-typedef std::map<size_t,Param> Subst;
-
-template<class V, class T, class F>
-bool unifier_helper1(Subst &subst1, V &vars1, T &to,
-                     Subst &subst2, V &vars2, F &from)
-{
-    size_t i01t = to.i0;
-    size_t i02f = from.i0;
-
-    size_t i = 0, j = 0;
-    while (i < to.size() && j < from.size()) {
-        size_t factor1 = to[i].factor;
-        size_t range1  = 0;
-        for (size_t k = 0; k < vars1.size(); k++) {
-            if (vars1[k].var == to[i].var) {
-                range1 = vars1[k].range;
+    for (size_t j = 0; j < lparam->n_terms; j++) {
+        term t = lparam->terms[j];
+        for (size_t k = 0; k < vars.size(); k++) {
+            if (rule->vars[k].var == t.var) {
+                if (vars[k] > 0) {
+                    if (value < vars[k]-1)
+                        return false;
+                    value -= vars[k]-1;
+                }
                 break;
             }
         }
-        size_t value1 = factor1*range1;
+    }
 
-        size_t factor2 = from[j].factor;
-        size_t range2  = 0;
-        for (size_t k = 0; k < vars2.size(); k++) {
-            if (vars2[k].var == from[j].var) {
-                range2 = vars2[k].range;
+    for (size_t j = 0; j < lparam->n_terms; j++) {
+        term t = lparam->terms[j];
+        for (size_t k = 0; k < vars.size(); k++) {
+            if (rule->vars[k].var == t.var) {
+                if (vars[k] == 0) {
+                    size_t v_val = value / t.factor;
+                    if (v_val >= rule->vars[k].range)
+                        return false;
+                    vars[k] = v_val + 1;
+                    value %= t.factor;
+                }
                 break;
             }
         }
-        size_t value2 = factor2*range2;
+    }
 
-        if (value1 > value2) {
-            size_t x = i02f / factor1;
-            if (x >= range1)
-                return false;
-            auto &s = subst1[to[i].var];
-            s.first = i02f / factor1;
-            s.second.clear();
-            i02f %= factor1;
-            while (j < from.size() && factor2 % factor1 == 0) {
-                size_t factor = factor2 / factor1;
-                s.second.emplace_back();
-                s.second.back().factor=factor;
-                s.second.back().var=subst2[from[j].var].second[0].var;
+    return (value == 0);
+}
+
+bool PgfAbstractParser::Item::instantiate(ref<PgfLParam> lparam,ref<PgfLParam> value,Item *other)
+{
+    size_t i = 0;
+    size_t i0_lparam = lparam->i0;
+
+    size_t j = 0;
+    size_t i0_value  = value->i0;
+
+    while (i < lparam->n_terms && j < value->n_terms) {
+        size_t max_lparam = 0, k_lparam = 0;
+        while (i < lparam->n_terms) {
+            for (k_lparam = 0; k_lparam < this->rule->vars.size(); k_lparam++) {
+                if (this->rule->vars[k_lparam].var == lparam->terms[i].var) {
+                    break;
+                }
+            }
+            if (this->vars[k_lparam] > 0) {
+                i0_lparam += lparam->terms[i].factor * (this->vars[k_lparam]-1);
+                i++;
+            } else {
+                max_lparam = lparam->terms[i].factor * this->rule->vars[k_lparam].range;
+                break;
+            }
+        }
+
+        size_t max_value = 0, k_value = 0;
+        while (j < value->n_terms) {
+            for (k_value = 0; k_value < other->rule->vars.size(); k_value++) {
+                if (other->rule->vars[k_value].var == value->terms[j].var) {
+                    break;
+                }
+            }
+            if (other->vars[k_value] > 0) {
+                i0_lparam += value->terms[j].factor * (other->vars[k_value]-1);
                 j++;
-                factor2 = from[j].factor;
+            } else {
+                max_value = value->terms[j].factor * other->rule->vars[k_value].range;
+                break;
             }
+        }
+
+        if (max_lparam > max_value) {
+            this->vars[k_lparam] = i0_value / this->rule->vars[k_lparam].range;
+            i0_value = i0_value % this->rule->vars[k_lparam].range;
             i++;
         } else {
-            size_t x = i01t / factor2;
-            if (x >= range2)
-                return false;
-            auto &s = subst2[from[j].var];
-            s.first = i01t / factor2;
-            s.second.clear();
-            i01t %= factor2;
-            while (i < to.size() && factor1 % factor2 == 0) {
-                size_t factor = factor1 / factor2;
-                s.second.emplace_back();
-                s.second.back().factor=factor;
-                s.second.back().var=subst1[to[i].var].second[0].var;
-                i++;
-                factor1 = to[i].factor;
-            }
+            //other->vars[k_value] = i0_lparam / other->rule->vars[k_value].range;
+            i0_lparam = i0_lparam % other->rule->vars[k_value].range;
             j++;
         }
     }
 
-    while (i < to.size()) {
-        auto &s = subst1[to[i].var];
-        size_t factor1 = to[i].factor;
-        s.first = i02f / factor1;
-        s.second.clear();
-        i02f %= factor1;
-        i++;
-    }
-
-    while (j < from.size()) {
-        auto &s = subst2[from[j].var];
-        size_t factor2 = from[j].factor;
-        s.first = i01t / factor2;
-        s.second.clear();
-        i01t %= factor2;
-        j++;
-    }
-
-    return (i01t == i02f);
+    return (i0_lparam == i0_value);
 }
 
-template<class A>
-void unifier_helper2(Subst &subst, std::map<size_t,size_t> &vars, std::map<size_t,size_t> &ranges, A &v, Param &p)
+void PgfAbstractParser::bu_predict(PgfPhrasetable phrasetable,
+                                   State *state, CCat *ccat)
 {
-    for (size_t i = 0; i < v.size(); i++) {
-        auto &s = subst[v[i].var];
-        size_t factor = v[i].factor;
-        p.first += factor * s.first;
-        for (term &t : s.second) {
-            p.second.emplace_back();
-            p.second.back().factor = factor * t.factor;
-            p.second.back().var = t.var;
-            vars[t.var] = ranges[t.var];
+    if (phrasetable == 0) {
+        return;
+	}
+
+    int cmp;
+    uint8_t tag = ref<PgfSymbol>::get_tag(phrasetable->sym);
+    if (PgfSymbolACat::tag != tag) {
+		cmp = ((int) PgfSymbolACat::tag) - ((int) tag);
+	} else {
+        auto symcf = ref<PgfSymbolACat>::untagged(phrasetable->sym);
+        cmp = textcmp(&ccat->cont->lincat->name, &symcf->name);
+    }
+    if (cmp < 0) {
+        bu_predict(phrasetable->left,state,ccat);
+    } else if (cmp > 0) {
+        bu_predict(phrasetable->right,state,ccat);
+    } else {        
+        for (size_t i = 0; i < phrasetable->n_items; i++) {
+            auto new_item = bu_item(ccat->cont->state, phrasetable->items[i]);
+            combine(state,new_item,ccat);
         }
     }
 }
 
-ref<PgfLCEdge> PgfLCTableMaker::compute_unifier(ref<PgfLCEdge> edge1, ref<PgfLCEdge> edge2)
+PgfAbstractParser::Item *PgfAbstractParser::bu_item(State *state, ref<PgfItem> pitem)
 {
-    std::map<size_t,std::pair<size_t,std::vector<term>>> subst1, subst2;
-    std::map<size_t,size_t> vars, ranges;
+    Item *item = NULL;
 
-    size_t next_var = 0;
-    for (size_t i = 0; i < edge1->vars.size(); i++) {
-        ranges[next_var] = edge1->vars[i].range;
+    switch (ref<object>::get_tag(pitem->rule->container)) {
+    case PgfConcrLin::tag: {
+        auto lin = ref<PgfConcrLin>::untagged(pitem->rule->container);
 
-        auto &s = subst1[edge1->vars[i].var];
-        s.second.emplace_back();
-        s.second.back().factor = 1;
-        s.second.back().var = next_var++;        
+        Cont *&cont = state->conts1[lin->lincat];
+        if (cont == NULL) {
+            cont = new Cont;
+            cont->ccat = NULL;
+            cont->lincat = lin->lincat;
+            cont->state = state;
+        }
+
+        item = new(pitem->rule) Item;
+        item->cont    = cont;
+        item->pre_alt = pitem->pre_alt;
+        item->pre_dot = pitem->pre_dot;
+        item->dot     = pitem->dot;
+        item->syms    = pitem->rule->syms.as_vector();
+        item->rule    = pitem->rule;
+        break;
     }
-    for (size_t i = 0; i < edge2->vars.size(); i++) {
-        ranges[next_var] = edge2->vars[i].range;
+    case PgfConcrLincat::tag: {
+        auto lincat = ref<PgfConcrLincat>::untagged(pitem->rule->container);
 
-        auto &s = subst2[edge2->vars[i].var];
-        s.second.emplace_back();
-        s.second.back().factor = 1;
-        s.second.back().var = next_var++;
+        Cont *&cont = state->conts1[0];
+        if (cont == NULL) {
+            cont = new Cont;
+            cont->ccat = NULL;
+            cont->lincat = 0;
+            cont->state = state;
+        }
+
+        item = new(pitem->rule) Item;
+        item->cont    = cont;
+        item->pre_alt = pitem->pre_alt;
+        item->pre_dot = pitem->pre_dot;
+        item->dot     = pitem->dot;
+        item->syms    = pitem->rule->syms.as_vector();
+        item->rule    = pitem->rule;
+        break;
+    }
     }
 
-    if (!unifier_helper1(subst1, edge1->vars, edge1->to.value,
-                         subst2, edge2->vars, edge2->from.value))
-        return 0;
-    if (!unifier_helper1(subst1, edge1->vars, edge1->to.lin_idx,
-                         subst2, edge2->vars, edge2->from.lin_idx))
-        return 0;
+    if (item->pre_alt > 0) {
+        auto symkp = ref<PgfSymbolKP>::untagged(item->syms[item->pre_dot]);
 
-    Param p1fv,p1fi,p2tv,p2ti;
-    p1fv.first = edge1->from.value.i0;
-    p1fi.first = edge1->from.lin_idx.i0;
-    p2tv.first = edge2->to.value.i0;
-    p2ti.first = edge2->to.lin_idx.i0;
+        if (item->pre_alt == 1)
+            item->syms = symkp->default_form;
+        else
+            item->syms = symkp->alts[item->pre_alt-2].form;
+    }
 
-    unifier_helper2(subst1, vars, ranges, edge1->from.value, p1fv);
-    unifier_helper2(subst1, vars, ranges, edge1->from.lin_idx, p1fi);
-    unifier_helper2(subst2, vars, ranges, edge2->to.value, p2tv);
-    unifier_helper2(subst2, vars, ranges, edge2->to.lin_idx, p2ti);
+    memcpy(&item->vars[0], &pitem->vars[0], sizeof(size_t) * item->vars.size());
 
-    ref<PgfLCEdge> edge = PgfLCEdge::alloc(p1fv.second.size(),p1fi.second.size(),p2tv.second.size(),p2ti.second.size(),vars.size());
-    edge->from.lincat = edge1->from.lincat;
-    edge->from.value.i0 = p1fv.first;
-    for (size_t i = 0; i < p1fv.second.size(); i++) {
-        edge->from.value[i] = p1fv.second[i];
+    for (size_t i = 0; i < pitem->args.size(); i++) {
+        ref<PgfSymbolCCat> arg = pitem->args[i];
+
+        item->args[i] = 0;
+
+        if (arg != 0) {
+            Cont *&arg_cont = state->conts1[arg->lincat];
+            if (arg_cont == NULL) {
+                arg_cont = new Cont;
+                arg_cont->ccat = NULL;
+                arg_cont->lincat = arg->lincat;
+                arg_cont->state = state;
+            }
+            item->args[i] =
+                td_epsilon(state, arg_cont, arg);
+        }
     }
-    edge->from.lin_idx.i0 = p1fi.first;
-    for (size_t i = 0; i < p1fi.second.size(); i++) {
-        edge->from.lin_idx[i] = p1fi.second[i];
-    }
-    edge->to.lincat = edge2->to.lincat;
-    edge->to.value.i0 = p2tv.first;
-    for (size_t i = 0; i < p2tv.second.size(); i++) {
-        edge->to.value[i] = p2tv.second[i];
-    }
-    edge->to.lin_idx.i0 = p2ti.first;
-    for (size_t i = 0; i < p2ti.second.size(); i++) {
-        edge->to.lin_idx[i] = p2ti.second[i];
-    }
-    size_t i = 0;
-    for (auto it : vars) {
-        edge->vars[i].var   = it.first;
-        edge->vars[i].range = it.second;
-        i++;
-    }
-/*
-    if (strcmp(edge->to.lincat->name.text, "VP") == 0 && edge->to.value.i0 == 2 && edge->to.value.size() == 2) {
-        print_edge(edge1);
-        print_edge(edge2);
-        fprintf(stderr,"------------------\n");
-        print_edge(edge);
-        fprintf(stderr,"\n");
-    }
-*/
-    return edge;
+
+    return item;
 }
 
-void PgfLCTableMaker::print_edge(ref<PgfLCEdge> edge)
+void PgfAbstractParser::combine(State *state, Item *item, CCat *ccat)
 {
-    PgfPrinter printer(NULL, 0, NULL);
+    PgfSymbol sym = item->rule->syms[item->dot];
+    auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
 
-    if (edge->vars.size() > 0) {
-        printer.puts("{");
-        for (size_t i = 0; i < edge->vars.size(); i++) {
+    if (!item->instantiate(item->rule->args[sym_cat->d],ccat->value)) {
+        // delete item;
+        return;
+    }
+    if (!item->instantiate(ref<PgfLParam>::from_ptr(&sym_cat->r),ccat->lin_idx)) {
+        // delete item;
+        return;
+    }
+    item->dot++;
+    item->args[sym_cat->d] = ccat;
+
+    process(item, state->start, false);
+}
+
+#ifdef DEBUG_PARSER
+static
+void print_symbols(PgfPrinter &printer, PgfConcrRule *rule, vector<PgfSymbol> syms, size_t pre_alt, size_t pre_dot, size_t dot)
+{
+    for (size_t i = 0; i < syms.size(); i++) {
+        if (pre_alt == 0 && dot == i) {
+            printer.puts(" . ");
+            printer.symbol(syms[i]);
+        } else if (pre_alt > 0 && pre_dot == i) {
+            auto sym_kp = ref<PgfSymbolKP>::untagged(rule->syms[pre_dot]);
+
+            printer.puts("pre {");
+
+            if (pre_alt == 1)
+                print_symbols(printer, rule, syms, 0, 0, dot);
+            else
+                printer.symbols(sym_kp->default_form);
+
+            for (size_t i = 0; i < sym_kp->alts.size(); i++) {
+                printer.puts("; ");
+                if (pre_alt-2 == i)
+                    print_symbols(printer, rule, syms, 0, 0, dot);
+                else
+                    printer.symbols(sym_kp->alts[i].form);
+                printer.puts(" /");
+                for (size_t j = 0; j < sym_kp->alts[i].prefixes.size(); j++) {
+                    printer.puts(" ");
+                    printer.lstr(sym_kp->alts[i].prefixes[j]);
+                }
+            }
+
+            printer.puts("}");
+        } else {
+            printer.symbol(syms[i]);
+        }
+    }
+    if (pre_alt == 0 && dot >= syms.size())
+        printer.puts(" . ");
+}
+
+void PgfAbstractParser::print_item(Item *item, const PgfTextSpot &spot)
+{
+    PgfPrinter printer(NULL,0,NULL);
+
+    printer.nprintf(32, "[%zd-%zd; ", item->cont ? item->cont->state->end.pos : 0, spot.pos);
+
+    if (item->vars.size() > 0) {
+        printer.lvar_ranges(item->rule->vars, &item->vars[0]);
+        printer.puts(" ");
+    }
+
+    if (item->cont) {
+        if (item->cont->ccat == NULL) {
+            printer.efun(&item->cont->lincat->name);
+            printer.puts("(");
+            printer.lparam(item->rule->res);
+            printer.puts(")");
+        } else {
+            printer.emeta(item->cont->ccat->fid);
+        }
+    }
+    printer.puts(" -> ");
+
+    switch (ref<object>::get_tag(item->rule->container)) {
+    case PgfConcrLin::tag: {
+        auto lin = ref<PgfConcrLin>::untagged(item->rule->container);
+        printer.efun(&lin->name);
+
+        printer.puts("[");
+        for (size_t i = 0; i < item->args.size(); i++) {
             if (i > 0)
                 printer.puts(",");
-            printer.lvar(edge->vars[i].var);
-            printer.nprintf(32,"<%zu",edge->vars[i].range);
-        }
-        printer.puts("} ");
-    }
 
-    printer.efun(&edge->from.lincat->name);
-    printer.puts("(");
-    if (edge->from.value.i0 != 0 || edge->from.value.size() == 0)
-        printer.nprintf(32,"%ld",edge->from.value.i0);
-    for (size_t i = 0; i < edge->from.value.size(); i++) {
-        if (edge->from.value.i0 != 0 || i > 0)
-            printer.puts("+");
-        if (edge->from.value[i].factor != 1) {
-            printer.nprintf(32,"%ld",edge->from.value[i].factor);
-            printer.puts("*");
-        }
-        printer.lvar(edge->from.value[i].var);
-    }
-    printer.puts(",");
-    if (edge->from.lin_idx.i0 != 0 || edge->from.lin_idx.size() == 0)
-        printer.nprintf(32,"%ld",edge->from.lin_idx.i0);
-    for (size_t i = 0; i < edge->from.lin_idx.size(); i++) {
-        if (edge->from.lin_idx.i0 != 0 || i > 0)
-            printer.puts("+");
-        if (edge->from.lin_idx[i].factor != 1) {
-            printer.nprintf(32,"%ld",edge->from.lin_idx[i].factor);
-            printer.puts("*");
-        }
-        printer.lvar(edge->from.lin_idx[i].var);
-    }
-    printer.puts(") -> ");
-
-    printer.efun(&edge->to.lincat->name);
-    printer.puts("(");
-    if (edge->to.value.i0 != 0 || edge->to.value.size() == 0)
-        printer.nprintf(32,"%ld",edge->to.value.i0);
-    for (size_t i = 0; i < edge->to.value.size(); i++) {
-        if (edge->to.value.i0 != 0 || i > 0)
-            printer.puts("+");
-        if (edge->to.value[i].factor != 1) {
-            printer.nprintf(32,"%ld",edge->to.value[i].factor);
-            printer.puts("*");
-        }
-        printer.lvar(edge->to.value[i].var);
-    }
-    printer.puts(",");
-    if (edge->to.lin_idx.i0 != 0 || edge->to.lin_idx.size() == 0)
-        printer.nprintf(32,"%ld",edge->to.lin_idx.i0);
-    for (size_t i = 0; i < edge->to.lin_idx.size(); i++) {
-        if (edge->to.lin_idx.i0 != 0 || i > 0)
-            printer.puts("+");
-        if (edge->to.lin_idx[i].factor != 1) {
-            printer.nprintf(32,"%ld",edge->to.lin_idx[i].factor);
-            printer.puts("*");
-        }
-        printer.lvar(edge->to.lin_idx[i].var);
-    }
-    printer.puts(")\n");
-
-    PgfText *text = printer.get_text();
-    fputs(text->text, stderr);
-    free(text);
-}
-
-vector<PgfLRState> PgfLCTableMaker::make()
-{
-    std::function<bool(ref<PgfConcrLin>)> f =
-        [this](ref<PgfConcrLin> lin) {
-            for (size_t seq_idx = 0; seq_idx < lin->seqs.size(); seq_idx++) {
-                size_t index = seq_idx / (lin->seqs.size() / lin->res.size());
-                size_t n_args = (lin->args.size() / lin->res.size());
-                ref<PgfPResult> res = lin->res[index];
-                ref<PgfSequence> seq = lin->seqs[seq_idx];
-
-                if (seq->syms.size() > 0) {
-                    PgfSymbol sym = seq->syms[0];
-                    switch (ref<PgfSymbol>::get_tag(sym)) {
-                    case PgfSymbolCat::tag: {
-                        auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
-                        size_t arg_idx = n_args * index + sym_cat->d;
-                        ref<PgfPArg> arg = ref<PgfPArg>::from_ptr(&lin->args[arg_idx]);
-
-                        std::set<size_t> vars;
-                        for (size_t i = 0; i < res->param.n_terms; i++) {
-                            vars.insert(res->param.terms[i].var);
-                        }
-                        for (size_t i = 0; i < arg->param->n_terms; i++) {
-                            vars.insert(arg->param->terms[i].var);
-                        }
-                        for (size_t i = 0; i < sym_cat->r.n_terms; i++) {
-                            vars.insert(sym_cat->r.terms[i].var);
-                        }
-
-                        ref<PgfLCEdge> edge =
-                            PgfLCEdge::alloc(res->param.n_terms,0,arg->param->n_terms,sym_cat->r.n_terms,vars.size());
-                        edge->from.lincat = lin->lincat;
-                        edge->from.value.i0 = res->param.i0;
-                        for (size_t i = 0; i < res->param.n_terms; i++) {
-                            edge->from.value[i] = res->param.terms[i];
-                        }
-                        edge->from.lin_idx.i0 = seq_idx % (lin->seqs.size() / lin->res.size());
-                        edge->to.lincat =
-                            namespace_lookup(concr->lincats, &lin->absfun->type->hypos[sym_cat->d].type->name);
-                        edge->to.value.i0 = arg->param->i0;
-                        for (size_t i = 0; i < arg->param->n_terms; i++) {
-                            edge->to.value[i] = arg->param->terms[i];
-                        }
-                        edge->to.lin_idx.i0 = sym_cat->r.i0;
-                        for (size_t i = 0; i < sym_cat->r.n_terms; i++) {
-                            edge->to.lin_idx[i] = sym_cat->r.terms[i];
-                        }
-                        size_t i = 0;
-                        for (size_t var : vars) {
-                            edge->vars[i].var = var;
-                            for (size_t k = 0; k < res->vars.size(); k++) {
-                                if (res->vars[k].var == var) {
-                                    edge->vars[i].range = res->vars[k].range;
-                                    break;
-                                }
-                            }
-                            i++;
-                        }
-
-                        rename(edge);
-                        add_edge(edge);
-                    }
-                    break;
-                    }
-                }
+            CCat *ccat = item->args[i];
+            if (ccat == NULL) {
+                printer.efun(&lin->absfun->type->hypos[i].type->name);
+                printer.puts("(");
+                printer.lparam(item->rule->args[i]);
+                printer.puts(")");
+            } else {
+                printer.emeta(ccat->fid);
             }
-            return true;
-        };
-    namespace_iter(concr->lins, f);
-
-/*    for (auto it : forwards) {
-        for (ref<PgfLCEdge> edge : it.second) {
-            print_edge(edge);
         }
+        printer.puts("]; ");
+        break;
     }
-*/
-    return 0;
-}
+    case PgfConcrLincat::tag: {
+        auto lincat = ref<PgfConcrLincat>::untagged(item->rule->container);
+        printer.puts("linref ");
+        printer.efun(&lincat->name);
 
-struct PgfParser::Choice {
-    int fid;
-    std::vector<Production*> prods;
-    std::vector<ExprState*> states;
-    std::vector<ExprInstance> exprs;
-
-    Choice(int fid) {
-        this->fid = fid;
-    }
-
-    ~Choice();
-};
-
-struct PgfParser::Production {
-    ref<PgfConcrLin> lin;
-    size_t index;
-    size_t n_args;
-    Choice *args[];
-
-    void *operator new(size_t size, ref<PgfConcrLin> lin, size_t index) {
-        size_t n_args = lin->args.size() / lin->res.size();
-        Production *prod = (Production *)
-            malloc(size+sizeof(Choice*)*n_args);
-        prod->lin    = lin;
-        prod->index  = index;
-        prod->n_args = n_args;
-        for (size_t i = 0; i < n_args; i++) {
-            prod->args[i] = NULL;
-        }
-        return prod;
-    }
-
-    Production() {
-        // If there is no constructor, GCC will zero the object,
-        // while it has already been initialized in the new operator.
-    }
-
-    bool operator==(const Production& other) const {
-        if (lin != other.lin || index != other.index)
-            return false;
-
-        for (size_t i = 0; i < n_args; i++) {
-            if (args[i] != other.args[i])
-                return false;
-        }
-
-        return true;
-    }
-
-    void operator delete(void *p) {
-        free(p);
-    }
-};
-
-struct PgfParser::StackNode {
-    Stage *stage;
-    size_t state_id;
-    Choice *choice;
-    std::vector<StackNode*> parents;
-
-    StackNode(Stage *stage, size_t state_id) {
-        this->stage    = stage;
-        this->state_id = state_id;
-        this->choice   = NULL;
-    }
-};
-
-struct PgfParser::Stage {
-    Stage *next;
-    PgfTextSpot start;
-    PgfTextSpot end;
-    std::vector<StackNode*> nodes;
-
-    Stage(PgfTextSpot spot) {
-        next = NULL;
-        start = spot;
-        end   = spot;
-    }
-
-    ~Stage() {
-        for (StackNode *node : nodes) {
-            delete node;
-        }
-    }
-};
-
-struct PgfParser::ExprState {
-    prob_t prob;
-
-    Choice *choice;
-    Production *prod;
-    size_t n_args;
-    PgfExpr expr;
-};
-
-struct PgfParser::ExprInstance {
-    PgfExpr expr;
-    prob_t prob;
-
-    ExprInstance(PgfExpr expr, prob_t prob) {
-        this->expr = expr;
-        this->prob = prob;
-    }
-};
-
-PgfParser::Choice::~Choice() {
-    while (states.size() > 0) {
-        ExprState *state = states.back(); states.pop_back();
-        delete state;
-    }
-
-    for (Production *prod : prods) {
-        delete prod;
-    }
-}
-
-#if defined(DEBUG_STATE_CREATION) || defined(DEBUG_AUTOMATON) || defined(DEBUG_PARSER)
-void PgfParser::print_prod(Choice *choice, Production *prod)
-{
-    PgfPrinter printer(NULL, 0, m);
-
-    printer.nprintf(32, "?%d -> ", choice->fid);
-
-    ref<PgfDTyp> type = prod->lin->absfun->type;
-    printer.puts(&prod->lin->name);
-    printer.nprintf(32,"/%zd[", prod->index);
-    PgfDBMarshaller m;
-    for (size_t i = 0; i < prod->n_args; i++) {
-        Choice *choice = prod->args[i];
-        if (i > 0)
-            printer.puts(",");
-        if (choice == NULL) {
-            m.match_type(&printer, vector_elem(type->hypos, i)->type.as_object());
+        printer.puts("[");
+        CCat *ccat = item->args[0];
+        if (ccat == NULL) {
+            printer.efun(&lincat->name);
+            printer.puts("(");
+            printer.lparam(item->rule->args[0]);
+            printer.puts(")");
         } else {
-            printer.nprintf(32, "?%d", choice->fid);
+            printer.emeta(ccat->fid);
         }
+        printer.puts("]; ");
+        break;
     }
-    printer.puts("]\n");
+    }
+
+    printer.lparam(item->rule->lin_idx);
+    printer.puts(" : ");
+    print_symbols(printer, item->rule, item->syms, item->pre_alt, item->pre_dot, item->dot);
+    printer.puts("]");
 
     PgfText *text = printer.get_text();
-    fputs(text->text, stderr);
+    fprintf(stderr, "%s\n", text->text);
     free(text);
 }
 
-void PgfParser::print_transition(StackNode *source, StackNode *target, Stage *stage, ref<PgfLRShiftKS> shift)
+void PgfAbstractParser::print_prod(CCat *ccat, Production *prod)
 {
-    PgfPrinter printer(NULL, 0, m);
-    printer.nprintf(64, "state %ld --- ", source->state_id);
-    if (target->choice != 0) {
-        printer.nprintf(32, "?%d", target->choice->fid);
-    } else if (shift != 0) {
-        size_t sym_idx = shift->sym_idx;
-        ref<PgfSequence> seq = shift->seq;
-        while (sym_idx < seq->syms.len) {
-            PgfSymbol sym = seq->syms.data[sym_idx];
-            if (ref<PgfSymbol>::get_tag(sym) != PgfSymbolKS::tag)
-                break;
-            printer.symbol(sym);
-            sym_idx++;
-        }
-    } else {
-        printer.puts("BIND");
+    PgfPrinter printer(NULL,0,NULL);
+
+    if (prod->vars.size() > 0) {
+        printer.lvar_ranges(prod->rule->vars, &prod->vars[0]);
+        printer.puts(" ");
     }
-    printer.nprintf(80, " ---> state %ld (position %zu-%zu, nodes %zu)\n",
-                    target->state_id,
-                    stage->start.pos, stage->end.pos, stage->nodes.size());
+
+    printer.emeta(ccat->fid);
+    printer.puts(" -> ");
+
+    switch (ref<object>::get_tag(prod->rule->container)) {
+    case PgfConcrLin::tag: {
+        auto lin = ref<PgfConcrLin>::untagged(prod->rule->container);
+        printer.efun(&lin->name);
+
+        printer.puts("[");
+        for (size_t i = 0; i < prod->args.size(); i++) {
+            if (i > 0)
+                printer.puts(",");
+
+            CCat *ccat = prod->args[i];
+            if (ccat == NULL) {
+                printer.efun(&lin->absfun->type->hypos[i].type->name);
+                printer.puts("(");
+                printer.lparam(prod->rule->args[i]);
+                printer.puts(")");
+            } else {
+                printer.emeta(ccat->fid);
+            }
+        }
+        printer.puts("]");
+        break;
+    }
+    case PgfConcrLincat::tag: {
+        auto lincat = ref<PgfConcrLincat>::untagged(prod->rule->container);
+        printer.puts("linref ");
+        printer.efun(&lincat->name);
+
+        printer.puts("[");
+        CCat *ccat = prod->args[0];
+        if (ccat == NULL) {
+            printer.efun(&lincat->name);
+            printer.puts("(");
+            printer.lparam(prod->rule->args[0]);
+            printer.puts(")");
+        } else {
+            printer.emeta(ccat->fid);
+        }
+        printer.puts("]");
+        break;
+    }
+    }
+
     PgfText *text = printer.get_text();
-    fputs(text->text, stderr);
+    fprintf(stderr, "%s\n", text->text);
     free(text);
 }
 #endif
 
-PgfParser::PgfParser(ref<PgfConcr> concr, ref<PgfConcrLincat> start, PgfText *sentence, bool case_sensitive, PgfMarshaller *m, PgfUnmarshaller *u)
+PgfParser::PgfParser(ref<PgfConcr> concr, PgfText *sentence, bool case_sensitive, PgfMarshaller *m, PgfUnmarshaller *u)
+   : PgfAbstractParser(concr)
 {
-    this->concr = concr;
-    this->sentence = sentence;
-    this->case_sensitive = case_sensitive;
     this->m = m;
     this->u = u;
-    this->last_fid = 0;
-    this->top_choice = NULL;
-    this->top_choice_index = 0;
-
-    PgfTextSpot spot;
-    spot.pos = 0;
-    spot.ptr = (uint8_t*) sentence->text;
-
-    this->before = new Stage(spot);
-    this->after  = NULL;
-    this->ahead  = NULL;
-
-    StackNode *node = new StackNode(before, 0);
-    this->before->nodes.push_back(node);
+    this->sentence = sentence;
+    this->end = (uint8_t *) (sentence->text+sentence->size);
+    this->case_sensitive = case_sensitive;
 }
 
-bool PgfParser::shift(StackNode *parent, ref<PgfConcrLincat> lincat, size_t r, Production *prod,
-                      Stage *before, Stage *after)
+PgfParser::~PgfParser()
 {
-    vector<PgfLRShift> shifts = concr->lrtable[parent->state_id].shifts;
-    for (size_t i = 0; i < shifts.size(); i++) {
-        ref<PgfLRShift> shift = shifts.elem(i);
-        if (lincat == shift->lincat && r == shift->r) {
-            StackNode *node = NULL;
-            for (StackNode *n : after->nodes) {
-                if (n->stage == before && n->state_id == shift->next_state) {
-                    node = n;
-                    break;
-                }
-            }
-            if (node == NULL) {
-                node = new StackNode(before, shift->next_state);
-                node->choice = new Choice(++last_fid);
-                dynamic.push_back(node->choice);
-                after->nodes.push_back(node);
-            }
-
-            bool added = true;
-            for (Production *other : node->choice->prods) {
-                if (*prod == *other) {
-                    added = false;
-                    break;
-                }
-            }
-
-            if (added) {
-                node->choice->prods.push_back(prod);
-#ifdef DEBUG_PARSER
-                print_prod(node->choice, prod);
-#endif
-            }
-
-            if (std::find(node->parents.begin(), node->parents.end(), parent) == node->parents.end()) {
-                node->parents.push_back(parent);
-#ifdef DEBUG_PARSER
-                print_transition(parent,node,after,0);
-#endif
-            }
-
-            return added;
-        }
-    }
-
-    return false;
-}
-
-void PgfParser::shift(StackNode *parent, Stage *before)
-{
-    vector<PgfLRShiftKS> shifts = concr->lrtable[parent->state_id].tokens;
-    if (shifts != 0) {
-        const uint8_t *sent_end = (const uint8_t *) &sentence->text[sentence->size];
-        for (size_t i = 0; i < shifts.size(); i++) {
-            ref<PgfLRShiftKS> shift = shifts.elem(i);
-            PgfTextSpot spot = before->end;
-            size_t sym_idx = shift->sym_idx;
-            int cmp =
-                text_sequence_cmp(&spot, sent_end,
-                                  shift->seq, &sym_idx,
-                                  case_sensitive, SM_PARTIAL);
-            if (cmp == 0) {
-                start_matches(&spot, NULL);
-
-                StackNode *node = NULL;
-                for (StackNode *n : after->nodes) {
-                    if (n->stage == before && n->state_id == shift->next_state) {
-                        node = n;
-                        break;
+    State *state = first_state;
+    while (state != NULL) {
+        for (auto it1 : state->completed) {
+            for (auto it2 : it1.second) {
+                for (auto it3 : it2.second) {
+                    for (ExprState *estate : it3.second->pending) {
+                        if (estate->expr != 0)
+                            u->free_ref(estate->expr);
+                    }
+                    for (ExprProb &ep : it3.second->exprs) {
+                        u->free_ref(ep.expr);
                     }
                 }
-                if (node == NULL) {
-                    node = new StackNode(before, shift->next_state);
-                    node->choice = NULL;
-                    after->nodes.push_back(node);
-                }
-
-                if (std::find(node->parents.begin(), node->parents.end(), parent) == node->parents.end()) {
-                    node->parents.push_back(parent);
-#ifdef DEBUG_PARSER
-                    print_transition(parent,node,after,shift);
-#endif
-                }
-
-                end_matches(&spot, NULL);
             }
         }
+
+        state = state->next;
     }
 }
 
-void PgfParser::shift(StackNode *parent, Stage *before, Stage *after)
+void PgfParser::bu_predict(PgfPhrasetable phrasetable,
+                           State *state,
+                           ptrdiff_t min, ptrdiff_t max)
 {
-    size_t next_bind_state = concr->lrtable[parent->state_id].next_bind_state;
-    if (next_bind_state != 0) {
-        StackNode *node = NULL;
-        for (StackNode *n : after->nodes) {
-            if (n->stage == before && n->state_id == next_bind_state) {
-                node = n;
-                break;
-            }
-        }
-        if (node == NULL) {
-            node = new StackNode(before, next_bind_state);
-            node->choice = NULL;
-            after->nodes.push_back(node);
-        }
-
-        if (std::find(node->parents.begin(), node->parents.end(), parent) == node->parents.end()) {
-            node->parents.push_back(parent);
-#ifdef DEBUG_PARSER
-            print_transition(parent,node,after,0);
-#endif
-        }
-    }
-}
-
-PgfParser::Choice *PgfParser::intersect_choice(Choice *choice1, Choice *choice2, intersection_map &im)
-{
-    if (choice1 == NULL)
-        return choice2;
-    if (choice2 == NULL)
-        return choice1;
-    if (choice1 == choice2)
-        return choice1;
-
-    std::pair<Choice*,Choice*> key(choice1,choice2);
-    auto it = im.find(key);
-    if (it != im.end()) {
-        return it->second;
-    }
-
-    Choice *choice = new Choice(++last_fid);
-    dynamic.push_back(choice);
-    im[key] = choice;
-    for (Production *prod1 : choice1->prods) {
-        for (Production *prod2 : choice2->prods) {
-            if (prod1->lin == prod2->lin && prod1->index == prod2->index) {
-                Production *prod = new(prod1->lin,prod1->index) Production();
-                choice->prods.push_back(prod);
-
-                for (size_t i = 0; i < prod->n_args; i++) {
-                    Choice *arg = intersect_choice(prod1->args[i],prod2->args[i],im);
-                    if (arg == NULL) {
-                        //delete choice;
-                        return NULL;
-                    }
-                    prod->args[i] = arg;
-                }
-
-#ifdef DEBUG_PARSER
-                print_prod(choice, prod);
-#endif
-            }
-        }
-    }
-
-    return choice;
-}
-
-void PgfParser::reduce(StackNode *parent, ref<PgfConcrLin> lin, ref<PgfLRReduce> red,
-                       size_t n, std::vector<Choice*> &args,
-                       Stage *before, Stage *after)
-{
-    if (n == 0) {
-        ref<PgfConcrLincat> lincat = lin->lincat;
-
-        size_t index = red->seq_idx / lincat->fields.size();
-        size_t r     = red->seq_idx % lincat->fields.size();
-        Production *prod = new(lin,index) Production();
-
-        for (size_t i = 0; i < prod->n_args; i++) {
-            auto arg = red->args.elem(i);
-
-            if (arg->stk_idx > 0) {
-                Choice *choice = args[red->depth-arg->stk_idx];
-                if (choice != NULL) {
-                    intersection_map im;
-                    choice = intersect_choice(choice, prod->args[i], im);
-                    if (choice == NULL) {
-                        //delete prod;
-                        return;
-                    }
-                }
-                prod->args[i] = choice;
-            }
-            if (arg->arg != 0) {
-                Choice *choice = retrieve_choice(arg->arg);
-                if (choice != NULL) {
-                    intersection_map im;
-                    choice = intersect_choice(choice, prod->args[i], im);
-                    if (choice == NULL) {
-                        //delete prod;
-                        return;
-                    }
-                }
-                prod->args[i] = choice;
-            }
-        }
-
-        if (!shift(parent, lincat, r, prod, before, after)) {
-            delete prod;
-        }
+    if (phrasetable == 0)
         return;
-    }
 
-    args.push_back(parent->choice);
-    for (auto node : parent->parents) {
-        reduce(node, lin, red, n-1, args, parent->stage, after);
-    }
-    args.pop_back();
-}
-
-PgfParser::Choice *PgfParser::retrieve_choice(ref<PgfLRReduceArg> arg)
-{
-    if (arg == 0)
-        return NULL;
-
-    Choice *&tmp   = persistant[arg.tagged()];
-    Choice *choice = tmp;
-    if (choice == NULL) {
-        tmp = new Choice(++last_fid); choice = tmp;
-        for (size_t i = 0; i < arg->n_prods; i++) {
-            Production *prod = new(arg->prods[i].lin, arg->prods[i].index) Production();
-            for (size_t j = 0; j < prod->n_args; j++) {
-                auto child = arg->prods[i].args[j];
-                prod->args[j] = retrieve_choice(child);
-            }
-            choice->prods.push_back(prod);
-#ifdef DEBUG_PARSER
-            print_prod(choice, prod);
-#endif
-        }
-    }
-
-    return choice;
-}
-
-void PgfParser::complete(StackNode *parent, ref<PgfConcrLincat> lincat, size_t r,
-                         size_t n, std::vector<Choice*> &args)
-{
-    if (n == 0) {
-        top_choice = args[0];
-        return;
-    }
-
-    args.push_back(parent->choice);
-    for (auto node : parent->parents) {
-        complete(node, lincat, r, n-1, args);
-    }
-    args.pop_back();
-}
-
-void PgfParser::reduce_all(StackNode *node)
-{
-    vector<PgfLRReduce> reductions = concr->lrtable[node->state_id].reductions;
-    for (size_t j = 0; j < reductions.size(); j++) {
-        ref<PgfLRReduce> red = reductions.elem(j);
-        switch (ref<PgfConcrLin>::get_tag(red->lin_obj)) {
-        case PgfConcrLin::tag: {
-            auto lin =
-                ref<PgfConcrLin>::untagged(red->lin_obj);
-            std::vector<Choice*> args;
-            reduce(node, lin, red, red->depth, args, before, before);
-            break;
-        }
-        case PgfConcrLincat::tag: {
-            auto lincat =
-                ref<PgfConcrLincat>::untagged(red->lin_obj);
-            std::vector<Choice*> args;
-            if (before->end.pos == sentence->size) {
-                complete(node, lincat, red->seq_idx % lincat->fields.size(), red->depth, args);
-            }
-        }
-        }
-    }
-}
-
-void PgfParser::space(PgfTextSpot *start, PgfTextSpot *end, PgfExn* err)
-{
-#ifdef DEBUG_PARSER
-    fprintf(stderr, "------------------ position %zu-%zu ------------------\n",
-                    start->pos, end->pos);
-#endif
-
-    while (ahead != NULL && ahead->start.pos <= start->pos) {
-        Stage *tmp = ahead->next;
-        ahead->next = before;
-        before = ahead;
-        ahead = tmp;
-    }
-
-    before->end = *end;
-
-    if (before->next != NULL && before->start.pos==before->end.pos) {
-        after = new Stage(*end);
-        after->next = before;
-        size_t i = 0;
-        while (i < before->nodes.size()) {
-            StackNode *node = before->nodes[i++];
-            reduce_all(node);
-            shift(node, before, after);
-        }
-        before = after;
-    }
-
-    size_t i = 0;
-    while (i < before->nodes.size()) {
-        StackNode *node = before->nodes[i++];
-        reduce_all(node);
-        shift(node, before);
-    }
-}
-
-void PgfParser::start_matches(PgfTextSpot *end, PgfExn* err)
-{
-    Stage **last = &ahead; after = *last;
-    while (after != NULL && after->start.pos < end->pos) {
-        last = &after->next; after = *last;
-    }
-
-    if (after == NULL) {
-        *last = new Stage(*end);
-        after = *last;
-    }
-}
-
-void PgfParser::match(ref<PgfConcrLin> lin, size_t seq_index, PgfExn* err)
-{
-    size_t index = seq_index / lin->lincat->fields.size();
-    size_t r     = seq_index % lin->lincat->fields.size();
-
-    for (StackNode *parent : before->nodes) {
-        Production *prod = new(lin,index) Production();
-        if (!shift(parent, lin->lincat, r, prod, before, after)) {
-            delete prod;
-        }
-    }
-}
-
-void PgfParser::end_matches(PgfTextSpot *end, PgfExn* err)
-{
-}
-
-bool PgfParser::CompareExprState::operator() (const ExprState *state1, const ExprState *state2) const {
-    return state1->prob > state2->prob;
-}
-
-void PgfParser::prepare()
-{
-    if (top_choice != NULL)
-        predict_expr_states(top_choice, 0);
-}
-
-void PgfParser::predict_expr_states(Choice *choice, prob_t outside_prob)
-{
-    for (Production *prod : choice->prods) {
-        ExprState *state = new ExprState;
-        state->choice = choice;
-        state->prod = prod;
-        state->n_args = 0;
-        state->expr = u->efun(&prod->lin->name);
-        state->prob = outside_prob+prod->lin->absfun->prob;
-        exprs.push_back(state->expr);
-        queue.push(state);
-    }
-}
-
-#ifdef DEBUG_GENERATOR
-void PgfParser::print_expr_state_before(PgfPrinter *printer, ExprState *state)
-{
-    if (state->choice->states.size() > 0) {
-        ExprState *parent = state->choice->states[0];
-        print_expr_state_before(printer, parent);
-        printer->puts(" [");
-    }
-    m->match_expr(printer, state->expr);
-}
-
-void PgfParser::print_expr_state_after(PgfPrinter *printer, ExprState *state)
-{
-    for (size_t i = state->n_args+1; i < state->prod->n_args; i++) {
-        if (state->prod->args[i] == NULL)
-            printer->puts(" ?");
-        else
-            printer->nprintf(32, " ?%d", state->prod->args[i]->fid);
-    }
-
-    if (state->choice->states.size() > 0) {
-        printer->puts("]");
-        ExprState *parent = state->choice->states[0];
-        print_expr_state_after(printer, parent);
-    }
-}
-
-void PgfParser::print_expr_state(ExprState *state)
-{
-    PgfPrinter printer(NULL, 0, m);
-
-    printer.nprintf(16, "[%f] ", state->prob);
-    print_expr_state_before(&printer, state);
-    if (state->n_args < state->prod->n_args) {
-        Choice *choice = state->prod->args[state->n_args];
-        if (choice == NULL)
-            printer.puts(" ?");
-        else
-            printer.nprintf(32, " ?%d", state->prod->args[state->n_args]->fid);
-    }
-    print_expr_state_after(&printer, state);
-    printer.puts("\n");
-
-    PgfText *text = printer.get_text();
-    fputs(text->text, stderr);
-    free(text);
-}
-#endif
-
-bool PgfParser::process_expr_state(ExprState *state)
-{
-    if (state->n_args >= state->prod->n_args) {
-        complete_expr_state(state);
-        return true;
-    }
-
-    Choice *choice = state->prod->args[state->n_args];
-    if (choice == NULL) {
-        PgfExpr meta = u->emeta(0);
-        PgfExpr app = u->eapp(state->expr, meta);
-        exprs.push_back(app);
-        u->free_ref(meta);
-        state->expr = app;
-        state->n_args++;
-        queue.push(state);
+    PgfTextSpot current = state->end;
+    int cmp;
+    if (state->needs_bind) {
+        uint8_t tag = ref<PgfSymbol>::get_tag(phrasetable->sym);
+        cmp = ((int) PgfSymbolBIND::tag) - ((int) tag);
     } else {
-        choice->states.push_back(state);
+        cmp = text_symbol_cmp(&current,end,phrasetable->sym,case_sensitive);
+    }
+    if (cmp < 0) {
+        bu_predict(phrasetable->left,state,min,max);
+    } else if (cmp > 0) {
+        ptrdiff_t len = current.ptr - state->end.ptr;
 
-        if (choice->states.size() == 1) {
-            predict_expr_states(choice, state->prob);
-        } else {
-            for (ExprInstance p : choice->exprs) {
-                combine_expr_state(state,p);
+        if (min <= len-1)
+            bu_predict(phrasetable->left,state,min,len-1);
+
+        if (len <= max)
+            bu_predict(phrasetable->right,state,len,max);
+    } else {
+        ptrdiff_t len = current.ptr - state->end.ptr;
+
+        if (min <= len)
+            bu_predict(phrasetable->left,state,min,len);
+
+        if (len > 0) {
+            for (size_t i = 0; i < phrasetable->n_items; i++) {
+                Item *item = bu_item(state, phrasetable->items[i]);
+                item->dot++;
+                if (item != NULL)
+                    process(item, current, false);
+            }
+        }
+
+        if (len <= max)
+            bu_predict(phrasetable->right,state,len,max);
+     }
+}
+
+void PgfParser::make_chunks(State *state, std::vector<CCat*> &chunks, prob_t prob)
+{
+    if (state->completed.size() == 0) {
+        ExprState *estate = new(chunks.size()) ExprState;
+        estate->expr   = u->emeta(0);
+        estate->prob   = prob;
+        estate->hash   = '?';
+        estate->res    = NULL;
+        estate->index  = 0;
+        estate->n_args = chunks.size();
+        for (size_t i = 0; i < estate->n_args; i++) {
+            estate->args[i] = chunks[estate->n_args-i-1];
+        }
+        queue.push_back(estate);
+        std::push_heap(queue.begin(), queue.end(), estate_comp);
+    }
+
+    for (auto it1 : state->completed) {
+        for (auto it2 : it1.second) {
+            for (auto it3 : it2.second) {
+                CCat *ccat = it3.second;
+                if (!ccat->covered && ccat->cont->state != state) {
+                    chunks.push_back(ccat);
+                    make_chunks(ccat->cont->state, chunks, prob+ccat->cont->lincat->abscat->prob);
+                    chunks.pop_back();
+                }
             }
         }
     }
-
-    return false;
 }
 
-void PgfParser::complete_expr_state(ExprState *state)
+void PgfParser::prepare(ref<PgfConcrLincat> start)
 {
-    Choice *choice = state->choice;
+    PgfTextSpot start_spot = {0, (uint8_t *) sentence->text};
+    State *state = new_state(start_spot);
+    state->needs_bind = false;
+    current_state = state;
 
-    prob_t outside_prob;
-    if (choice == top_choice)
-        outside_prob = 0;
-    else
-        outside_prob = choice->states[0]->prob;
-
-    prob_t inside_prob = state->prob-outside_prob;
-    choice->exprs.emplace_back(state->expr,inside_prob);
-    for (ExprState *state : choice->states) {
-        combine_expr_state(state,choice->exprs.back());
+    for (size_t i = start->n_lindefs; i < start->rules.size(); i++) {
+        ref<PgfConcrRule> rule = start->rules[i];
+        Item *item = new(rule) Item;
+        item->cont    = NULL;
+        item->dot     = 0;
+        item->pre_alt = 0;
+        item->pre_dot = 0;
+        item->syms    = rule->syms.as_vector();
+        item->rule    = rule;
+        process(item, start_spot, false);
     }
-}
 
-void PgfParser::combine_expr_state(ExprState *state, ExprInstance &inst)
-{
-    PgfExpr app = u->eapp(state->expr, inst.expr);
-    exprs.push_back(app);
+    while (current_state != NULL) {
+        bu_predict(concr->phrasetable, current_state, 1, sentence->size);
+        state = current_state;
+        current_state = current_state->next;
+    }
 
-    ExprState *app_state = new ExprState();
-    app_state->prob   = state->prob + inst.prob;
-    app_state->choice = state->choice;
-    app_state->prod   = state->prod;
-    app_state->n_args = state->n_args+1;
-    app_state->expr   = app;
-    queue.push(app_state);
+    if (queue.size() == 0) {
+        std::vector<CCat*> chunks;
+        make_chunks(state, chunks, 0);
+    }
 }
 
 PgfExpr PgfParser::fetch(PgfDB *db, prob_t *prob)
 {
     DB_scope scope(db, READER_SCOPE);
 
-    if (top_choice == NULL)
-        return 0;
+    while (queue.size() > 0) {
+        ExprState *estate = queue.front();
+        std::pop_heap(queue.begin(), queue.end(), estate_comp);
+        queue.pop_back();
 
-    for (;;) {
-        if (top_choice_index < top_choice->exprs.size()) {
-            auto inst = top_choice->exprs[top_choice_index++];
-            *prob = inst.prob;
-            return inst.expr;
-        }
-
-        if (queue.empty())
-            return 0;
-
-        ExprState *state = queue.top(); queue.pop();
-#ifdef DEBUG_GENERATOR
-        print_expr_state(state);
+#ifdef DEBUG_EXPRS
+        print_expr_state(m, estate);
 #endif
 
-        if (process_expr_state(state)) {
-            delete state;
-        }
+        PgfExpr expr = process_expr(estate, prob);
+        if (expr != 0)
+            return expr;
     }
-
     return 0;
 }
 
-PgfParser::~PgfParser()
+PgfExpr PgfParser::process_expr(ExprState *estate, prob_t *prob)
 {
-    while (before != NULL) {
-        Stage *tmp = before;
-        before = before->next;
-        delete tmp;
+    if (estate->index < estate->n_args) {
+        CCat *ccat = estate->args[estate->index];
+
+        if (ccat == NULL) {
+            ExprState *app_state = new(estate->n_args) ExprState;
+            app_state->expr   = estate->expr ? u->eapp(estate->expr, u->emeta(0)) : u->emeta(0);
+            app_state->prob   = estate->prob;
+            app_state->hash   = estate->hash * 101 + '?';
+            app_state->res    = estate->res;
+            app_state->index  = estate->index+1;
+            app_state->n_args = estate->n_args;
+            for (size_t i = 0; i < app_state->n_args; i++) {
+                app_state->args[i] = estate->args[i];
+            }
+            queue.push_back(app_state);
+            std::push_heap(queue.begin(), queue.end(), estate_comp);
+        } else {
+            ccat->pending.push_back(estate);
+
+            if (ccat->pending.size() == 1) {
+                for (Production *prod : ccat->prods) {
+                    auto lin = ref<PgfConcrLin>::untagged(prod->rule->container);
+
+                    ExprState *new_estate = new(prod->args.size()) ExprState;
+                    new_estate->expr   = u->efun(&lin->name);
+                    new_estate->prob   = estate->prob+lin->absfun->prob;
+                    new_estate->hash   = 0;
+                    new_estate->res    = ccat;
+                    new_estate->index  = 0;
+                    new_estate->n_args = prod->args.size();
+                    for (size_t i = 0; i < lin->name.size; i++) {
+                        new_estate->hash = new_estate->hash * 101 + lin->name.text[i];
+                    }
+                    for (size_t i = 0; i < new_estate->n_args; i++) {
+                        new_estate->args[i] = prod->args[i];
+                    }
+                    queue.push_back(new_estate);
+                    std::push_heap(queue.begin(), queue.end(), estate_comp);
+                }
+            } else {
+                for (ExprProb ep : ccat->exprs) {
+                    ExprState *app_state = new(estate->n_args) ExprState;
+                    app_state->expr  = estate->expr ? u->eapp(estate->expr, ep.expr) : ep.expr;
+                    app_state->prob  = estate->prob+ep.prob;
+                    app_state->hash  = estate->hash * 31 + ep.hash;
+                    app_state->res   = estate->res;
+                    app_state->index = estate->index+1;
+                    app_state->n_args= estate->n_args;
+                    for (size_t i = 0; i < app_state->n_args; i++) {
+                        app_state->args[i] = estate->args[i];
+                    }
+                    queue.push_back(app_state);
+                    std::push_heap(queue.begin(), queue.end(), estate_comp);
+                }
+            }
+        }
+    } else {
+        if (estate->res == NULL) {
+            *prob = estate->prob;
+            return estate->expr;
+        }
+
+        prob_t prob = estate->prob - estate->res->pending[0]->prob;
+        for (size_t i = estate->res->exprs.size(); i > 0; i--) {
+            ExprProb &ep = estate->res->exprs[i-1];
+            if (ep.prob != prob)
+                break;
+            if (ep.hash == estate->hash)
+                return 0;
+        }
+        
+        estate->res->exprs.emplace_back(estate->expr, prob, estate->hash);
+        for (ExprState *parent : estate->res->pending) {
+            ExprState *app_state = new(parent->n_args) ExprState;
+            app_state->expr  = parent->expr ? u->eapp(parent->expr, estate->expr) : estate->expr;
+            app_state->prob  = parent->prob+estate->prob;
+            app_state->hash  = parent->hash * 31 + estate->hash;
+            app_state->res   = parent->res;
+            app_state->index = parent->index+1;
+            app_state->n_args= parent->n_args;
+            for (size_t i = 0; i < app_state->n_args; i++) {
+                app_state->args[i] = parent->args[i];
+            }
+            queue.push_back(app_state);
+            std::push_heap(queue.begin(), queue.end(), estate_comp);
+        }
+    }
+    return 0;
+}
+
+PgfAbstractParser::State *PgfParser::new_state(const PgfTextSpot &start)
+{
+    State **prev = &first_state;
+    State *state = current_state;
+    while (state != NULL && state->start.ptr <= start.ptr) {
+        if (state->start.ptr == start.ptr)
+            return state;
+        prev  = &state->next;
+        state = state->next;
     }
 
-    while (ahead != NULL) {
-        Stage *tmp = ahead;
-        ahead = ahead->next;
-        delete tmp;
+    state = new State;
+    state->start = start;
+    state->end   = start;
+    state->next  = *prev;
+    *prev = state;
+
+    while (state->end.ptr < end) {
+        const uint8_t *ptr = state->end.ptr;
+        uint32_t ucs = pgf_utf8_decode(&ptr);
+        if (!pgf_utf8_is_space(ucs))
+            break;
+        state->end.pos++;
+        state->end.ptr = ptr;
     }
 
-    for (auto it : persistant) {
-        delete it.second;
+    state->needs_bind = (state->start.pos == state->end.pos);
+
+    return state;
+}
+
+void PgfParser::symbol_token(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym)
+{
+    PgfTextSpot next = spot;
+
+    const uint8_t *start = next.ptr;
+    for (;;) {
+        const uint8_t *ptr = next.ptr;
+        uint32_t ucs = pgf_utf8_decode(&ptr);
+        if (!pgf_utf8_is_space(ucs))
+            break;
+        next.ptr = ptr;
+        next.pos++;
     }
 
-    for (Choice *choice : dynamic) {
-        delete choice;
+    if (bind != (spot.ptr == next.ptr))
+        return;
+
+    if (text_symbol_cmp(&next,end,sym,case_sensitive) != 0)
+        return;
+
+    item->dot++;
+    process(item, next, false);
+}
+
+void PgfParser::symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym)
+{
+    item->dot++;
+    process(item, spot, true);
+}
+
+PgfAbstractParser::CCat *PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref<PgfSymbolCCat> arg)
+{
+    CCat *&ccat = state->completed[cont][arg->value][arg->lin_idx];
+    if (ccat == NULL) {
+        ccat = new CCat;
+        ccat->fid = (++last_fid);
+        ccat->cont  = cont;
+        ccat->state = state;
+        ccat->lin_idx = arg->lin_idx;
+        ccat->value = arg->value;
+        ccat->covered = true;
+
+#ifdef DEBUG_PARSER
+        {
+            PgfPrinter printer(NULL,0,NULL);
+            printer.nprintf(64,"[%zd-%zd; ",cont->state->end.pos,state->start.pos);
+            printer.efun(&ccat->cont->lincat->name);
+            printer.nprintf(64,"(%zd); %zd; ",ccat->value,ccat->lin_idx);
+            printer.emeta(ccat->fid);
+            printer.puts("]");
+            PgfText *text = printer.get_text();
+            fprintf(stderr, "%s\n", text->text);
+            free(text);
+        }
+#endif
+
+        size_t n_items = 0;
+        vector<ref<PgfItem>> items =
+            phrasetable_lookup(concr->phrasetable, arg.tagged(), &n_items);
+
+        for (size_t i = 0; i < n_items; i++) {
+            ref<PgfItem> pitem = items[i];
+
+            Production *prod = new (pitem) Production;
+            prod->rule = pitem->rule;
+            memcpy(&prod->vars[0], &pitem->vars[0], sizeof(size_t) * prod->vars.size());
+
+            for (size_t j = 0; j < pitem->args.size(); j++) {
+                ref<PgfSymbolCCat> arg = pitem->args[j];
+
+                prod->args[j] = 0;
+
+                if (arg != 0) {
+                    Cont *&arg_cont = state->conts1[arg->lincat];
+                    if (arg_cont == NULL) {
+                        arg_cont = new Cont;
+                        arg_cont->ccat = NULL;
+                        arg_cont->lincat = arg->lincat;
+                        arg_cont->state = state;
+                    }
+                    prod->args[j] =
+                        td_epsilon(state, arg_cont, arg);
+                }
+            }
+
+#ifdef DEBUG_PARSER
+            print_prod(ccat, prod);
+#endif
+            ccat->prods.push_back(prod);
+        }
     }
 
-    for (PgfExpr expr : exprs) {
-        u->free_ref(expr);
+    return ccat;
+}
+
+PgfAbstractParser::CCat *PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref<PgfSymbolCCat> arg,
+                                                       size_t n_items, vector<ref<PgfItem>> items)
+{
+    CCat *&ccat = state->completed[cont][arg->value][arg->lin_idx];
+    if (ccat == NULL) {
+        ccat = new CCat;
+        ccat->fid = (++last_fid);
+        ccat->cont  = cont;
+        ccat->state = state;
+        ccat->lin_idx = arg->lin_idx;
+        ccat->value = arg->value;
+        ccat->covered = true;
+
+#ifdef DEBUG_PARSER
+        {
+            PgfPrinter printer(NULL,0,NULL);
+            printer.nprintf(64,"[%zd-%zd; ",cont->state->end.pos,state->start.pos);
+            printer.efun(&ccat->cont->lincat->name);
+            printer.nprintf(64,"(%zd); %zd; ",ccat->value,ccat->lin_idx);
+            printer.emeta(ccat->fid);
+            printer.puts("]");
+            PgfText *text = printer.get_text();
+            fprintf(stderr, "%s\n", text->text);
+            free(text);
+        }
+#endif
+
+        for (size_t i = 0; i < n_items; i++) {
+            ref<PgfItem> pitem = items[i];
+
+            Production *prod = new (pitem) Production;
+            prod->rule = pitem->rule;
+            memcpy(&prod->vars[0], &pitem->vars[0], sizeof(size_t) * prod->vars.size());
+
+            for (size_t j = 0; j < pitem->args.size(); j++) {
+                ref<PgfSymbolCCat> arg = pitem->args[j];
+
+                prod->args[j] = 0;
+
+                if (arg != 0) {
+                    Cont *&arg_cont = state->conts1[arg->lincat];
+                    if (arg_cont == NULL) {
+                        arg_cont = new Cont;
+                        arg_cont->ccat = NULL;
+                        arg_cont->lincat = arg->lincat;
+                        arg_cont->state = state;
+                    }
+                    prod->args[j] =
+                        td_epsilon(state, arg_cont, arg);
+                }
+            }
+
+#ifdef DEBUG_PARSER
+            print_prod(ccat, prod);
+#endif
+            ccat->prods.push_back(prod);
+        }
     }
 
-    while (!queue.empty()) {
-        ExprState *state = queue.top(); queue.pop();
-        delete state;
+    return ccat;
+}
+
+void PgfAbstractParser::td_predict(State *state, Cont *cont, Production *prod, size_t lin_idx)
+{
+    switch (ref<object>::get_tag(prod->rule->container)) {
+    case PgfConcrLin::tag: {
+        auto lin = ref<PgfConcrLin>::untagged(prod->rule->container);
+
+        for (ref<PgfConcrRule> rule : lin->rules) {
+            Item *item = new (rule) Item;
+            item->cont    = cont;
+            item->dot     = 0;
+            item->pre_alt = 0;
+            item->pre_dot = 0;
+            item->syms    = rule->syms.as_vector();
+            item->rule    = rule;
+
+            if (!item->instantiate(item->rule->res, cont->ccat->value)) {
+                // delete item;
+                continue;
+            }
+
+            if (!item->instantiate(item->rule->lin_idx, lin_idx)) {
+                // delete item;
+                continue;
+            }
+
+            for (size_t i = 0; i < item->args.size(); i++) {
+                if (prod->args[i] != NULL) {
+                    if (!item->instantiate(item->rule->args[i], prod->args[i]->value)) {
+                        // delete item;
+                        goto next;
+                    }
+                } else {
+                    /*if (!item->instantiate(item->rule->args[i], prod->args[i]->value)) {
+                        delete item;
+                        continue;
+                    }*/
+                }
+                item->args[i] = prod->args[i];
+            }
+
+            process(item, state->start, false);
+        next:;
+        }
+    }
+    default:;
+        // should not happend
+    }
+}
+
+void PgfParser::suspend(State *state,ref<PgfConcrLincat> lincat,Item *item)
+{
+    Cont *&cont = state->conts1[lincat];
+    if (cont == NULL) {
+        cont = new Cont;
+        cont->ccat = NULL;
+        cont->lincat = lincat;
+        cont->state = state;
+    }
+
+    cont->suspended.push_back(item);
+
+    if (cont->suspended.size() == 1) {
+        std::function<void(ref<PgfSymbolCCat>,size_t,vector<ref<PgfItem>>)> f =
+            [this,state,item,cont](ref<PgfSymbolCCat> symcf, size_t n_items, vector<ref<PgfItem>> items) {
+
+                Item *new_item = new (item) Item;
+                PgfSymbol sym = new_item->rule->syms[new_item->dot];
+                auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
+                if (!new_item->instantiate(new_item->rule->args[sym_cat->d],symcf->value))
+                    return;
+                if (!new_item->instantiate(ref<PgfLParam>::from_ptr(&sym_cat->r),symcf->lin_idx))
+                    return;
+
+                new_item->dot++;
+                new_item->args[sym_cat->d] =
+                    td_epsilon(state,cont,symcf,n_items,items);
+
+                process(new_item, state->start, false);
+            };
+        phrasetable_iter(concr->phrasetable,lincat,f);
+    }
+}
+
+void PgfParser::final_item(State *state, Item *item, size_t value, size_t lin_idx)
+{
+    if (item->cont == NULL && state->end.ptr == end) {
+        ExprState *estate = new(item->args.size()) ExprState;
+        estate->expr   = 0;
+        estate->prob   = 0;
+        estate->hash   = 0;
+        estate->res    = NULL;
+        estate->index  = 0;
+        estate->n_args = item->args.size();
+        for (size_t i = 0; i < estate->n_args; i++) {
+            estate->args[i] = item->args[i];
+        }
+        queue.push_back(estate);
+        std::push_heap(queue.begin(), queue.end(), estate_comp);
+    }
+}
+
+#ifdef DEBUG_EXPRS
+void PgfParser::print_expr_state_left(PgfPrinter *printer, PgfMarshaller *m, ExprState *estate)
+{
+    if (estate->res && estate->res->pending.size() > 0) {
+        ExprState *parent = estate->res->pending[0];
+        print_expr_state_left(printer, m, parent);
+        printer->puts(" (");
+    }
+
+    if (estate->expr)
+        m->match_expr(printer, estate->expr);
+    else
+        printer->puts("::");
+}
+
+void PgfParser::print_expr_state_right(PgfPrinter *printer, PgfMarshaller *m, ExprState *estate)
+{
+    for (size_t i = estate->index+1; i < estate->n_args; i++) {
+        printer->puts(" ");
+        if (estate->args[i] != NULL)
+            printer->emeta(estate->args[i]->fid);
+        else
+            printer->puts("?");
+    }
+
+    if (estate->res && estate->res->pending.size() > 0) {
+        printer->puts(")");
+        ExprState *parent = estate->res->pending[0];
+        print_expr_state_right(printer, m, parent);
+    }
+}
+
+void PgfParser::print_expr_state(PgfMarshaller *m, ExprState *estate)
+{
+    PgfPrinter printer(NULL,0,m);
+    printer.nprintf(64,"[%f] ",estate->prob);
+    print_expr_state_left(&printer, m, estate);
+    printer.puts(" .");
+    print_expr_state_right(&printer, m, estate);
+
+    PgfText *text = printer.get_text();
+    fprintf(stderr, "%s\n", text->text);
+    free(text);    
+}
+#endif
+
+PgfParseTableMaker::PgfParseTableMaker(ref<PgfConcr> concr)
+    : PgfAbstractParser(concr)
+{
+    first_state = new State;
+    first_state->start.pos = 0;
+    first_state->start.ptr = NULL;
+    first_state->end       = first_state->start;
+    first_state->next      = NULL;
+    current_state = first_state;
+}
+
+ref<PgfItem> PgfParseTableMaker::clone_item(Item *item)
+{
+    size_t ex_size =
+        sizeof(ref<PgfSymbolCCat>) * item->args.size() +
+        sizeof(size_t)             * item->vars.size();
+    auto pitem = PgfDB::malloc<PgfItem>(ex_size);
+    pitem->pre_alt = item->pre_alt;
+    pitem->pre_dot = item->pre_dot;
+    pitem->dot     = item->dot;
+    pitem->rule    = item->rule;
+    memcpy(&pitem->vars[0],&item->vars[0],sizeof(size_t) * item->vars.size());
+    
+    for (size_t i = 0; i < item->args.size(); i++) {
+        ref<PgfSymbolCCat> symcf = 0;
+        if (item->args[i] != NULL) {
+            symcf = PgfDB::malloc<PgfSymbolCCat>();
+            symcf->lincat  = item->args[i]->cont->lincat;
+            symcf->value   = item->args[i]->value;
+            symcf->lin_idx = item->args[i]->lin_idx;
+        }
+        pitem->args[i] = symcf;
+    }
+
+    return pitem;
+}
+
+PgfAbstractParser::State *PgfParseTableMaker::new_state(const PgfTextSpot &start)
+{
+    return this->first_state;
+}
+
+void PgfParseTableMaker::symbol_token(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym)
+{
+    auto pitem = clone_item(item);
+    auto phrasetable = phrasetable_insert(concr->phrasetable,sym,pitem);
+    concr->phrasetable = phrasetable;
+}
+
+void PgfParseTableMaker::symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym)
+{
+    auto pitem = clone_item(item);
+    auto phrasetable = phrasetable_insert(concr->phrasetable,sym,pitem);
+    concr->phrasetable = phrasetable;
+}
+
+void PgfParseTableMaker::suspend(State *state,ref<PgfConcrLincat> lincat,Item *item)
+{
+    Cont *&cont = state->conts1[lincat];
+    if (cont == NULL) {
+        cont = new Cont;
+        cont->ccat = NULL;
+        cont->lincat = lincat;
+        cont->state = state;
+    }
+
+    cont->suspended.push_back(item);
+
+    for (auto it1 : state->completed[cont]) {
+        for (auto it2 : it1.second) {
+            CCat *ccat = it2.second;
+            if (ccat != NULL) {
+                Item *new_item = new (item) Item;
+                combine(state,new_item,ccat);
+            }
+        }
+    }
+
+    auto pitem = clone_item(item);
+    auto acat  = ref<PgfSymbolACat>::from_ptr((PgfSymbolACat*) &lincat->name);
+    auto phrasetable = phrasetable_insert(concr->phrasetable,acat.tagged(),pitem);
+    concr->phrasetable = phrasetable;
+}
+
+void PgfParseTableMaker::final_item(State *state, Item *item, size_t value, size_t lin_idx)
+{
+    auto pitem = clone_item(item);
+    
+    PgfPhrasetable phrasetable = concr->phrasetable;
+    phrasetable = phrasetable_insert(phrasetable,
+                                     item->cont->lincat, value, lin_idx,
+                                     pitem);
+    concr->phrasetable = phrasetable;
+}
+
+void PgfParseTableMaker::bu_predict(PgfPhrasetable phrasetable, State *state, CCat *ccat)
+{
+}
+
+void PgfParseTableMaker::insert_rule(ref<PgfConcrRule> rule)
+{    
+    switch (ref<object>::get_tag(rule->container)) {
+    case PgfConcrLin::tag: {
+        auto lin = ref<PgfConcrLin>::untagged(rule->container);
+
+        Cont *&cont = first_state->conts1[lin->lincat];
+        if (cont == NULL) {
+            cont = new Cont;
+            cont->ccat = NULL;
+            cont->lincat = lin->lincat;
+            cont->state = first_state;
+        }
+
+        Item *item = new(rule) Item;
+        item->cont    = cont;
+        item->dot     = 0;
+        item->pre_alt = 0;
+        item->pre_dot = 0;
+        item->syms    = rule->syms.as_vector();
+        item->rule    = rule;
+        return process(item, first_state->end, false);
+    }
     }
 }
diff --git a/src/runtime/c/pgf/parser.h b/src/runtime/c/pgf/parser.h
index c0bbd4773..1bbb2aa49 100644
--- a/src/runtime/c/pgf/parser.h
+++ b/src/runtime/c/pgf/parser.h
@@ -1,191 +1,294 @@
 #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;
-    PgfText *sentence;
-    bool case_sensitive;
-    PgfMarshaller *m;
-    PgfUnmarshaller *u;
+    typedef size_t hash_t;
 
-    struct Choice;
-    struct Production;
-    struct StackNode;
-    struct Stage;
+protected:
+    ref<PgfConcr> concr;
+
+    struct CCat;
+    struct Cont;
+    struct Item;
+    struct State;
     struct ExprState;
-    struct ExprInstance;
-    struct CompareExprState : std::less<ExprState*> {
-        bool operator() (const ExprState *state1, const ExprState *state2) const;
+
+    struct Production {
+        ref<PgfConcrRule> rule;
+
+        struct {
+            size_t &operator[](int i) {
+                Production *prod = containerof(Production,vars,this);
+                return ((size_t*) (((CCat**) (prod+1))+prod->args.size()))[i];
+            }
+            size_t size() {
+                Production *prod = containerof(Production,vars,this);
+                return prod->rule->vars.size();
+            }
+        } vars;
+
+        struct {
+            CCat *&operator[](int i) {
+                Production *prod = containerof(Production,args,this);
+                return ((CCat**) (prod+1))[i];
+            }
+            size_t size() {
+                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;
-    std::priority_queue<ExprState*, std::vector<ExprState*>, CompareExprState> queue;
-    int last_fid;
+    struct ExprProb {
+        PgfExpr expr;
+        prob_t prob;
+        hash_t hash;
+        
+        ExprProb(PgfExpr expr, prob_t prob, hash_t hash) {
+            this->expr = expr;
+            this->prob = prob;
+            this->hash = hash;
+        }
+    };
 
-    std::vector<Choice*> dynamic;
-    std::map<object,Choice*> persistant;
+    struct CCat {
+        PgfMetaId fid;
+        Cont *cont;
+        State *state;
+        size_t value;
+        size_t lin_idx;
+        bool covered;
+        std::vector<Production*> prods;
+        std::vector<ExprState*> pending;
+        std::vector<ExprProb> exprs;
 
-    std::vector<PgfExpr> exprs;
+        ~CCat();
+    };
 
-    Choice *top_choice;
-    size_t top_choice_index;
+    struct State {
+        PgfTextSpot start, end;
+        bool needs_bind;
+        std::map<ref<PgfConcrLincat>,Cont*> conts1;
+        std::map<CCat*,std::map<size_t,Cont*>> conts2;
+        std::map<Cont*,std::map<size_t,std::map<size_t,CCat*>>> completed;
+        State *next;
+    };
 
-    bool shift(StackNode *parent, ref<PgfConcrLincat> lincat, size_t r, Production *prod,
-               Stage *before, Stage *after);
-    void shift(StackNode *parent, Stage *before);
-    void shift(StackNode *parent, Stage *before, Stage *after);
-    void reduce(StackNode *parent, ref<PgfConcrLin> lin, ref<PgfLRReduce> red,
-                size_t n, std::vector<Choice*> &args,
-                Stage *before, Stage *after);
-    Choice *retrieve_choice(ref<PgfLRReduceArg> arg);
-    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);
+    struct Cont {
+        CCat *ccat;
+        ref<PgfConcrLincat> lincat;
+        State *state;
+        std::vector<Item*> suspended;
 
-    typedef std::map<std::pair<Choice*,Choice*>,Choice*> intersection_map;
+        ~Cont();
+    };
 
-    Choice *intersect_choice(Choice *choice1, Choice *choice2, intersection_map &im);
+    struct Item {
+        Cont *cont;
+        uint16_t pre_alt;
+        uint16_t pre_dot;
+        uint16_t dot;
+        vector<PgfSymbol> syms;
+        ref<PgfConcrRule> rule;
 
-    void print_expr_state_before(PgfPrinter *printer, ExprState *state);
-    void print_expr_state_after(PgfPrinter *printer, ExprState *state);
-    void print_expr_state(ExprState *state);
+        struct {
+            size_t &operator[](int i) {
+                Item *item = containerof(Item,vars,this);
+                return ((size_t*) (((CCat**) (item+1))+item->args.size()))[i];
+            }
+            size_t size() {
+                Item *item = containerof(Item,vars,this);
+                return item->rule->vars.size();
+            }
+        } vars;
 
-    void predict_expr_states(Choice *choice, prob_t outside_prob);
-    bool process_expr_state(ExprState *state);
-    void complete_expr_state(ExprState *state);
-    void combine_expr_state(ExprState *state, ExprInstance &inst);
+        struct {
+            CCat *&operator[](int i) {
+                Item *item = containerof(Item,args,this);
+                return ((CCat**) (item+1))[i];
+            }
+            size_t size() {
+                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->vars.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() {
+        }
+
+        bool instantiate(ref<PgfLParam> lparam,size_t value);
+        bool instantiate(ref<PgfLParam> lparam,ref<PgfLParam> value,Item *other);
+    };
+
+    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 *first_state, *current_state;
+    PgfMetaId last_fid;
+
+    void process(Item *item, const PgfTextSpot &spot, bool bind);
+    void symbol(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym);
+    void complete(Item *item, const PgfTextSpot &spot, bool bind);
+
+    virtual State *new_state(const PgfTextSpot &start)=0;
+    virtual void symbol_token(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym)=0;
+    virtual void symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym)=0;
+    virtual void suspend(State *state,ref<PgfConcrLincat> lincat, Item *item)=0;
+    virtual void final_item(State *state,Item *item,size_t value,size_t lin_idx)=0;
+
+    virtual void bu_predict(PgfPhrasetable phrasetable, State *state, CCat *ccat);
+    Item *bu_item(State *state, ref<PgfItem> pitem);
+    CCat *td_epsilon(State *state, Cont *cont, ref<PgfSymbolCCat> arg);
+    CCat *td_epsilon(State *state, Cont *cont, ref<PgfSymbolCCat> arg,
+                     size_t n_items, vector<ref<PgfItem>> items);
+    void td_predict(State *state, Cont *cont, Production *prod, size_t lin_idx);
+    void combine(State *state, Item *item, CCat *ccat);
+
+    static
+    void print_item(Item *item, const PgfTextSpot &spot);
+
+    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);
+    virtual void symbol_token(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym);
+    virtual void symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym);
+    virtual void suspend(State *state,ref<PgfConcrLincat> lincat, Item *item);
+    virtual void final_item(State *state,Item *item,size_t value,size_t lin_idx);
+
+    void bu_predict(PgfPhrasetable phrasetable, State *state, 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);
+
+    static
+    void print_expr_state_left(PgfPrinter *printer, PgfMarshaller *m, ExprState *estate);
+    static
+    void print_expr_state_right(PgfPrinter *printer, PgfMarshaller *m, ExprState *estate);
+    static
+    void print_expr_state(PgfMarshaller *m, ExprState *estate);
+
+    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);
-    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();
+    void prepare(ref<PgfConcrLincat> start);
 
     PgfExpr fetch(PgfDB *db, prob_t *prob);
 };
+
+class PGF_INTERNAL_DECL PgfParseTableMaker : private PgfAbstractParser
+{
+private:
+    virtual State *new_state(const PgfTextSpot &start);
+    virtual void symbol_token(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym);
+    virtual void symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym);
+    virtual void suspend(State *state,ref<PgfConcrLincat> lincat,Item *item);
+    virtual void final_item(State *state,Item *item,size_t value,size_t lin_idx);
+    virtual void bu_predict(PgfPhrasetable phrasetable, State *state, CCat *ccat);
+
+    static
+    ref<PgfItem> clone_item(Item *item);
+
+public:
+    PgfParseTableMaker(ref<PgfConcr> concr);
+    void insert_rule(ref<PgfConcrRule> rule);
+};
+
 #endif
diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx
index 6a332a295..0f2eacb2d 100644
--- a/src/runtime/c/pgf/pgf.cxx
+++ b/src/runtime/c/pgf/pgf.cxx
@@ -985,10 +985,10 @@ public:
     {
     }
 
-    virtual void match(ref<PgfConcrLin> lin, size_t seq_index, PgfExn* err)
+    virtual void match(ref<PgfConcrLin> lin, size_t lin_idx, PgfExn* err)
     {
         ref<PgfText> field =
-            lin->lincat->fields[seq_index % lin->lincat->fields.size()];
+            lin->lincat->fields[lin_idx];
         callback->fn(callback, &lin->absfun->name, field, lin->lincat->abscat->prob+lin->absfun->prob, err);
     }
 
@@ -1012,6 +1012,8 @@ void pgf_lookup_morpho(PgfDB *db, PgfConcrRevision cnc_revision,
         bool case_sensitive = pgf_is_case_sensitive(concr);
 
         PgfMorphoScanner scanner(callback);
+        size_t n_items;
+
         phrasetable_lookup(concr->phrasetable,
                            sentence, case_sensitive,
                            &scanner, err);
@@ -1069,24 +1071,22 @@ void pgf_lookup_cohorts(PgfDB *db, PgfConcrRevision cnc_revision,
 }
 
 PGF_API
-PgfPhrasetableIds *pgf_iter_sequences(PgfDB *db, PgfConcrRevision cnc_revision,
-                                      PgfSequenceItor *itor,
-                                      PgfMorphoCallback *callback,
-                                      PgfExn *err)
+void pgf_iter_sequences(PgfDB *db, PgfConcrRevision cnc_revision,
+                        PgfSequenceItor *itor,
+                        PgfMorphoCallback *callback,
+                        PgfExn *err)
 {
     PGF_API_BEGIN {
         DB_scope scope(db, READER_SCOPE);
         ref<PgfConcr> concr = db->revision2concr(cnc_revision);
 
-        PgfPhrasetableIds *seq_ids = new PgfPhrasetableIds();
+/*        PgfPhrasetableIds *seq_ids = new PgfPhrasetableIds();
         seq_ids->start(concr);
 
         phrasetable_iter(concr, concr->phrasetable, itor, callback, seq_ids, err);
 
-        return seq_ids;
+        return seq_ids; */
     } PGF_API_END
-
-    return NULL;
 }
 
 PGF_API
@@ -1095,7 +1095,7 @@ void pgf_get_lincat_counts_internal(object o, size_t *counts)
     ref<PgfConcrLincat> lincat = o;
     counts[0] = lincat->fields.size();
     counts[1] = lincat->n_lindefs;
-    counts[2] = lincat->res.size() - lincat->n_lindefs;
+    counts[2] = lincat->rules.size() - lincat->n_lindefs;
 }
 
 PGF_API
@@ -1106,59 +1106,50 @@ PgfText *pgf_get_lincat_field_internal(object o, size_t i)
 }
 
 PGF_API
-size_t pgf_get_lin_get_prod_count(object o)
+size_t pgf_get_lin_rules_count(object o)
 {
     ref<PgfConcrLin> lin = o;
-    return lin->res.size();
+    return lin->rules.size();
 }
 
 PGF_API
-PgfText *pgf_print_lindef_internal(PgfPhrasetableIds *seq_ids, object o, size_t i)
+PgfText *pgf_print_lindef_internal(object o, size_t i)
 {
     ref<PgfConcrLincat> lincat = o;
 
     PgfInternalMarshaller m;
     PgfPrinter printer(NULL,0,&m);
 
-    ref<PgfPResult> res = lincat->res[i];
-    if (res->vars != 0) {
-        printer.lvar_ranges(res->vars, NULL);
-        printer.puts(" . ");
+    ref<PgfConcrRule> rule = lincat->rules[i];
+    if (rule->vars != 0) {
+        printer.lvar_ranges(rule->vars, NULL);
+        printer.puts(" ");
     }
-
     printer.efun(&lincat->name);
     printer.puts("(");
-    printer.lparam(ref<PgfLParam>::from_ptr(&res->param));
+    printer.lparam(rule->res);
     printer.puts(") -> ");
     printer.efun(&lincat->name);
-    printer.puts("[String(0)] = [");
-
-    size_t n_seqs = lincat->fields.size();
-    for (size_t j = 0; j < n_seqs; j++) {
-		if (j > 0)
-			printer.puts(",");
-
-		ref<PgfSequence> seq = lincat->seqs[i*n_seqs + j];
-		printer.seq_id(seq_ids, seq);
-	}
-
-	printer.puts("]");
-
+    printer.puts("[String(0)]; ");
+    printer.lparam(rule->lin_idx);
+    printer.puts(" : ");
+    printer.symbols(rule->syms.as_vector());
     return printer.get_text();
 }
 
 PGF_API
-PgfText *pgf_print_linref_internal(PgfPhrasetableIds *seq_ids, object o, size_t i)
+PgfText *pgf_print_linref_internal(object o, size_t i)
 {
     ref<PgfConcrLincat> lincat = o;
 
     PgfInternalMarshaller m;
     PgfPrinter printer(NULL,0,&m);
 
-    ref<PgfPResult> res = lincat->res[lincat->n_lindefs+i];
-    if (res->vars != 0) {
-        printer.lvar_ranges(res->vars, NULL);
-        printer.puts(" . ");
+    ref<PgfConcrRule> rule = lincat->rules[lincat->n_lindefs+i];
+
+    if (rule->vars != 0) {
+        printer.lvar_ranges(rule->vars, NULL);
+        printer.puts(" ");
     }
 
     printer.puts("String(0) -> ");
@@ -1166,74 +1157,52 @@ PgfText *pgf_print_linref_internal(PgfPhrasetableIds *seq_ids, object o, size_t
     printer.puts("[");
     printer.efun(&lincat->name);
     printer.puts("(");
-    printer.lparam(lincat->args[lincat->n_lindefs+i].param);
-    printer.puts(")] = [");
+    printer.lparam(rule->args[0]);
+    printer.puts(")]; ");
 
-	size_t n_seqs = lincat->fields.size();
-	ref<PgfSequence> seq = lincat->seqs[lincat->n_lindefs*n_seqs+i];
-	printer.seq_id(seq_ids, seq);
-
-	printer.puts("]");
+    printer.lparam(rule->lin_idx);
+    printer.puts(" : ");
+    printer.symbols(rule->syms.as_vector());
 
     return printer.get_text();
 }
 
 PGF_API
-PgfText *pgf_print_lin_internal(PgfPhrasetableIds *seq_ids, object o, size_t i)
+PgfText *pgf_print_lin_internal(object o, size_t i)
 {
     ref<PgfConcrLin> lin = o;
 
     PgfInternalMarshaller m;
     PgfPrinter printer(NULL,0,&m);
 
-    ref<PgfPResult> res = lin->res[i];
+    ref<PgfConcrRule> rule = lin->rules[i];
     ref<PgfDTyp> ty = lin->absfun->type;
 
-    if (res->vars != 0) {
-        printer.lvar_ranges(res->vars, NULL);
-        printer.puts(" . ");
+    if (rule->vars != 0) {
+        printer.lvar_ranges(rule->vars, NULL);
+        printer.puts(" ");
     }
 
     printer.efun(&ty->name);
     printer.puts("(");
-    printer.lparam(ref<PgfLParam>::from_ptr(&res->param));
+    printer.lparam(rule->res);
     printer.puts(") -> ");
 
     printer.efun(&lin->name);
     printer.puts("[");
-    size_t n_args = lin->args.size() / lin->res.size();
-    for (size_t j = 0; j < n_args; j++) {
+    for (size_t j = 0; j < rule->args.size(); j++) {
         if (j > 0)
             printer.puts(",");
-        printer.parg(ty->hypos.elem(j)->type,
-                     lin->args.elem(i*n_args + j));
+        printer.efun(&ty->hypos.elem(j)->type->name);
+        printer.puts("(");
+        printer.lparam(rule->args[j]);
+        printer.puts(")");
     }
-    printer.puts("] = [");
+    printer.puts("]; ");
 
-    size_t n_seqs = lin->seqs.size() / lin->res.size();
-    for (size_t j = 0; j < n_seqs; j++) {
-		if (j > 0)
-			printer.puts(",");
-
-		ref<PgfSequence> seq = lin->seqs[i*n_seqs + j];
-		printer.seq_id(seq_ids, seq);
-	}
-
-	printer.puts("]");
-
-    return printer.get_text();
-}
-
-PGF_API
-PgfText *pgf_print_sequence_internal(size_t seq_id, object o)
-{
-    ref<PgfSequence> seq = o;
-
-    PgfInternalMarshaller m;
-    PgfPrinter printer(NULL,0,&m);
-
-	printer.nprintf(10,"S%zu = ", seq_id);
-	printer.sequence(seq);
+    printer.lparam(rule->lin_idx);
+    printer.puts(" : ");
+    printer.symbols(rule->syms.as_vector());
 
     return printer.get_text();
 }
@@ -1241,14 +1210,14 @@ PgfText *pgf_print_sequence_internal(size_t seq_id, object o)
 PGF_API
 PgfText *pgf_sequence_get_text_internal(object o)
 {
-    ref<PgfSequence> seq = o;
+    ref<PgfConcrRule> rule = o;
 
     PgfPrinter printer(NULL,0,NULL);
-    for (size_t i = 0; i < seq->syms.size(); i++) {
+    for (size_t i = 0; i < rule->syms.size(); i++) {
         if (i > 0)
             printer.puts(" ");
 
-        PgfSymbol sym = seq->syms[i];
+        PgfSymbol sym = rule->syms[i];
         switch (ref<PgfSymbol>::get_tag(sym)) {
         case PgfSymbolKS::tag: {
             auto sym_ks = ref<PgfSymbolKS>::untagged(sym);
@@ -1263,12 +1232,6 @@ PgfText *pgf_sequence_get_text_internal(object o)
     return printer.get_text();
 }
 
-PGF_API_DECL
-void pgf_release_phrasetable_ids(PgfPhrasetableIds *seq_ids)
-{
-	delete seq_ids;
-}
-
 PGF_API
 PgfExpr pgf_check_expr(PgfDB *db, PgfRevision revision,
                        PgfExpr e, PgfType ty,
@@ -1535,13 +1498,6 @@ void drop_lin(ref<PgfConcr> concr, PgfText *name)
     Namespace<PgfConcrLin> lins =
         namespace_delete(concr->lins, name, &lin);
     if (lin != 0) {
-        object container = lin.tagged();
-        for (size_t i = 0; i < lin->seqs.size(); i++) {
-            ref<PgfSequence> seq = lin->seqs[i];
-            PgfPhrasetable phrasetable =
-                phrasetable_delete(concr->phrasetable,container,i,seq);
-            concr->phrasetable = phrasetable;
-        }
         PgfConcrLin::release(lin);
     }
     concr->lins = lins;
@@ -1764,48 +1720,46 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision,
 class PGF_INTERNAL PgfLinBuilder : public PgfLinBuilderIface
 {
 	ref<PgfConcr> concr;
-
-    vector<PgfPArg> args;
-    vector<ref<PgfPResult>> res;
-    vector<ref<PgfSequence>> seqs;
+    vector<ref<PgfConcrRule>> rules;
 
     object container; // what are we building?
     ref<PgfConcrLincat> container_lincat;
 
     size_t var_index;
     size_t arg_index;
-    size_t res_index;
-    size_t seq_index;
     size_t sym_index;
     size_t alt_index;
 
     size_t n_lindefs;
     size_t n_linrefs;
 
-    ref<PgfSequence> seq;
+    size_t n_args;
+    size_t rule_index;
+
+    vector<PgfSymbol> syms;
 
     size_t pre_sym_index;
 
+    PgfParseTableMaker tm;
+
     const char *builder_error_msg =
         "Detected incorrect use of the linearization builder";
 
 public:
-    PgfLinBuilder(ref<PgfConcr> concr)
+    PgfLinBuilder(ref<PgfConcr> concr) : tm(concr)
     {
 		this->concr = concr;
 
-        this->args = 0;
-        this->res  = 0;
-        this->seqs = 0;
+        this->rules = 0;
         this->var_index = 0;
         this->arg_index = 0;
-        this->res_index = 0;
-        this->seq_index = 0;
         this->sym_index = (size_t) -1;
         this->alt_index = (size_t) -1;
         this->n_lindefs = 0;
         this->n_linrefs = 0;
-        this->seq = 0;
+        this->n_args = 0;
+        this->rule_index = 0;
+        this->syms = 0;
         this->pre_sym_index = (size_t) -1;
     }
 
@@ -1814,20 +1768,24 @@ public:
                               size_t n_lindefs, size_t n_linrefs,
                               PgfBuildLinIface *build, PgfExn *err)
     {
-        size_t n_prods = n_lindefs+n_linrefs;
-        this->args = vector<PgfPArg>::alloc(n_prods);
-        this->res  = vector<ref<PgfPResult>>::alloc(n_prods);
-        this->seqs = vector<ref<PgfSequence>>::alloc(n_lindefs*n_fields+n_linrefs);
+        this->var_index = 0;
+        this->arg_index = 0;
+        this->sym_index = (size_t) -1;
+        this->alt_index = (size_t) -1;
         this->n_lindefs = n_lindefs;
         this->n_linrefs = n_linrefs;
+        this->n_args = 1;
+        this->rule_index = 0;
+        this->syms = 0;
+        this->pre_sym_index = (size_t) -1;
+
+        this->rules = vector<ref<PgfConcrRule>>::alloc(n_lindefs+n_linrefs);
 
         ref<PgfConcrLincat> lincat = PgfDB::malloc<PgfConcrLincat>(abscat->name.size+1);
         memcpy(&lincat->name, &abscat->name, sizeof(PgfText)+abscat->name.size+1);
         lincat->abscat = abscat;
-        lincat->args = args;
-        lincat->res  = res;
-        lincat->seqs = seqs;
         lincat->n_lindefs = n_lindefs;
+        lincat->rules= this->rules;
 
         vector<ref<PgfText>> db_fields = vector<ref<PgfText>>::alloc(n_fields);
         for (size_t i = 0; i < n_fields; i++) {
@@ -1840,7 +1798,7 @@ public:
         this->container_lincat = 0;
 
         build->build(this, err);
-        if (err->type == PGF_EXN_NONE && res_index != res.size()) {
+        if (err->type == PGF_EXN_NONE && rule_index != rules.size()) {
             err->type = PGF_EXN_PGF_ERROR;
             err->msg  = builder_error_msg;
         }
@@ -1852,7 +1810,7 @@ public:
         return lincat;
     }
 
-    ref<PgfConcrLin> build(ref<PgfAbsFun> absfun, size_t n_prods,
+    ref<PgfConcrLin> build(ref<PgfAbsFun> absfun, size_t n_rules,
                            PgfBuildLinIface *build, PgfExn *err)
     {
         ref<PgfConcrLincat> lincat =
@@ -1861,24 +1819,32 @@ public:
             throw pgf_error("Missing linearization category");
         }
 
-        this->args = vector<PgfPArg>::alloc(n_prods*absfun->type->hypos.size());
-        this->res  = vector<ref<PgfPResult>>::alloc(n_prods);
-        this->seqs = vector<ref<PgfSequence>>::alloc(n_prods*lincat->fields.size());
-        this->n_lindefs = n_prods;
+        this->var_index = 0;
+        this->arg_index = 0;
+        this->sym_index = (size_t) -1;
+        this->alt_index = (size_t) -1;
+        this->n_lindefs = n_rules;
+        this->n_linrefs = n_linrefs;
+        this->n_args = 1;
+        this->rule_index = 0;
+        this->syms = 0;
+        this->pre_sym_index = (size_t) -1;
+
+        this->rules = vector<ref<PgfConcrRule>>::alloc(n_rules);
 
         ref<PgfConcrLin> lin = PgfDB::malloc<PgfConcrLin>(absfun->name.size+1);
         memcpy(&lin->name, &absfun->name, sizeof(PgfText)+absfun->name.size+1);
         lin->absfun = absfun;
         lin->lincat = lincat;
-        lin->args = args;
-        lin->res  = res;
-        lin->seqs = seqs;
+        lin->rules  = this->rules;
 
         this->container = lin.tagged();
         this->container_lincat = lincat;
 
+        this->n_args = absfun->type->hypos.size();
+
         build->build(this, err);
-        if (err->type == PGF_EXN_NONE && res_index != res.size()) {
+        if (err->type == PGF_EXN_NONE && rule_index != rules.size()) {
             err->type = PGF_EXN_PGF_ERROR;
             err->msg  = builder_error_msg;
         }
@@ -1890,26 +1856,43 @@ public:
         return lin;
     }
 
-    void start_production(PgfExn *err)
+    void start_rule(size_t n_vars, size_t n_syms, PgfExn *err)
     {
         if (err->type != PGF_EXN_NONE)
             return;
 
         PGF_API_BEGIN {
-            if (res_index >= res.size())
+            if (rule_index >= rules.size())
                 throw pgf_error(builder_error_msg);
+
+            vector<PgfVariableRange> vars = 
+                (n_vars > 0) ? vector<PgfVariableRange>::alloc(n_vars) : 0;
+            vector<ref<PgfLParam>> args =
+                (n_args > 0) ? vector<ref<PgfLParam>>::alloc(n_args) : 0;
+
+            ref<PgfConcrRule> rule = inline_vector<PgfSymbol>::alloc(&PgfConcrRule::syms, n_syms);
+            rule->vars = vars;
+            rule->res  = 0;
+            rule->container = container;
+            rule->args = args;
+            rule->lin_idx = 0;
+            rules[rule_index] = rule;
+
             var_index = 0;
-            res[res_index] = 0;
+            arg_index = 0;
+            sym_index = 0;
+
+            syms = rule->syms.as_vector();
         } PGF_API_END
     }
 
-    void add_argument(size_t n_hypos, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)
+    void add_argument(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)
     {
         if (err->type != PGF_EXN_NONE)
             return;
 
         PGF_API_BEGIN {
-            if (arg_index >= args.size())
+            if (rule_index >= rules.size() || rules[rule_index]->args == 0 || arg_index >= rules[rule_index]->args.size())
                 throw pgf_error(builder_error_msg);
 
             ref<PgfLParam> param = PgfDB::malloc<PgfLParam>(n_terms*2*sizeof(size_t));
@@ -1921,37 +1904,53 @@ public:
                 param->terms[i].var    = terms[2*i+1];
             }
 
-            ref<PgfPArg> parg = args.elem(arg_index);
-            parg->param = param;
+            rules[rule_index]->args[arg_index] = param;
 
             arg_index++;
         } PGF_API_END
     }
 
-    void set_result(size_t n_vars, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)
+    void set_result(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)
     {
         if (err->type != PGF_EXN_NONE)
             return;
 
         PGF_API_BEGIN {
-            if (res_index >= res.size())
+            if (rule_index >= rules.size() || rules[rule_index]->res != 0)
                 throw pgf_error(builder_error_msg);
 
-            vector<PgfVariableRange> vars =
-                (n_vars > 0) ? vector<PgfVariableRange>::alloc(n_vars)
-                             : 0;
-
-            ref<PgfPResult> res_elem = PgfDB::malloc<PgfPResult>(n_terms*2*sizeof(size_t));
-            res_elem->vars = vars;
-            res_elem->param.i0 = i0;
-            res_elem->param.n_terms = n_terms;
+            ref<PgfLParam> res = PgfDB::malloc<PgfLParam>(n_terms*2*sizeof(size_t));
+            res->i0 = i0;
+            res->n_terms = n_terms;
 
             for (size_t i = 0; i < n_terms; i++) {
-                res_elem->param.terms[i].factor = terms[2*i];
-                res_elem->param.terms[i].var    = terms[2*i+1];
+                res->terms[i].factor = terms[2*i];
+                res->terms[i].var    = terms[2*i+1];
             }
 
-            res[res_index] = res_elem;
+            rules[rule_index]->res = res;
+        } PGF_API_END
+    }
+
+    void set_lin_idx(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)
+    {
+        if (err->type != PGF_EXN_NONE)
+            return;
+
+        PGF_API_BEGIN {
+            if (rule_index >= rules.size() || rules[rule_index]->lin_idx != 0)
+                throw pgf_error(builder_error_msg);
+
+            ref<PgfLParam> lin_idx = PgfDB::malloc<PgfLParam>(n_terms*2*sizeof(size_t));
+            lin_idx->i0 = i0;
+            lin_idx->n_terms = n_terms;
+
+            for (size_t i = 0; i < n_terms; i++) {
+                lin_idx->terms[i].factor = terms[2*i];
+                lin_idx->terms[i].var    = terms[2*i+1];
+            }
+
+            rules[rule_index]->lin_idx = lin_idx;
         } PGF_API_END
     }
 
@@ -1961,16 +1960,16 @@ public:
             return;
 
         PGF_API_BEGIN {
-            if (res_index >= res.size())
+            if (rule_index >= rules.size())
                 throw pgf_error(builder_error_msg);
 
-            ref<PgfPResult> res_elem = res[res_index];
+            ref<PgfConcrRule> rule = rules[rule_index];
 
-            if (res_elem->vars == 0 || var_index >= res_elem->vars.size())
+            if (rule->vars == 0 || var_index >= rule->vars.size())
                 throw pgf_error(builder_error_msg);
 
             ref<PgfVariableRange> var_range =
-                res_elem->vars.elem(var_index);
+                rule->vars.elem(var_index);
             var_range->var   = var;
             var_range->range = range;
 
@@ -1978,29 +1977,16 @@ public:
         } PGF_API_END
     }
 
-    void start_sequence(size_t n_syms, PgfExn *err)
-    {
-        if (err->type != PGF_EXN_NONE)
-            return;
-
-        PGF_API_BEGIN {
-            if (seq_index >= seqs.size())
-                throw pgf_error(builder_error_msg);
-
-			seq = inline_vector<PgfSymbol>::alloc(&PgfSequence::syms, n_syms);
-
-            seqs[seq_index] = seq;
-            sym_index = 0;
-        } PGF_API_END
-    }
-
     void add_symcat(size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)
     {
         if (err->type != PGF_EXN_NONE)
             return;
 
         PGF_API_BEGIN {
-            if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size())
+            if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size())
+                throw pgf_error(builder_error_msg);
+
+            if (d > n_args)
                 throw pgf_error(builder_error_msg);
 
             ref<PgfSymbolCat> symcat = PgfDB::malloc<PgfSymbolCat>(n_terms*2*sizeof(size_t));
@@ -2013,7 +1999,7 @@ public:
                 symcat->r.terms[i].var    = terms[2*i+1];
             }
 
-            seq->syms[sym_index] = symcat.tagged();
+            syms[sym_index] = symcat.tagged();
             sym_index++;
         } PGF_API_END
     }
@@ -2024,7 +2010,10 @@ public:
             return;
 
         PGF_API_BEGIN {
-            if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size())
+            if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size())
+                throw pgf_error(builder_error_msg);
+
+            if (d > n_args)
                 throw pgf_error(builder_error_msg);
 
             ref<PgfSymbolLit> symlit = PgfDB::malloc<PgfSymbolLit>(n_terms*2*sizeof(size_t));
@@ -2037,7 +2026,7 @@ public:
                 symlit->r.terms[i].var    = terms[2*i+1];
             }
 
-            seq->syms[sym_index] = symlit.tagged();
+            syms[sym_index] = symlit.tagged();
             sym_index++;
         } PGF_API_END
     }
@@ -2048,14 +2037,17 @@ public:
             return;
 
         PGF_API_BEGIN {
-            if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size())
+            if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size())
+                throw pgf_error(builder_error_msg);
+
+            if (d > n_args)
                 throw pgf_error(builder_error_msg);
 
             ref<PgfSymbolVar> symvar = PgfDB::malloc<PgfSymbolVar>();
             symvar->d = d;
             symvar->r = r;
 
-            seq->syms[sym_index] = symvar.tagged();
+            syms[sym_index] = symvar.tagged();
             sym_index++;
         } PGF_API_END
     }
@@ -2066,13 +2058,13 @@ public:
             return;
 
         PGF_API_BEGIN {
-            if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size())
+            if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size())
                 throw pgf_error(builder_error_msg);
 
             ref<PgfSymbolKS> symtok = PgfDB::malloc<PgfSymbolKS>(token->size+1);
             memcpy(&symtok->token, token, sizeof(PgfText)+token->size+1);
 
-            seq->syms[sym_index] = symtok.tagged();
+            syms[sym_index] = symtok.tagged();
             sym_index++;
         } PGF_API_END
     }
@@ -2083,18 +2075,18 @@ public:
             return;
 
         PGF_API_BEGIN {
-            if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size() || pre_sym_index != (size_t) -1)
+            if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size() || pre_sym_index != (size_t) -1)
                 throw pgf_error(builder_error_msg);
 
-			ref<PgfSequence> def = inline_vector<PgfSymbol>::alloc(&PgfSequence::syms,n_syms);
+            vector<PgfSymbol> def = vector<PgfSymbol>::alloc(n_syms);
 
             ref<PgfSymbolKP> symkp = inline_vector<PgfAlternative>::alloc(&PgfSymbolKP::alts,n_alts);
             symkp->default_form = def;
 
-            seq->syms[sym_index] = symkp.tagged();
+            syms[sym_index] = symkp.tagged();
 
             pre_sym_index = sym_index;
-            seq = def;
+            syms = def;
             sym_index = 0;
             alt_index = 0;
         } PGF_API_END
@@ -2109,7 +2101,7 @@ public:
             if (pre_sym_index == (size_t) -1)
                 throw pgf_error(builder_error_msg);
 
-			ref<PgfSequence> form = inline_vector<PgfSymbol>::alloc(&PgfSequence::syms, n_syms);
+            vector<PgfSymbol> form = vector<PgfSymbol>::alloc(n_syms);
 
             vector<ref<PgfText>> prefixes = vector<ref<PgfText>>::alloc(n_prefs);
             for (size_t i = 0; i < n_prefs; i++) {
@@ -2117,14 +2109,14 @@ public:
                 prefixes[i] = pref;
             }
 
-            seq = seqs[seq_index];
-            ref<PgfSymbolKP> symkp = ref<PgfSymbolKP>::untagged(seq->syms[pre_sym_index]);
+            syms = rules[rule_index]->syms.as_vector();
+            ref<PgfSymbolKP> symkp = ref<PgfSymbolKP>::untagged(syms[pre_sym_index]);
             ref<PgfAlternative> alt = symkp->alts.elem(alt_index);
 
             alt->form     = form;
             alt->prefixes = prefixes;
 
-            seq = form;
+            syms = form;
             sym_index = 0;
         } PGF_API_END
     }
@@ -2138,8 +2130,8 @@ public:
             if (pre_sym_index == (size_t) -1)
                 throw pgf_error(builder_error_msg);
 
-            seq = seqs[seq_index];
-            ref<PgfSymbolKP> symkp = ref<PgfSymbolKP>::untagged(seq->syms[pre_sym_index]);            
+            syms = rules[rule_index]->syms.as_vector();
+            ref<PgfSymbolKP> symkp = ref<PgfSymbolKP>::untagged(syms[pre_sym_index]);            
             if (alt_index >= symkp->alts.size())
                 throw pgf_error(builder_error_msg);
 
@@ -2156,7 +2148,7 @@ public:
             if (pre_sym_index == (size_t) -1)
                 throw pgf_error(builder_error_msg);
 
-            seq = seqs[seq_index];
+            syms = rules[rule_index]->syms.as_vector();
             sym_index = pre_sym_index+1;
             alt_index = 0;
             pre_sym_index = (size_t) -1;
@@ -2169,10 +2161,10 @@ public:
             return;
 
         PGF_API_BEGIN {
-            if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size())
+            if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size())
                 throw pgf_error(builder_error_msg);
 
-            seq->syms[sym_index] = ref<PgfSymbolBIND>(0).tagged();
+            syms[sym_index] = ref<PgfSymbolBIND>(0).tagged();
             sym_index++;
         } PGF_API_END
     }
@@ -2183,10 +2175,10 @@ public:
             return;
 
         PGF_API_BEGIN {
-            if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size())
+            if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size())
                 throw pgf_error(builder_error_msg);
 
-            seq->syms[sym_index] = ref<PgfSymbolSOFTBIND>(0).tagged();
+            syms[sym_index] = ref<PgfSymbolSOFTBIND>(0).tagged();
             sym_index++;
         } PGF_API_END
     }
@@ -2197,10 +2189,10 @@ public:
             return;
 
         PGF_API_BEGIN {
-            if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size())
+            if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size())
                 throw pgf_error(builder_error_msg);
 
-            seq->syms[sym_index] = ref<PgfSymbolNE>(0).tagged();
+            syms[sym_index] = ref<PgfSymbolNE>(0).tagged();
             sym_index++;
         } PGF_API_END
     }
@@ -2211,10 +2203,10 @@ public:
             return;
 
         PGF_API_BEGIN {
-            if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size())
+            if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size())
                 throw pgf_error(builder_error_msg);
 
-            seq->syms[sym_index] = ref<PgfSymbolSOFTSPACE>(0).tagged();
+            syms[sym_index] = ref<PgfSymbolSOFTSPACE>(0).tagged();
             sym_index++;
         } PGF_API_END
     }
@@ -2225,10 +2217,10 @@ public:
             return;
 
         PGF_API_BEGIN {
-            if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size())
+            if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size())
                 throw pgf_error(builder_error_msg);
 
-            seq->syms[sym_index] = ref<PgfSymbolCAPIT>(0).tagged();
+            syms[sym_index] = ref<PgfSymbolCAPIT>(0).tagged();
             sym_index++;
         } PGF_API_END
     }
@@ -2239,79 +2231,38 @@ public:
             return;
 
         PGF_API_BEGIN {
-            if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size())
+            if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size())
                 throw pgf_error(builder_error_msg);
 
-            seq->syms[sym_index] = ref<PgfSymbolALLCAPIT>(0).tagged();
+            syms[sym_index] = ref<PgfSymbolALLCAPIT>(0).tagged();
             sym_index++;
         } PGF_API_END
     }
 
-    object end_sequence(PgfExn *err)
-    {
-        if (err->type != PGF_EXN_NONE)
-            return 0;
-
-        ref<PgfPhrasetableEntry> entry = 0;
-
-        PGF_API_BEGIN {
-            if (seq == 0 || sym_index != seq->syms.size())
-                throw pgf_error(builder_error_msg);
-
-            PgfPhrasetable phrasetable =
-				phrasetable_internalize(concr->phrasetable,
-                                        seq, container_lincat, container, seq_index,
-                                        &entry);
-            concr->phrasetable = phrasetable;
-            seqs[seq_index] = entry->seq;
-
-            sym_index = (size_t) -1;
-            seq = 0;
-            seq_index++;
-        } PGF_API_END
-
-        return entry.as_object();
-    }
-
-    void add_sequence_id(object seq_id, PgfExn *err)
+    void end_rule(PgfExn *err)
     {
         if (err->type != PGF_EXN_NONE)
             return;
 
         PGF_API_BEGIN {
-            if (seq_index >= seqs.size())
+            if (rule_index >= rules.size())
                 throw pgf_error(builder_error_msg);
 
-            ref<PgfPhrasetableEntry> entry = seq_id;
-            phrasetable_add_backref(entry,PgfDB::get_txn_id(),container,seq_index);
-
-            seqs[seq_index] = entry->seq;
-
-            seq_index++;
-        } PGF_API_END
-	}
-
-    void end_production(PgfExn *err)
-    {
-        if (err->type != PGF_EXN_NONE)
-            return;
-
-        PGF_API_BEGIN {
-            size_t n_args = (args.size()/res.size());
-            if (arg_index != (res_index+1)*n_args)
+            ref<PgfConcrRule> rule = rules[rule_index];
+            if (rule->res == 0)
                 throw pgf_error(builder_error_msg);
 
-            if (res[res_index] == 0)
+            if (arg_index < n_args)
                 throw pgf_error(builder_error_msg);
 
-            size_t n_seqs = ((seqs.size()-n_linrefs)/(res.size()-n_linrefs));
-            size_t exp_index =
-                     (res_index < n_lindefs) ? (res_index+1)*n_seqs
-                                             : n_seqs * n_lindefs + (res_index-n_lindefs+1) ;
-            if (seq_index != exp_index)
-                throw pgf_error(builder_error_msg);
+            if ((ref<PgfConcrLin>::get_tag(rule->container) == PgfConcrLin::tag) ||
+                (rule_index < n_lindefs)) {
+                /*PgfParseIndex parse_index =
+                    parse_index_insert(concr->parse_index, rule);
+                concr->parse_index = parse_index;*/
+            }
 
-            res_index++;
+            rule_index++;
         } PGF_API_END
     }
 };
@@ -2375,16 +2326,6 @@ void pgf_drop_lincat(PgfDB *db,
                 };
             probspace_iter(pgf->abstract.funs_by_cat, name, f, true);
 
-            // Remove the sequences comprizing the lindef and linref
-            object container = lincat.tagged();
-            PgfPhrasetable phrasetable = concr->phrasetable;
-            for (size_t i = 0; i < lincat->seqs.size(); i++) {
-                ref<PgfSequence> seq = lincat->seqs[i];
-                phrasetable =
-                    phrasetable_delete(phrasetable,container,i,seq);
-            }
-            concr->phrasetable = phrasetable;
-
             // Finaly remove the lincat object itself.
             PgfConcrLincat::release(lincat);
         }
@@ -2395,11 +2336,11 @@ void pgf_drop_lincat(PgfDB *db,
 PGF_API
 void pgf_create_lin(PgfDB *db,
                     PgfRevision revision, PgfConcrRevision cnc_revision,
-                    PgfText *name, size_t n_prods,
+                    PgfText *name, size_t n_rules,
                     PgfBuildLinIface *build,
                     PgfExn *err)
 {
-    if (n_prods == 0)
+    if (n_rules == 0)
         return;
 
     PGF_API_BEGIN {
@@ -2415,7 +2356,7 @@ void pgf_create_lin(PgfDB *db,
         }
 
         ref<PgfConcrLin> lin =
-            PgfLinBuilder(concr).build(absfun, n_prods, build, err);
+            PgfLinBuilder(concr).build(absfun, n_rules, build, err);
         if (lin != 0) {
             Namespace<PgfConcrLin> lins =
                 namespace_insert(concr->lins, lin);
@@ -2430,7 +2371,7 @@ void pgf_create_lin(PgfDB *db,
 PGF_API
 void pgf_alter_lin(PgfDB *db,
                    PgfRevision revision, PgfConcrRevision cnc_revision,
-                   PgfText *name, size_t n_prods,
+                   PgfText *name, size_t n_rules,
                    PgfBuildLinIface *build,
                    PgfExn *err)
 {
@@ -2447,21 +2388,13 @@ void pgf_alter_lin(PgfDB *db,
         }
 
         ref<PgfConcrLin> lin =
-            PgfLinBuilder(concr).build(absfun, n_prods, build, err);
+            PgfLinBuilder(concr).build(absfun, n_rules, build, err);
         if (lin != 0) {
             ref<PgfConcrLin> old_lin;
             Namespace<PgfConcrLin> lins =
                 namespace_replace(concr->lins, lin, &old_lin);
             concr->lins = lins;
             if (old_lin != 0) {
-                object container = old_lin.tagged();
-                PgfPhrasetable phrasetable = concr->phrasetable;
-                for (size_t i = 0; i < old_lin->seqs.size(); i++) {
-                    ref<PgfSequence> seq = old_lin->seqs[i];
-                    phrasetable =
-                        phrasetable_delete(phrasetable,container,i,seq);
-                }
-                concr->phrasetable = phrasetable;
                 PgfConcrLin::release(old_lin);
             }
         }
@@ -2757,11 +2690,8 @@ PgfExprEnum *pgf_parse(PgfDB *db, PgfConcrRevision revision,
         if (lincat_u.lincat == 0)
             return 0;
 
-        PgfParser *parser = new PgfParser(concr, lincat_u.lincat, sentence, case_sensitive, m, u);
-        phrasetable_lookup_cohorts(concr->phrasetable,
-                                   sentence, case_sensitive,
-                                   parser, err);
-        parser->prepare();
+        PgfParser *parser = new PgfParser(concr, sentence, case_sensitive, m, u);
+        parser->prepare(lincat_u.lincat);
         return parser;
     } PGF_API_END
 
@@ -3122,91 +3052,3 @@ pgf_align_words(PgfDB *db, PgfConcrRevision revision,
 
     return NULL;
 }
-
-PGF_API PgfText *
-pgf_graphviz_lr_automaton(PgfDB *db, PgfConcrRevision revision,
-                          PgfExn *err)
-{
-    PGF_API_BEGIN {
-        DB_scope scope(db, READER_SCOPE);
-
-        ref<PgfConcr> concr = db->revision2concr(revision);
-
-        PgfPrinter printer(NULL,0,NULL);
-        
-        printer.puts("digraph {\n");
-        for (size_t i = 0; i < concr->lrtable.size(); i++) {
-            ref<PgfLRState> state = concr->lrtable.elem(i);
-
-            printer.nprintf(16, "  s%zu [label=\"", i);
-            for (size_t j = 0; j < state->reductions.size(); j++) {
-                ref<PgfLRReduce> reduce = state->reductions.elem(j);
-                
-                switch (ref<PgfConcrLin>::get_tag(reduce->lin_obj)) {
-                case PgfConcrLin::tag: {
-                    auto lin =
-                        ref<PgfConcrLin>::untagged(reduce->lin_obj);
-                    printer.efun(&lin->name);
-                    break;
-                }
-                case PgfConcrLincat::tag: {
-                    auto lincat =
-                        ref<PgfConcrLincat>::untagged(reduce->lin_obj);
-                    printer.puts("linref ");
-                    printer.efun(&lincat->name);
-                    break;
-                }
-                }
-
-                printer.puts("[");
-                for (size_t i = 0; i < reduce->args.size(); i++) {
-                    ref<PgfLRReduce::Arg> arg = reduce->args.elem(i);
-                    if (i > 0)
-                        printer.puts(",");
-                    if (arg->arg == 0 && arg->stk_idx == 0) {
-                        printer.nprintf(32,"?");
-                    } else {
-                        if (arg->arg != 0)
-                            printer.nprintf(32,"?%zd",arg->arg->id);
-                        if (arg->stk_idx != 0)
-                            printer.nprintf(32,"$%zd",arg->stk_idx);
-                    }
-                }
-                printer.nprintf(32,"] %zd\n",reduce->depth);
-            }
-            printer.puts("\"");
-            if (i == 0) printer.puts(",penwidth=3");
-            printer.nprintf(16, "]\n");
-
-            for (size_t j = 0; j < state->shifts.size(); j++) {
-                ref<PgfLRShift> shift = state->shifts.elem(j);
-                printer.nprintf(16, "  s%zu -> s%zu [label=\"", i, shift->next_state);
-                printer.efun(&shift->lincat->name);
-                printer.nprintf(16, ".%zu\"];\n", shift->r);
-            }
-
-            for (size_t j = 0; j < state->tokens.size(); j++) {
-                ref<PgfLRShiftKS> shift = state->tokens.elem(j);
-                printer.nprintf(16, "  s%zu -> s%zu [label=\"", i, shift->next_state);
-                size_t sym_idx = shift->sym_idx;
-                while (sym_idx < shift->seq->syms.size()) {
-                    if (ref<PgfSymbol>::get_tag(shift->seq->syms[sym_idx]) != PgfSymbolKS::tag)
-                        break;
-                    if (sym_idx > shift->sym_idx)
-                        printer.puts(" ");
-                    auto symks = ref<PgfSymbolKS>::untagged(shift->seq->syms[sym_idx]);
-                    printer.puts("\\\"");
-                    printer.put_esc_str(&symks->token);
-                    printer.puts("\\\"");
-                    sym_idx++;
-                }
-                printer.puts("\"];\n");
-            }
-        }
-        printer.puts("}");
-
-        return printer.get_text();
-    } PGF_API_END
-
-    return NULL;
-}
diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h
index 3c41c6e26..8bc2ddede 100644
--- a/src/runtime/c/pgf/pgf.h
+++ b/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,
-                                      PgfSequenceItor *itor,
-                                      PgfMorphoCallback *callback,
-                                      PgfExn *err);
+void pgf_iter_sequences(PgfDB *db, PgfConcrRevision cnc_revision,
+                        PgfSequenceItor *itor,
+                        PgfMorphoCallback *callback,
+                        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);
-
-PGF_API_DECL
-PgfText *pgf_print_sequence_internal(size_t seq_id, object o);
+PgfText *pgf_print_lin_internal(object o, size_t i);
 
 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,
@@ -635,11 +627,11 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision,
 
 #ifdef __cplusplus
 struct PgfLinBuilderIface {
-    virtual void start_production(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 set_result(size_t n_vars, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
+    virtual void start_rule(size_t n_vars, size_t n_syms, 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 i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
+    virtual void set_lin_idx(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 start_sequence(size_t n_syms, 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 +646,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 add_sequence_id(object seq_id, PgfExn *err)=0;
-    virtual void end_production(PgfExn *err)=0;
+    virtual void end_rule(PgfExn *err)=0;
 };
 
 struct PgfBuildLinIface {
@@ -666,11 +656,11 @@ struct PgfBuildLinIface {
 typedef struct PgfLinBuilderIface PgfLinBuilderIface;
 
 typedef struct {
-    void (*start_production)(PgfLinBuilderIface *this, PgfExn *err);
-    void (*add_argument)(PgfLinBuilderIface *this, size_t n_hypos, 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 (*start_rule)(PgfLinBuilderIface *this, size_t n_vars, size_t n_syms, 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 i0, size_t n_terms, size_t *terms, PgfExn *err);
+    void (*set_lin_idx)(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 (*start_sequence)(PgfLinBuilderIface *this, size_t n_syms, 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 +675,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 (*add_sequence_id)(PgfLinBuilderIface *this, object seq_id, PgfExn *err);
-    void (*end_production)(PgfLinBuilderIface *this, PgfExn *err);
+    void (*end_rule)(PgfLinBuilderIface *this, PgfExn *err);
 } PgfLinBuilderIfaceVtbl;
 
 struct PgfLinBuilderIface {
@@ -720,10 +708,17 @@ 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,
+                    PgfText *name, size_t n_rules,
                     PgfBuildLinIface *build,
                     PgfExn *err);
 
+PGF_API_DECL
+void pgf_alter_lin(PgfDB *db,
+                   PgfRevision revision, PgfConcrRevision cnc_revision,
+                   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 +911,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_
diff --git a/src/runtime/c/pgf/phrasetable.cxx b/src/runtime/c/pgf/phrasetable.cxx
index 49e7c95c7..86a8cfffb 100644
--- a/src/runtime/c/pgf/phrasetable.cxx
+++ b/src/runtime/c/pgf/phrasetable.cxx
@@ -1,77 +1,8 @@
 #include "data.h"
+#include "printer.h"
 #include <queue>
 
-PgfPhrasetableIds::PgfPhrasetableIds()
-{
-	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;
-}
+// #define DEBUG_PARSE_INDEX
 
 static
 int lparam_cmp(PgfLParam *p1, PgfLParam *p2)
@@ -101,7 +32,7 @@ int lparam_cmp(PgfLParam *p1, PgfLParam *p2)
 }
 
 static
-int sequence_cmp(ref<PgfSequence> seq1, ref<PgfSequence> seq2);
+int sequence_cmp(vector<PgfSymbol> seq1, vector<PgfSymbol> seq2);
 
 static
 void symbol_cmp(PgfSymbol sym1, PgfSymbol sym2, int res[2])
@@ -202,25 +133,49 @@ void symbol_cmp(PgfSymbol sym1, PgfSymbol sym2, int res[2])
 	case PgfSymbolCAPIT::tag:
 	case PgfSymbolALLCAPIT::tag:
         break;
+    case PgfSymbolACat::tag: {
+        auto sym_acat1 = ref<PgfSymbolACat>::untagged(sym1);
+        auto sym_acat2 = ref<PgfSymbolACat>::untagged(sym2);
+        res[0] = (res[1] = textcmp(&sym_acat1->name,&sym_acat2->name));
+        return;
+    }
+    case PgfSymbolCCat::tag: {
+        auto sym_ccat1 = ref<PgfSymbolCCat>::untagged(sym1);
+        auto sym_ccat2 = ref<PgfSymbolCCat>::untagged(sym2);
+        res[0] = (res[1] = textcmp(&sym_ccat1->lincat->name,&sym_ccat2->lincat->name));
+        if (res[0] != 0)
+            return;
+        if (sym_ccat1->value < sym_ccat2->value)
+			res[0] = (res[1] = -1);
+        else if (sym_ccat1->value > sym_ccat2->value)
+			res[0] = (res[1] = 1);
+        if (sym_ccat1->lin_idx < sym_ccat2->lin_idx)
+			res[0] = (res[1] = -1);
+        else if (sym_ccat1->lin_idx > sym_ccat2->lin_idx)
+			res[0] = (res[1] = 1);
+        else
+            res[0] = (res[1] = 0);
+        return;
+    }
 	default:
 		throw pgf_error("Unknown symbol tag");
     }
 }
 
 static
-int sequence_cmp(ref<PgfSequence> seq1, ref<PgfSequence> seq2)
+int sequence_cmp(vector<PgfSymbol> seq1, vector<PgfSymbol> seq2)
 {
 	int res[2] = {0,0};
 	for (size_t i = 0; ; i++) {
-        if (i >= seq1->syms.size()) {
-			if (i < seq2->syms.size())
+        if (i >= seq1.size()) {
+			if (i < seq2.size())
 				return -1;
             return res[1];
 		}
-        if (i >= seq2->syms.size())
+        if (i >= seq2.size())
             return 1;
 
-		symbol_cmp(seq1->syms[i], seq2->syms[i], res);
+		symbol_cmp(seq1[i], seq2[i], res);
 		if (res[0] != 0)
 			return res[0];
     }
@@ -229,67 +184,33 @@ int sequence_cmp(ref<PgfSequence> seq1, ref<PgfSequence> seq2)
 }
 
 PGF_INTERNAL
-int text_sequence_cmp(PgfTextSpot *spot, const uint8_t *end,
-                      ref<PgfSequence> seq, size_t *p_i,
-                      bool case_sensitive, SeqMatch sm)
+int text_symbol_cmp(PgfTextSpot *spot, const uint8_t *end,
+                    PgfSymbol sym, bool case_sensitive)
 {
-	int res1 = 0;
+    uint8_t tag = ref<PgfSymbol>::get_tag(sym);
+    if (PgfSymbolKS::tag != tag)
+        return ((int) PgfSymbolKS::tag) - ((int) tag);
 
-    const uint8_t *s2 = NULL;
-    const uint8_t *e2 = NULL;
+    int res1 = 0;
 
-    uint8_t t = 0xff;
-    if (*p_i < seq->syms.size()) {
-        t = ref<PgfSymbol>::get_tag(seq->syms[*p_i]);
-    }
-
-    size_t count = 0;
+    auto sym_ks = ref<PgfSymbolKS>::untagged(sym);
+    const uint8_t *s2 = (uint8_t *) &sym_ks->token.text;
+    const uint8_t *e2 = s2+sym_ks->token.size;
 
     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) {
-            return (sm == SM_FULL_MATCH) ? 1 : 0;
+        if (s2 >= e2) {
+            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,179 +230,429 @@ 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;
+    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
-void phrasetable_add_backref(ref<PgfPhrasetableEntry> entry, txn_t txn_id,
-                             object container,
-                             size_t seq_index)
+static
+int symbol_cmp(ref<PgfConcrLincat> lincat, size_t value, size_t lin_idx, PgfSymbol sym)
 {
-    vector<PgfSequenceBackref> backrefs = entry->backrefs;
+    uint8_t tag = ref<PgfSymbol>::get_tag(sym);
+    if (PgfSymbolCCat::tag != tag)
+        return ((int) PgfSymbolCCat::tag) - ((int) tag);
 
-    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,
-                                       ref<PgfSequence> seq,
-                                       ref<PgfConcrLincat> lincat,
-                                       object container,
-                                       size_t seq_index,
-                                       ref<PgfPhrasetableEntry> *pentry)
-{
-    if (table == 0) {
-        PgfPhrasetableEntry entry;
-        entry.seq = seq;
-        entry.n_backrefs = 1;
-        entry.backrefs = vector<PgfSequenceBackref>::alloc(1);
-        entry.backrefs[0].container = container;
-        entry.backrefs[0].seq_index = seq_index;
-        PgfPhrasetable new_table = Node<PgfPhrasetableEntry>::new_node(entry);
-        *pentry = ref<PgfPhrasetableEntry>::from_ptr(&new_table->value);
-        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)
+    auto symcf = ref<PgfSymbolCCat>::untagged(sym);
+    int res = textcmp(&lincat->name, &symcf->lincat->name);
+    if (res != 0)
+        return res;
+    if (value < symcf->value)
+        return -1;
+    else if (value > symcf->value)
+        return 1;
+    else if (lin_idx < symcf->lin_idx)
+        return -1;
+    else if (lin_idx > symcf->lin_idx)
+        return 1;
+    else
         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--;
+static
+int symbol_cmp(PgfSymbol sym1, PgfSymbol sym2)
+{
+    uint8_t tag1 = ref<PgfSymbol>::get_tag(sym1);
+    uint8_t tag2 = ref<PgfSymbol>::get_tag(sym2);
+    if (tag1 != tag2)
+        return ((int) tag1) - ((int) tag2);
 
-            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;
+    switch (tag1) {
+    case PgfSymbolKS::tag: {
+        auto symks1 = ref<PgfSymbolKS>::untagged(sym1);
+        auto symks2 = ref<PgfSymbolKS>::untagged(sym2);
+        int res[2] = {0,0};
+        texticmp(&symks1->token, &symks2->token, res);
+        if (res[0] != 0)
+            return res[0];
+        return res[1];
+    }
+    case PgfSymbolACat::tag: {
+        auto symcf1 = ref<PgfSymbolACat>::untagged(sym1);
+        auto symcf2 = ref<PgfSymbolACat>::untagged(sym2);
+        return textcmp(&symcf1->name, &symcf2->name);
+    }
+    case PgfSymbolCCat::tag: {
+        auto symcf1 = ref<PgfSymbolCCat>::untagged(sym1);
+        auto symcf2 = ref<PgfSymbolCCat>::untagged(sym2);
+        int res = textcmp(&symcf1->lincat->name, &symcf2->lincat->name);
+        if (res != 0)
+            return res;
+        if (symcf1->value < symcf2->value)
+            return -1;
+        else if (symcf1->value > symcf2->value)
+            return 1;
+        else if (symcf1->lin_idx < symcf2->lin_idx)
+            return -1;
+        else if (symcf1->lin_idx > symcf2->lin_idx)
+            return 1;
+        else
+            return 0;
+    }
+    default:
+        return 0;
+    }
+}
+
+ref<PgfPhrasetableNode> PgfPhrasetableNode::new_node(PgfSymbol sym, size_t n_items)
+{
+    auto items = vector<ref<PgfItem>>::alloc(n_items);
+
+    auto node = PgfDB::malloc<PgfPhrasetableNode>();
+    node->sym     = sym;
+    node->n_items = 0;
+    node->items   = items;
+    node->txn_id  = PgfDB::get_txn_id();
+    node->sz      = 1;
+    node->left    = 0;
+    node->right   = 0;
+    
+    return node;
+}
+
+PgfPhrasetable PgfPhrasetableNode::upd_node(PgfPhrasetable node, PgfPhrasetable left, PgfPhrasetable right)
+{
+    if (node->txn_id != PgfDB::get_txn_id()) {
+        PgfPhrasetable new_node = PgfDB::malloc<PgfPhrasetableNode>();
+        new_node->sym      = node->sym;
+        new_node->n_items  = node->n_items;
+        new_node->items    = node->items;
+        new_node->txn_id   = PgfDB::get_txn_id();
+        release(node);
+        node = new_node;
+    }
+
+    node->sz        = 1+PgfPhrasetableNode::size(left)+PgfPhrasetableNode::size(right);
+    node->left      = left;
+    node->right     = right;
+
+    return node;
+}
+
+PgfPhrasetable PgfPhrasetableNode::balanceL(PgfPhrasetable node)
+{
+    if (node->right == 0) {
+        if (node->left == 0) {
+            return node;
         } 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);
+            if (node->left->left == 0) {
+                if (node->left->right == 0) {
+                    return node;
+                } else {
+                    PgfPhrasetable left_right = node->left->right;
+                    PgfPhrasetable left  = upd_node(node->left,0,0);
+                    PgfPhrasetable right = upd_node(node,0,0);
+                    return upd_node(left_right,
+                                    left,
+                                    right);
+                }
             } 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);
+                if (node->left->right == 0) {
+                    PgfPhrasetable left  = node->left;
+                    PgfPhrasetable right = upd_node(node,0,0);
+                    return upd_node(left,
+                                    left->left,
+                                    right);
+                } else {
+                    if (node->left->right->sz < RATIO * node->left->left->sz) {
+                        PgfPhrasetable left  = node->left;
+                        PgfPhrasetable right =
+                            upd_node(node,
+                                     left->right,
+                                     0);
+                        return upd_node(left,
+                                        left->left,
+                                        right);
+                    } else {
+                        PgfPhrasetable left_right = node->left->right;
+                        PgfPhrasetable left  =
+                            upd_node(node->left,
+                                     node->left->left,
+                                     left_right->left);
+                        PgfPhrasetable right =
+                            upd_node(node,
+                                     left_right->right,
+                                     0);
+                        return upd_node(left_right,
+                                        left,
+                                        right);
+                    }
+                }
+            }
+        }
+    } else {
+        if (node->left == 0) {
+            return node;
+        } else {
+            if (node->left->sz > DELTA*node->right->sz) {
+                if (node->left->right->sz < RATIO*node->left->left->sz) {
+                    PgfPhrasetable left  = node->left;
+                    PgfPhrasetable right =
+                        upd_node(node,
+                                 left->right,
+                                 node->right);
+                    return upd_node(left,
+                                    left->left,
+                                    right);
+                } else {
+                    PgfPhrasetable left_right = node->left->right;
+                    PgfPhrasetable left  =
+                        upd_node(node->left,
+                                 node->left->left,
+                                 left_right->left);
+                    PgfPhrasetable right =
+                        upd_node(node,
+                                 left_right->right,
+                                 node->right);
+                    return upd_node(left_right,
+                                    left,
+                                    right);
+                }
+            } else {
+                return node;
             }
         }
     }
 }
 
-PGF_INTERNAL
-size_t phrasetable_size(PgfPhrasetable table)
+PgfPhrasetable PgfPhrasetableNode::balanceR(PgfPhrasetable node)
 {
-    return Node<PgfPhrasetableEntry>::size(table);
+    if (node->left == 0) {
+        if (node->right == 0) {
+            return node;
+        } else {
+            if (node->right->left == 0) {
+                if (node->right->right == 0) {
+                    return node;
+                } else {
+                    PgfPhrasetable right = node->right;
+                    PgfPhrasetable left  =
+                        upd_node(node,
+                                 0,
+                                 0);
+                    return upd_node(right,
+                                    left,
+                                    right->right);
+                }
+            } else {
+                if (node->right->right == 0) {
+                    PgfPhrasetable right_left = node->right->left;
+                    PgfPhrasetable right =
+                        upd_node(node->right,0,0);
+                    PgfPhrasetable left =
+                        upd_node(node,0,0);
+                    return upd_node(right_left,
+                                    left,
+                                    right);
+                } else {
+                    if (node->right->left->sz < RATIO * node->right->right->sz) {
+                        PgfPhrasetable right = node->right;
+                        PgfPhrasetable left  =
+                            upd_node(node,
+                                     0,
+                                     right->left);
+                        return upd_node(right,
+                                        left,
+                                        right->right);
+                    } else {
+                        PgfPhrasetable right_left = node->right->left;
+                        PgfPhrasetable right =
+                            upd_node(node->right,
+                                     right_left->right,
+                                     node->right->right);
+                        PgfPhrasetable left =
+                            upd_node(node,
+                                     0,
+                                     right_left->left);
+                        return upd_node(right_left,
+                                        left,
+                                        right);
+                    }
+                }
+            }
+        }
+    } else {
+        if (node->right == 0) {
+            return node;
+        } else {
+            if (node->right->sz > DELTA*node->left->sz) {
+                if (node->right->left->sz < RATIO*node->right->right->sz) {
+                    PgfPhrasetable right = node->right;
+                    PgfPhrasetable left =
+                        upd_node(node,
+                                 node->left,
+                                 right->left);
+                    return upd_node(right,
+                                    left,
+                                    right->right);
+                } else {
+                    PgfPhrasetable right_left = node->right->left;
+                    PgfPhrasetable right =
+                        upd_node(node->right,
+                                 right_left->right,
+                                 node->right->right);
+                    PgfPhrasetable left =
+                        upd_node(node,
+                                 node->left,
+                                 right_left->left);
+                    return upd_node(right_left,
+                                    left,
+                                    right);
+                }
+            } else {
+                return node;
+            }
+        }
+    }
+}
+
+void PgfPhrasetableNode::release(ref<PgfPhrasetableNode> node)
+{
+    PgfDB::free(node);
+}
+
+void phrasetable_iter(PgfPhrasetable table, ref<PgfConcrLincat> lincat, std::function<void(ref<PgfSymbolCCat> arg,size_t,vector<ref<PgfItem>>)> &f)
+{
+    if (table == 0)
+        return;
+
+    int cmp = 0;
+    ref<PgfSymbolCCat> symcf = 0;
+    uint8_t tag = ref<PgfSymbol>::get_tag(table->sym);
+    if (PgfSymbolCCat::tag != tag) {
+        cmp = ((int) PgfSymbolCCat::tag) - ((int) tag);
+    } else {
+        symcf = ref<PgfSymbolCCat>::untagged(table->sym);
+        cmp = textcmp(&lincat->name, &symcf->lincat->name);
+    }
+
+    if (cmp < 0)
+        phrasetable_iter(table->left,  lincat, f);
+    else if (cmp > 0)
+        phrasetable_iter(table->right, lincat, f);
+    else {
+        phrasetable_iter(table->left,  lincat, f);
+        f(symcf,table->n_items,table->items);
+        phrasetable_iter(table->right, lincat, f);
+    }
+}
+
+vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable table, PgfSymbol sym, size_t *n_items)
+{
+    while (table != 0) {
+        int cmp = symbol_cmp(sym,table->sym);
+        if (cmp < 0)
+            table = table->left;
+        else if (cmp > 0)
+            table = table->right;
+        else {
+            *n_items = table->n_items;
+            return table->items;
+        }
+    }
+
+    *n_items = 0;
+    return 0;
 }
 
 PGF_INTERNAL
@@ -493,27 +664,34 @@ void phrasetable_lookup(PgfPhrasetable table,
     if (table == 0)
         return;
 
-    PgfTextSpot current;
-    current.pos = 0;
-    current.ptr = (uint8_t *) sentence->text;
-    const uint8_t *end = current.ptr+sentence->size;
-    size_t sym_idx = 0;
-    int cmp = text_sequence_cmp(&current,end,table->value.seq,&sym_idx,case_sensitive,SM_FULL_MATCH);
+    PgfTextSpot spot;
+    spot.pos = 0;
+    spot.ptr = (uint8_t *) sentence->text;
+    const uint8_t *end = spot.ptr+sentence->size;
+    int cmp = text_symbol_cmp(&spot,end,table->sym,case_sensitive);
     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;
-        for (size_t i = 0; i < table->value.n_backrefs; i++) {
-            PgfSequenceBackref backref = backrefs[i];
-            switch (ref<PgfConcrLin>::get_tag(backref.container)) {
+        if (!case_sensitive) {
+            phrasetable_lookup(table->left,sentence,case_sensitive,scanner,err);
+            if (err->type != PGF_EXN_NONE)
+                return;
+        }
+
+        for (size_t i = 0; i < table->n_items; i++) {
+            ref<PgfItem> item = table->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);
-                    if (err->type != PGF_EXN_NONE)
-                        return;
+                    PgfTextSpot current = spot;
+                    if (text_item_match(&current, end, item, case_sensitive) && current.ptr == end) {
+                        scanner->match(lin, item->rule->lin_idx->i0, err);
+                        if (err->type != PGF_EXN_NONE)
+                            return;
+                    }
                 }
                 break;
             }
@@ -525,10 +703,7 @@ void phrasetable_lookup(PgfPhrasetable table,
         }
 
         if (!case_sensitive) {
-            phrasetable_lookup(table->left,sentence,false,scanner,err);
-            if (err->type != PGF_EXN_NONE)
-                return;
-            phrasetable_lookup(table->right,sentence,false,scanner,err);
+            phrasetable_lookup(table->right,sentence,case_sensitive,scanner,err);
             if (err->type != PGF_EXN_NONE)
                 return;
         }
@@ -606,8 +781,7 @@ void phrasetable_lookup_prefixes(PgfCohortsState *state,
         return;
 
     PgfTextSpot current = state->spot;
-    size_t sym_idx = 0;
-    int cmp = text_sequence_cmp(&current,state->end,table->value.seq,&sym_idx,state->case_sensitive,SM_PREFIX);
+    int cmp = text_symbol_cmp(&current,state->end,table->sym,state->case_sensitive);
     if (cmp < 0) {
         phrasetable_lookup_prefixes(state,table->left,min,max);
     } else if (cmp > 0) {
@@ -628,8 +802,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 && backrefs != 0) {
+        if (len > 0) {
             if (state->last.pos != current.pos) {
                 if (state->last.pos > 0) {
                     state->scanner->end_matches(&state->last,
@@ -647,14 +820,14 @@ void phrasetable_lookup_prefixes(PgfCohortsState *state,
             }
             state->queue.push(current);
 
-            for (size_t i = 0; i < table->value.n_backrefs; i++) {
-                PgfSequenceBackref backref = backrefs[i];
-                switch (ref<PgfConcrLin>::get_tag(backref.container)) {
+            for (size_t i = 0; i < table->n_items; i++) {
+                auto rule = table->items[i]->rule;
+                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;
@@ -762,62 +935,81 @@ void phrasetable_lookup_cohorts(PgfPhrasetable table,
     }
 }
 
-PGF_INTERNAL
-void phrasetable_iter(PgfConcr *concr,
-                      PgfPhrasetable table,
-                      PgfSequenceItor* itor,
-                      PgfMorphoCallback *callback,
-                      PgfPhrasetableIds *seq_ids, PgfExn *err)
+PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
+                                  PgfSymbol sym,
+                                  ref<PgfItem> item)
 {
-    if (table == 0)
-        return;
+    if (table == 0) {
+        PgfPhrasetable new_table = PgfPhrasetableNode::new_node(sym,1);
+        new_table->n_items = 1;
+        new_table->items[0] = item;
+        return new_table;
+	}
 
-    phrasetable_iter(concr, table->left, itor, callback, seq_ids, err);
-    if (err->type != PGF_EXN_NONE)
-        return;
+    int cmp = symbol_cmp(sym,table->sym);
+    if (cmp < 0) {
+        PgfPhrasetable left = phrasetable_insert(table->left, sym, item);
+        table = PgfPhrasetableNode::upd_node(table,left,table->right);
+        return PgfPhrasetableNode::balanceL(table);
+    } else if (cmp > 0) {
+        PgfPhrasetable right = phrasetable_insert(table->right, sym, item);
+        table = PgfPhrasetableNode::upd_node(table, table->left, right);
+        return PgfPhrasetableNode::balanceR(table);
+    } else {
+        PgfPhrasetable new_table =
+            PgfPhrasetableNode::upd_node(table, table->left, table->right);
 
-	size_t seq_id = seq_ids->add(table->value.seq);
-    int res = itor->fn(itor, seq_id, table->value.seq.as_object(), err);
-    if (err->type != PGF_EXN_NONE)
-        return;
-
-    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;
-            }
-            }
+        auto items = new_table->items;
+        if (new_table->n_items >= items.size()) {
+            size_t new_len = get_next_padovan(new_table->n_items+1);
+            items = items.realloc(new_len, new_table->txn_id);
         }
+        items[new_table->n_items] = item;
+        new_table->n_items++;
+        new_table->items = items;
+        return new_table;
     }
-
-    phrasetable_iter(concr, table->right, itor, callback, seq_ids, err);
-    if (err->type != PGF_EXN_NONE)
-        return;
 }
 
-PGF_INTERNAL
-void phrasetable_release(PgfPhrasetable table)
+PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
+                                  ref<PgfConcrLincat> lincat,
+                                  size_t value, size_t lin_idx,
+                                  ref<PgfItem> item)
 {
-    if (table == 0)
-        return;
-    phrasetable_release(table->left);
-    phrasetable_release(table->right);
-    Node<PgfPhrasetableEntry>::release(table);
+    if (table == 0) {
+        ref<PgfSymbolCCat> symcf = PgfDB::malloc<PgfSymbolCCat>();
+        symcf->lincat = lincat;
+        symcf->value   = value;
+        symcf->lin_idx = lin_idx;
+        PgfPhrasetable new_table = PgfPhrasetableNode::new_node(symcf.tagged(),1);
+        new_table->n_items = 1;
+        new_table->items[0] = item;
+        return new_table;
+	}
+
+    int cmp = symbol_cmp(lincat,value,lin_idx,table->sym);
+    if (cmp < 0) {
+        PgfPhrasetable left = phrasetable_insert(table->left,
+                                                lincat, value, lin_idx, item);
+        table = PgfPhrasetableNode::upd_node(table,left,table->right);
+        return PgfPhrasetableNode::balanceL(table);
+    } else if (cmp > 0) {
+        PgfPhrasetable right = phrasetable_insert(table->right,
+                                                  lincat, value, lin_idx, item);
+        table = PgfPhrasetableNode::upd_node(table, table->left, right);
+        return PgfPhrasetableNode::balanceR(table);
+    } else {
+        PgfPhrasetable new_table =
+            PgfPhrasetableNode::upd_node(table, table->left, table->right);
+
+        auto items = new_table->items;
+        if (new_table->n_items >= items.size()) {
+            size_t new_len = get_next_padovan(new_table->n_items+1);
+            items = items.realloc(new_len, new_table->txn_id);
+        }
+        items[new_table->n_items] = item;
+        new_table->n_items++;
+        new_table->items = items;
+        return new_table;
+    }
 }
diff --git a/src/runtime/c/pgf/phrasetable.h b/src/runtime/c/pgf/phrasetable.h
index eabd74abd..894fda150 100644
--- a/src/runtime/c/pgf/phrasetable.h
+++ b/src/runtime/c/pgf/phrasetable.h
@@ -1,138 +1,122 @@
 #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 {
+    struct {
+        size_t &operator[](int i) {
+            PgfItem *item = containerof(PgfItem,vars,this);
+            return ((size_t*) (((ref<PgfSymbolCCat>*) (item+1))+item->rule->args.size()))[i];
+        }
+        size_t size() {
+            PgfItem *item = containerof(PgfItem,vars,this);
+            return (item->rule->vars != 0) ? item->rule->vars.size() : 0;
+        }
+    } vars;
+
+    struct {
+        ref<PgfSymbolCCat> &operator[](int i) {
+            PgfItem *item = containerof(PgfItem,args,this);
+            return ((ref<PgfSymbolCCat>*) (item+1))[i];
+        }
+        size_t size() {
+            PgfItem *item = containerof(PgfItem,args,this);
+            return item->rule->args.size();
+        }
+    } args;
+
+    uint16_t pre_alt;
+    uint16_t pre_dot;
+    uint16_t dot;
+    ref<PgfConcrRule> rule;
+};
+
+struct PgfPhrasetableNode;
+typedef ref<PgfPhrasetableNode> PgfPhrasetable;
+
+struct PGF_INTERNAL_DECL PgfPhrasetableNode {
+    const static size_t DELTA = 3;
+    const static size_t RATIO = 2;
+
+public:
+    PgfSymbol sym;
+
+    // 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;
+
+    txn_t txn_id;
+
+    size_t sz;
+    ref<PgfPhrasetableNode> left;
+    ref<PgfPhrasetableNode> right;
+
+    static
+    ref<PgfPhrasetableNode> new_node(PgfSymbol sym, size_t n_items);
+
+    static
+    ref<PgfPhrasetableNode> upd_node(ref<PgfPhrasetableNode> node, ref<PgfPhrasetableNode> left, ref<PgfPhrasetableNode> right);
+
+    static
+    ref<PgfPhrasetableNode> balanceL(ref<PgfPhrasetableNode> node);
+
+    static
+    ref<PgfPhrasetableNode> balanceR(ref<PgfPhrasetableNode> node);
+
+    static
+    size_t size(ref<PgfPhrasetableNode> node)
+    {
+        if (node == 0)
+            return 0;
+        return node->sz;
+    }
+
+    static
+    void release(ref<PgfPhrasetableNode> node);
+};
+
+PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
+                                  PgfSymbol sym,
+                                  ref<PgfItem> item);
+
+PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
+                                  ref<PgfConcrLincat> lincat,
+                                  size_t value, size_t lin_idx,
+                                  ref<PgfItem> item);
+
+PGF_INTERNAL_DECL
+void phrasetable_iter(PgfPhrasetable phrasetable,ref<PgfConcrLincat> lincat,std::function<void(ref<PgfSymbolCCat> symcf,size_t,vector<ref<PgfItem>>)> &f);
+
+PGF_INTERNAL_DECL
+vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable phrasetable, PgfSymbol sym, 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 phrasetable,
                         PgfText *sentence,
                         bool case_sensitive,
                         PgfPhraseScanner *scanner, PgfExn* err);
 
 PGF_INTERNAL_DECL
-void phrasetable_lookup_cohorts(PgfPhrasetable table,
+void phrasetable_lookup_cohorts(PgfPhrasetable phrasetable,
                                 PgfText *sentence,
                                 bool case_sensitive,
                                 PgfPhraseScanner *scanner, PgfExn* err);
 
-PGF_INTERNAL_DECL
-void phrasetable_iter(PgfConcr *concr,
-                      PgfPhrasetable table,
-                      PgfSequenceItor* itor,
-                      PgfMorphoCallback *callback,
-                      PgfPhrasetableIds *seq_ids, PgfExn *err);
-
-PGF_INTERNAL_DECL
-void phrasetable_release(PgfPhrasetable table);
-
-// The following are used internally in the parser
-
-enum SeqMatch { SM_FULL_MATCH, SM_PREFIX, SM_PARTIAL };
-
-PGF_INTERNAL_DECL
-int text_sequence_cmp(PgfTextSpot *spot, const uint8_t *end,
-                      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
diff --git a/src/runtime/c/pgf/printer.cxx b/src/runtime/c/pgf/printer.cxx
index 0add283eb..444aceefe 100644
--- a/src/runtime/c/pgf/printer.cxx
+++ b/src/runtime/c/pgf/printer.cxx
@@ -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(" ");
@@ -578,22 +578,100 @@ void PgfPrinter::symbol(PgfSymbol sym)
 	case PgfSymbolALLCAPIT::tag:
         puts("ALL_CAPIT");
         break;
+	case PgfSymbolACat::tag: {
+        auto symcf = ref<PgfSymbolACat>::untagged(sym);
+        efun(&symcf->name);
+        break;
+    }
+	case PgfSymbolCCat::tag: {
+        auto symcf = ref<PgfSymbolCCat>::untagged(sym);
+        efun(&symcf->lincat->name);
+        nprintf(64,"(%zu,%zu)",symcf->value,symcf->lin_idx);
+        break;
+    }
 	}
 }
 
-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->vars != 0) {
+            lvar_ranges(item->rule->vars, &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->vars != 0) {
+            lvar_ranges(item->rule->vars, &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)
diff --git a/src/runtime/c/pgf/printer.h b/src/runtime/c/pgf/printer.h
index 9cd209605..54bcfd753 100644
--- a/src/runtime/c/pgf/printer.h
+++ b/src/runtime/c/pgf/printer.h
@@ -79,9 +79,9 @@ public:
     void lvar(size_t var);
     void lparam(ref<PgfLParam> lparam);
     void lvar_ranges(vector<PgfVariableRange> vars, 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);
diff --git a/src/runtime/c/pgf/reader.cxx b/src/runtime/c/pgf/reader.cxx
index aa9df3bdb..53b08e0f0 100644
--- a/src/runtime/c/pgf/reader.cxx
+++ b/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))
 {
@@ -572,14 +588,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 +632,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<PgfVariableRange> vars = 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->vars = vars;
+    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;
-}
-
-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);
+    return rule;
 }
 
 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 res  = read_vector(&PgfReader::read_presult2);
-    auto seqs = read_seq_ids(lincat.tagged());
+    auto rules = read_vector(&PgfReader::read_rule2);
+
+    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->res  = res;
-    lincat->seqs = seqs;
+    lincat->rules = rules;
     return lincat;
 }
 
@@ -715,13 +701,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);
-    auto res  = read_vector(&PgfReader::read_presult2);
-    auto seqs = read_seq_ids(lin.tagged());
+    container  = lin.tagged();
 
-    lin->args = args;
-    lin->res  = res;
-    lin->seqs = seqs;
+    auto rules = read_vector(&PgfReader::read_rule2);
+    lin->rules = rules;
+
+    container  = 0;
+
+    for (size_t i = 0; i < rules.size(); i++) {
+        table_maker->insert_rule(rules[i]);
+    }
 
     return lin;
 }
@@ -740,8 +729,8 @@ ref<PgfConcr> PgfReader::read_concrete()
 	auto cflags = read_namespace<PgfFlag>(&PgfReader::read_flag);
 	concrete->cflags = cflags;
 
-	auto phrasetable = read_phrasetable();
-	concrete->phrasetable = phrasetable;
+    PgfParseTableMaker tm(concrete);
+    this->table_maker = &tm;
 
 	auto lincats = read_namespace<PgfConcrLincat>(&PgfReader::read_lincat);
 	concrete->lincats = lincats;
@@ -749,12 +738,11 @@ ref<PgfConcr> PgfReader::read_concrete()
 	auto lins = read_namespace<PgfConcrLin>(&PgfReader::read_lin);
 	concrete->lins = lins;
 
+    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;
 }
 
diff --git a/src/runtime/c/pgf/reader.h b/src/runtime/c/pgf/reader.h
index 74902a6a7..2167e7214 100644
--- a/src/runtime/c/pgf/reader.h
+++ b/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,6 +73,7 @@ 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();
@@ -77,10 +81,6 @@ public:
     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,6 +94,9 @@ 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);
@@ -101,6 +104,8 @@ private:
     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();
diff --git a/src/runtime/c/pgf/writer.cxx b/src/runtime/c/pgf/writer.cxx
index dfd881995..cfc05b1d6 100644
--- a/src/runtime/c/pgf/writer.cxx
+++ b/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);
@@ -293,18 +306,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)
-{
-    if (pres->vars != 0)
-        write_vector(pres->vars, &PgfWriter::write_variable_range);
-    else
-        write_len(0);
-    write_lparam(ref<PgfLParam>::from_ptr(&pres->param));
+    write_null_vector(rule->vars, &PgfWriter::write_variable_range);
+    write_lparam(rule->res);
+    write_null_vector(rule->args, &PgfWriter::write_lparam);
+
+    write_lparam(rule->lin_idx);
+
+    for (PgfSymbol sym : rule->syms) {
+        write_symbol(sym);
+    }
 }
 
 void PgfWriter::write_symbol(PgfSymbol sym)
@@ -341,10 +355,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 +373,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->res, &PgfWriter::write_presult);
-    write_vector(lincat->seqs, &PgfWriter::write_seq_id);
+    write_vector(lincat->rules, &PgfWriter::write_rule);
 }
 
 void PgfWriter::write_lincat_field(ref<ref<PgfText>> field)
@@ -399,9 +389,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->res, &PgfWriter::write_presult);
-    write_vector(lin->seqs, &PgfWriter::write_seq_id);
+    write_vector(lin->rules, &PgfWriter::write_rule);
 }
 
 void PgfWriter::write_printname(ref<PgfConcrPrintname> printname)
@@ -428,16 +416,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)
diff --git a/src/runtime/c/pgf/writer.h b/src/runtime/c/pgf/writer.h
index 4625f41c1..5bb8bb881 100644
--- a/src/runtime/c/pgf/writer.h
+++ b/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);
@@ -42,12 +44,7 @@ public:
     void write_lincat_field(ref<ref<PgfText>> field);
     void write_variable_range(ref<PgfVariableRange> var);
     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
diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc
index 6870a725f..e81030fcf 100644
--- a/src/runtime/haskell/PGF2.hsc
+++ b/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 seq_ids c
-      doc2 <- ppLins seq_ids c
-      pgf_release_phrasetable_ids seq_ids
+      doc1 <- ppLincats c
+      doc2 <- ppLins c
       return (text "concrete" <+> text name <+> char '{' $$
               nest 2 (doc1 $$
-                      doc2 $$
-                      (text "sequences" <+> char '{' $$ 
-                       nest 2 doc3 $$ 
-                       char '}')) $$
+                      doc2) $$
               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
@@ -830,8 +808,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)
-     pgf_release_phrasetable_ids seq_ids)
+     withPgfExn "fullFormLexicon" (pgf_iter_sequences (c_db c) c_revision itor1 itor2))
   fmap (reverse2 []) (readIORef ref)
   where
     getSequences ref _ seq_id val exn = do
@@ -1484,15 +1461,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
diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc
index 2030846bd..1ad73a18f 100644
--- a/src/runtime/haskell/PGF2/FFI.hsc
+++ b/src/runtime/haskell/PGF2/FFI.hsc
@@ -48,7 +48,6 @@ data PgfSequenceItor
 data PgfProbsCallback
 data PgfMorphoCallback
 data PgfCohortsCallback
-data PgfPhrasetableIds
 data PgfExprEnum
 data PgfAlignmentPhrase
 
@@ -150,26 +149,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_sequence_internal :: CSize -> Ptr () -> IO (Ptr PgfText)
+foreign import ccall pgf_print_lin_internal :: Ptr () -> CSize -> 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
@@ -244,7 +239,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 ())
 
@@ -318,8 +313,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
diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc
index 51aca6082..d3a197a3b 100644
--- a/src/runtime/haskell/PGF2/Transactions.hsc
+++ b/src/runtime/haskell/PGF2/Transactions.hsc
@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 module PGF2.Transactions
           ( -- transactions
             TxnID
@@ -18,15 +19,14 @@ module PGF2.Transactions
           , setAbstractFlag
 
             -- concrete syntax
-          , Token, SeqId, LIndex, LVar, LParam(..)
-          , PArg(..), Symbol(..), Production(..)
+          , Token, LIndex, LVar, LParam(..)
+          , PArg(..), Symbol(..), Rule(..)
 
           , createConcrete
           , alterConcrete
           , dropConcrete
           , mergePGF
           , setConcreteFlag
-          , SeqTable
           , createLincat
           , dropLincat
           , createLin, alterLin
@@ -251,21 +251,23 @@ data Symbol
   | SymALL_CAPIT                    -- the special ALL_CAPIT token
   deriving (Eq,Ord,Show)
 
+type Quantifiers = [(LVar,Int)]
+data Rule = Rule Quantifiers LParam [LParam] LParam [Symbol]
+                 deriving (Eq,Show)
+
 data PArg = PArg [(LIndex,LIndex)] {-# UNPACK #-} !LParam
             deriving (Eq,Show)
 
 data Production = Production [(LVar,LIndex)] [PArg] LParam [SeqId]
                  deriving (Eq,Show)
 
-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 ->
+createLincat :: Cat -> [String] -> [Rule] -> [Rule] -> Transaction Concr ()
+createLincat name fields lindefs linrefs = 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
                          (fromIntegral n_fields) c_fields
                          (fromIntegral (length lindefs)) (fromIntegral (length linrefs))
@@ -282,27 +284,25 @@ dropLincat name = Transaction $ \c_db  c_abstr c_revision 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 name prods seqtbl = Transaction $ \c_db c_abstr c_revision c_exn ->
+createLin :: Fun -> [Rule] -> Transaction Concr ()
+createLin name rules = Transaction $ \c_db c_abstr c_revision c_exn ->
   withText name $ \c_name ->
-  withBuildLinIface prods seqtbl $ \c_build ->
-    pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn
+  withBuildLinIface rules $ \c_build ->
+    pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length rules)) c_build c_exn
 
-alterLin :: Fun -> [Production] -> SeqTable -> Transaction Concr SeqTable
-alterLin name prods seqtbl = Transaction $ \c_db c_abstr c_revision c_exn ->
+alterLin :: Fun -> [Rule] -> Transaction Concr ()
+alterLin name rules = Transaction $ \c_db c_abstr c_revision c_exn ->
   withText name $ \c_name ->
-  withBuildLinIface prods seqtbl $ \c_build ->
-    pgf_alter_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn
+  withBuildLinIface rules $ \c_build ->
+    pgf_alter_lin c_db c_abstr c_revision c_name (fromIntegral (length rules)) c_build c_exn
 
-withBuildLinIface prods seqtbl f = do
-  ref <- newIORef seqtbl
+withBuildLinIface rules f = do
   (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 +311,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
-        fun <- (#peek PgfLinBuilderIfaceVtbl, start_production) vtbl
-        callLinBuilder0 fun c_builder c_exn
+      forM_ rules c_exn $ \(Rule vars res args lin_idx seq) -> do
+        fun <- (#peek PgfLinBuilderIfaceVtbl, start_rule) vtbl
+        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) ->
-          callLParam (callLinBuilder3 fun c_builder (fromIntegral (length hypos))) param c_exn
-        fun <- (#peek PgfLinBuilderIfaceVtbl, set_result) vtbl  
-        callLParam (callLinBuilder3 fun c_builder (fromIntegral (length vars))) res c_exn
+        forM_ args c_exn $ \arg ->
+          callLParam (callLinBuilder3 fun c_builder) arg c_exn
+        fun <- (#peek PgfLinBuilderIfaceVtbl, set_result) vtbl
+        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) ->
           callLinBuilder2 fun c_builder (fromIntegral v) (fromIntegral r) c_exn
-        fun <- (#peek PgfLinBuilderIfaceVtbl, add_sequence_id) vtbl
-        seqtbl <- readIORef ref
-        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
+        forM_ seq c_exn (addSymbol c_builder vtbl c_exn)
+        fun <- (#peek PgfLinBuilderIfaceVtbl, end_rule) vtbl
         callLinBuilder0 fun c_builder c_exn
 
     addSymbol c_builder vtbl c_exn (SymCat d r) = do

From a0c810530e9d77de13befea5151a05c323c3a59d Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 13 Nov 2025 18:54:40 +0100
Subject: [PATCH 058/144] remove the old evaluator

---
 src/compiler/api/GF/Command/SourceCommands.hs |    2 +-
 src/compiler/api/GF/Compile/CheckGrammar.hs   |    2 +-
 .../api/GF/Compile/Compute/Concrete.hs        | 1924 +++++++++--------
 .../api/GF/Compile/Compute/Concrete2.hs       | 1229 -----------
 src/compiler/api/GF/Compile/GeneratePMCFG.hs  |    2 +-
 .../api/GF/Compile/GrammarToCanonical.hs      |    2 +-
 .../api/GF/Compile/TypeCheck/Concrete.hs      |    2 +-
 src/compiler/api/GF/Interactive.hs            |    9 +-
 src/compiler/api/GF/Term.hs                   |   12 -
 src/compiler/gf.cabal                         |    2 -
 10 files changed, 1074 insertions(+), 2112 deletions(-)
 delete mode 100644 src/compiler/api/GF/Compile/Compute/Concrete2.hs
 delete mode 100644 src/compiler/api/GF/Term.hs

diff --git a/src/compiler/api/GF/Command/SourceCommands.hs b/src/compiler/api/GF/Command/SourceCommands.hs
index 33badb3ea..6e856645b 100644
--- a/src/compiler/api/GF/Command/SourceCommands.hs
+++ b/src/compiler/api/GF/Command/SourceCommands.hs
@@ -19,7 +19,7 @@ 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.Concrete(normalForm,normalFlatForm,Globals(..),stdPredef)
 import GF.Compile.TypeCheck.Concrete as TC(inferLType)
 
 import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
diff --git a/src/compiler/api/GF/Compile/CheckGrammar.hs b/src/compiler/api/GF/Compile/CheckGrammar.hs
index 5f0deb696..c734d8cb7 100644
--- a/src/compiler/api/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/api/GF/Compile/CheckGrammar.hs
@@ -28,7 +28,7 @@ import GF.Infra.Option
 
 import GF.Compile.TypeCheck.Abstract
 import GF.Compile.TypeCheck.Concrete(checkLType,inferLType)
-import GF.Compile.Compute.Concrete2(normalForm,Globals(..),stdPredef)
+import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef)
 
 import GF.Grammar
 import GF.Grammar.Lexer
diff --git a/src/compiler/api/GF/Compile/Compute/Concrete.hs b/src/compiler/api/GF/Compile/Compute/Concrete.hs
index 35e98b612..f35dd3f54 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete.hs
@@ -1,343 +1,508 @@
-{-# LANGUAGE RankNTypes, BangPatterns, CPP, ExistentialQuantification #-}
+{-# LANGUAGE RankNTypes, BangPatterns, GeneralizedNewtypeDeriving, TupleSections #-}
 
--- | Functions for computing the values of terms in the concrete syntax, in
--- | preparation for PMCFG generation.
 module GF.Compile.Compute.Concrete
-           ( normalForm, normalFlatForm, normalStringForm
-           , Value(..), Thunk, ThunkState(..), Env, Scope, showValue, isCanonicalForm
-           , PredefImpl, Predef(..), PredefCombinator, ($\)
-           , pdForce, pdCanonicalArgs, pdArity, pdStandard
-           , MetaThunks, Constraint, PredefTable, Globals(..), ConstValue(..)
-           , EvalM(..), runEvalM, runEvalOneM, reset, try, evalError, evalWarn
-           , eval, apply, force, value2term, patternMatch, stdPredef
-           , unsafeIOToEvalM
-           , newThunk, newEvaluatedThunk
-           , newResiduation, newNarrowing, getVariables
-           , getRef, setRef
-           , getResDef, getInfo, getResType, getOverload
-           , getAllParamValues
-           ) where
+           (Env, Scope, Value(..), Variants(..), OptionInfo(..),
+            ConstValue(..), Globals(..), PredefTable, EvalM,
+            mapVariantsC, unvariants,
+            runEvalM, runEvalMWithInput, stdPredef, globals,
+            PredefImpl, Predef(..), ($\),
+            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
 
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
-import GF.Grammar hiding (Env, VGen, VApp, VRecType)
-import GF.Grammar.Lookup(lookupResDef,lookupResType,
-                         lookupOrigInfo,lookupOverloadTypes,
-                         allParamValues)
-import GF.Grammar.Predef
-import GF.Grammar.Lockfield(lockLabel)
-import GF.Grammar.Printer
-import GF.Data.Operations(Err(..))
-import GF.Data.Utilities(splitAt')
+import GF.Infra.Ident
 import GF.Infra.CheckM
-import GF.Infra.Option
-import Data.STRef
-import Data.Maybe(fromMaybe)
+import GF.Data.Operations(Err(..))
+import GF.Data.Utilities(maybeAt,splitAt',(<||>),anyM,secondM,bimapM)
+import GF.Grammar.Lookup(lookupResDef,lookupOrigInfo)
+import GF.Grammar.Grammar
+import GF.Grammar.Macros
+import GF.Grammar.Predef
+import GF.Grammar.Printer hiding (ppValue)
+import GF.Grammar.Lockfield(lockLabel)
+import GF.Text.Pretty hiding (empty)
+import qualified GF.Text.Pretty as PP
+import Control.Monad
+import Control.Applicative hiding (Const)
+import qualified Control.Applicative as A
+import qualified Data.Map as Map
+import Data.Bifunctor (second)
+import Data.Functor ((<&>))
+import Data.Maybe (fromMaybe,fromJust)
 import Data.List
 import Data.Char
-import Control.Monad
-import Control.Monad.ST
-import Control.Monad.ST.Unsafe
-import Control.Applicative hiding (Const)
-import qualified Control.Monad.Fail as Fail
-import Data.Functor ((<&>))
-import qualified Data.Map as Map
-import GF.Text.Pretty
-import PGF2.Transactions(LIndex)
+import PGF2(Expr(..),Literal(..))
 
--- * Main entry points
+type PredefImpl = Globals -> Choice -> [Value] -> ConstValue Value
+newtype Predef = Predef { runPredef :: PredefImpl }
 
--- | The term is fully evaluated. Variants are only expanded if necessary for the evaluation.
-normalForm :: Globals -> Term -> Check Term
-normalForm globals t =
-  fmap mkFV (runEvalM globals (eval [] t [] >>= value2term False []))
-  where
-    mkFV [t] = t
-    mkFV ts  = FV ts
+infix 1 $\
 
--- | The result is a list of terms and contains all variants. Each term by itself does not contain any variants.
-normalFlatForm :: Globals -> Term -> Check [Term]
-normalFlatForm globals t =
-  runEvalM globals (eval [] t [] >>= value2term True [])
+($\) :: (Predef -> Predef) -> PredefImpl -> Predef
+k $\ f = k (Predef f)
 
-normalStringForm :: Globals -> Term -> Check [String]
-normalStringForm globals t =
-  fmap toStrs (runEvalM globals (fmap value2string (eval [] t [])))
-  where
-    toStrs []            = []
-    toStrs (Const s:cfs) = s : toStrs cfs
-    toStrs (_      :cfs) = toStrs cfs
+pdCanonicalArgs :: Bool -> Predef -> Predef
+pdCanonicalArgs flat def = Predef $ \g c args ->
+  if all (isCanonicalForm flat) args then runPredef def g c args else RunTime
 
-type Sigma s = Value s
-type Constraint s = Value s
+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
 
-data ThunkState s
-  = Unevaluated (Env s) Term
-  | Evaluated {-# UNPACK #-} !Int (Value s)
-  | Hole        {-# UNPACK #-} !MetaId
-  | Narrowing   {-# UNPACK #-} !MetaId Type
-  | Residuation {-# UNPACK #-} !MetaId (Scope s) (Maybe (Constraint s))
+type Env  = [(Ident,Value)]
+type Scope = [(Ident,Value)]
+type PredefTable = Map.Map Ident Predef
+data Globals = Gl Grammar PredefTable
 
-type Thunk s = STRef s (ThunkState s)
-type Env s = [(Ident,Thunk s)]
-type Scope s = [(Ident,Value s)]
-
-data Value s
-  = VApp QIdent [Thunk s]
-  | VMeta (Thunk s) [Thunk s]
-  | VSusp (Thunk s) (Value s -> EvalM s (Value s)) [Thunk s]
-  | VGen  {-# UNPACK #-} !Int [Thunk s]
-  | VClosure (Env s) Term
-  | VProd BindType Ident (Value s) (Value s)
-  | VRecType [(Label, Value s)]
-  | VR [(Label, Thunk s)]
-  | VP (Value s) Label [Thunk s]
-  | VExtR (Value s) (Value s)
-  | VTable (Value s) (Value s)
-  | VT (Value s) (Env s) [Case]
-  | VV (Value s) [Thunk s]
-  | VS (Value s) (Thunk s) [Thunk s]
+data Value
+  = VApp Choice QIdent [Value]
+  | VMeta {-# UNPACK #-} !MetaId [Value]
+  | VSusp {-# UNPACK #-} !MetaId (Value -> Value) [Value]
+  | VGen  {-# UNPACK #-} !Int [Value]
+  | VClosure Env Choice Term
+  | VProd BindType Ident Value Value
+  | VRecType [(Label, Bool, Value)] Bool
+  | VR [(Label, Value)]
+  | VP Value Label [Value]
+  | VExtR Value Value
+  | VTable Value Value
+  | VT Value Env Choice [Case]
+  | VV Value [Value]
+  | VS Value Value [Value]
   | VSort Ident
   | VInt Integer
   | VFlt Double
   | VStr String
   | VEmpty
-  | VC (Value s) (Value s)
-  | VGlue (Value s) (Value s)
+  | VC Value Value
+  | VGlue Value Value
   | VPatt Int (Maybe Int) Patt
-  | VPattType (Value s)
-  | VAlts (Value s) [(Value s, Value s)]
-  | VStrs [Value s]
-  | VMarkup Ident [(Ident,Value s)] [Value s]
-    -- These two constructors are only used internally
-    -- in the PMCFG generator.
-  | VSymCat Int LIndex [(LIndex, (Thunk s, Type))]
-  | VSymVar Int Int
-    -- These two constructors are only used internally
-    -- in the type checker.
-  | VCRecType [(Label, Bool, Constraint s)]
-  | VCInts (Maybe Integer) (Maybe Integer)
+  | VPattType Value
+  | VFV Choice (Variants Value)
+  | VAlts Value [(Value, Value)]
+  | VStrs [Value]
+  | VMarkup Ident [(Ident,Value)] [L Value]
+  | VReset Ident (Maybe Value) Value (Maybe QIdent)
+  | VSymCat Int LIndex [(LIndex, (Value, Type))]
+  | VError Doc
+  | VInts Integer Bool
 
-showValue (VApp q tnks) = "(VApp "++unwords (show q : map (const "_") tnks) ++ ")"
-showValue (VMeta _ _) = "VMeta"
-showValue (VSusp _ _ _) = "VSusp"
-showValue (VGen i _) = "(VGen "++show i++")"
-showValue (VClosure _ _) = "VClosure"
-showValue (VProd _ x v1 v2) = "VProd ("++show x++") ("++showValue v1++") ("++showValue v2++")"
-showValue (VRecType _) = "VRecType"
-showValue (VR lbls) = "(VR {"++unwords (map (\(lbl,_) -> show lbl) lbls)++"})"
-showValue (VP v l _) = "(VP "++showValue v++" "++show l++")"
-showValue (VExtR _ _) = "VExtR"
-showValue (VTable v1 v2) = "VTable ("++showValue v1++") ("++showValue v2++")"
-showValue (VT _ _ cs) = "(VT "++show cs++")"
-showValue (VV _ _) = "VV"
-showValue (VS v _ _) = "(VS "++showValue v++")"
-showValue (VSort s) = "(VSort "++show s++")"
-showValue (VInt _) = "VInt"
-showValue (VFlt _) = "VFlt"
-showValue (VStr s) = "(VStr "++show s++")"
-showValue VEmpty = "VEmpty"
-showValue (VC v1 v2) = "(VC "++showValue v1++" "++showValue v2++")"
-showValue (VGlue _ _) = "VGlue"
-showValue (VPatt _ _ _) = "VPatt"
-showValue (VPattType _) = "VPattType"
-showValue (VAlts _ _) = "VAlts"
-showValue (VStrs _) = "VStrs"
-showValue (VSymCat _ _ _) = "VSymCat"
+data Variants a
+  = VarFree [a]
+  | VarOpts Value [(Value, a)]
 
-isCanonicalForm :: Value s -> Bool
-isCanonicalForm (VClosure {})       = True
-isCanonicalForm (VProd b x d cod)   = isCanonicalForm d && isCanonicalForm cod
-isCanonicalForm (VRecType fs)       = all (isCanonicalForm . snd) fs
-isCanonicalForm (VR {})             = True
-isCanonicalForm (VTable d cod)      = isCanonicalForm d && isCanonicalForm cod
-isCanonicalForm (VT {})             = True
-isCanonicalForm (VV {})             = True
-isCanonicalForm (VSort {})          = True
-isCanonicalForm (VInt {})           = True
-isCanonicalForm (VFlt {})           = True
-isCanonicalForm (VStr {})           = True
-isCanonicalForm VEmpty              = True
-isCanonicalForm (VAlts d vs)        = all (isCanonicalForm . snd) vs
-isCanonicalForm (VStrs vs)          = all isCanonicalForm vs
-isCanonicalForm (VMarkup tag as vs) = all (isCanonicalForm . snd) as && all isCanonicalForm vs
-isCanonicalForm _ = False
+instance Functor Variants where
+    fmap f (VarFree vs)   = VarFree (f <$> vs)
+    fmap f (VarOpts n cs) = VarOpts n (second f <$> cs)
 
-eval env (Vr x)         vs  = do (tnk,depth) <- lookup x env
-                                 withVar depth $ do
-                                   v <- force tnk
-                                   apply v vs
-                              where
-                                lookup x []   = evalError ("Variable" <+> pp x <+> "is not in scope")
-                                lookup x ((y,tnk):env)
-                                  | x == y    = return (tnk,length env)
-                                  | otherwise = lookup x env
-eval env (Sort s)       []
-  | s == cTok               = return (VSort cStr)
-  | otherwise               = return (VSort s)
-eval env (EInt n)       []  = return (VInt n)
-eval env (EFloat d)     []  = return (VFlt d)
-eval env (K t)          []  = return (VStr t)
-eval env Empty          []  = return VEmpty
-eval env (App t1 t2)    vs  = do tnk <- newThunk env t2
-                                 eval env t1 (tnk : vs)
-eval env (Abs b x t)    []  = return (VClosure env (Abs b x t))
-eval env (Abs b x t) (v:vs) = eval ((x,v):env) t vs
-eval env (Meta i)       vs  = do tnk <- newHole i
-                                 return (VMeta tnk vs)
-eval env (ImplArg t)    []  = eval env t []
-eval env (Prod b x t1 t2)[] = do v1 <- eval env t1 []
-                                 return (VProd b x v1 (VClosure env t2))
-eval env (Typed t ty)   vs  = eval env t vs
-eval env (RecType lbls) []  = do lbls <- mapM (\(lbl,ty) -> fmap ((,) lbl) (eval env ty [])) lbls
-                                 return (VRecType (sortRec lbls))
-eval env (R as)         []  = do as <- mapM (\(lbl,(_,t)) -> fmap ((,) lbl) (newThunk env t)) as
-                                 return (VR as)
-eval env (P t lbl)      vs  = do v <- eval env t []
-                                 case v of
-                                   VR as -> case lookup lbl as of
-                                              Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
-                                                                     "in" <+> pp (P t lbl))
-                                              Just tnk -> do v <- force tnk
-                                                             apply v vs
-                                   v     -> return (VP v lbl vs)
-eval env (ExtR t1 t2)   []  = do v1 <- eval env t1 []
-                                 v2 <- eval env t2 []
-                                 case (v1,v2) of
-                                   (VR       as1,VR       as2) -> return (VR       (foldl (\as (lbl,v) -> update lbl v as) as1 as2))
-                                   (VRecType as1,VRecType as2) -> return (VRecType (foldl (\as (lbl,v) -> update lbl v as) as1 as2))
-                                   _                           -> return (VExtR v1 v2)
-eval env (Table t1 t2)  []  = do v1 <- eval env t1 []
-                                 v2 <- eval env t2 []
-                                 return (VTable v1 v2)
-eval env (T (TTyped ty) cs)[]=do vty <- eval env ty []
-                                 return (VT vty env cs)
-eval env (T (TWild ty) cs) []=do vty <- eval env ty []
-                                 return (VT vty env cs)
-eval env (V ty ts)      []  = do vty <- eval env ty []
-                                 tnks <- mapM (newThunk env) ts
-                                 return (VV vty tnks)
-eval env (S t1 t2)      vs  = do v1   <- eval env t1 []
-                                 tnk2 <- newThunk env t2
-                                 let v0 = VS v1 tnk2 vs
-                                 case v1 of
-                                   VT _  env cs -> patternMatch v0 (map (\(p,t) -> (env,[p],tnk2:vs,t)) cs)
-                                   VV vty tnks  -> do ty <- value2term True (map fst env) vty
-                                                      vtableSelect v0 ty tnks tnk2 vs
-                                   v1           -> return v0
-eval env (Let (x,(_,t1)) t2) vs = do tnk <- newThunk env t1
-                                     eval ((x,tnk):env) t2 vs
-eval env (Q q@(m,id)) vs
-  | m == cPredef            = evalPredef id vs   
-  | otherwise               = do t <- getResDef q
-                                 eval env t vs
-eval env (QC q)         vs  = return (VApp q vs)
-eval env (C t1 t2)      []  = do v1 <- eval env t1 []
-                                 v2 <- eval env t2 []
-                                 case (v1,v2) of
-                                   (v1,    VEmpty) -> return v1
-                                   (VEmpty,v2    ) -> return v2
-                                   _               -> return (VC v1 v2)
-eval env t@(Glue t1 t2) []  = do v1 <- eval env t1 []
-                                 v2 <- eval env t2 []
-                                 let glue VEmpty        v             = v
-                                     glue (VC v1 v2)    v             = VC v1 (glue v2 v)
-                                     glue (VApp q [])   v
-                                       | q == (cPredef,cNonExist)     = VApp q []
-                                     glue v             VEmpty        = v
-                                     glue v             (VC v1 v2)    = VC (glue v v1) v2
-                                     glue v             (VApp 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
-                                     glue (VAlts d vas) v             = glue d v
-                                     glue v1          v2              = VGlue v1 v2
+mapVariantsC :: (Choice -> a -> b) -> Choice -> Variants a -> Variants b
+mapVariantsC f c (VarFree vs)   = VarFree (mapC f c vs)
+mapVariantsC f c (VarOpts n cs) = VarOpts n (mapC (\c (x,y) -> (x,f c y)) c cs)
 
-                                     pre vd []                 s             = glue vd (VStr s)
-                                     pre vd ((v,VStrs ss):vas) s
-                                      | or [startsWith s' s | VStr s' <- ss] = glue v (VStr s)
-                                      | otherwise                            = pre vd vas s
+unvariants :: Variants a -> [a]
+unvariants (VarFree vs)   = vs
+unvariants (VarOpts n cs) = snd <$> cs
 
-                                 return (glue v1 v2)
-eval env (EPatt min max p) [] = return (VPatt min max p)
-eval env (EPattType t)  []  = do v <- eval env t []
-                                 return (VPattType v)
-eval env (ELincat c ty) []  = do v <- eval env ty []
-                                 let lbl = lockLabel c
-                                     lv  = VRecType []
-                                 case v of
-                                   (VRecType as) -> return (VRecType (update lbl lv as))
-                                   _             -> return (VExtR v (VRecType [(lbl,lv)]))
-eval env (ELin c t)     []  = do v <- eval env t []
-                                 let lbl = lockLabel c
-                                 tnk <- newEvaluatedThunk (VR [])
-                                 case v of
-                                   (VR as) -> return (VR (update lbl tnk as))
-                                   _       -> return (VExtR v (VR [(lbl,tnk)]))
-eval env (FV ts)        vs  = msum [eval env t vs | t <- ts]
-eval env (Alts d as)    []  = do vd <- eval env d []
-                                 vas <- forM as $ \(t,s) -> do
-                                           vt <- eval env t []
-                                           vs <- eval env s []
-                                           return (vt,vs)
-                                 return (VAlts vd vas)
-eval env (Strs ts)      []  = do vs <- mapM (\t -> eval env t []) ts
-                                 return (VStrs vs)
-eval env (Markup tag as ts) [] =
-                              do as <- mapM (\(id,t) -> eval env t [] >>= \v -> return (id,v)) as
-                                 vs <- mapM (\t -> eval env (unLoc t) []) ts
-                                 return (VMarkup tag as vs)
-eval env (TSymCat d r rs) []= do rs <- forM rs $ \(i,(pv,ty)) ->
-                                         case lookup pv env of
-                                           Just tnk -> return (i,(tnk,ty))
-                                           Nothing  -> evalError ("Variable" <+> pp pv <+> "is not in scope")
-                                 return (VSymCat d r rs)
-eval env (TSymVar d r)  []  = do return (VSymVar d r)
-eval env t@(Opts n cs)  vs  = EvalM $ \gr k e mt b r msgs ->
-  case cs of
-    []        -> return $ Fail ("No options in expression:" $$ ppTerm Unqualified 0 t) msgs
-    ((l,t):_) -> case eval env t vs of EvalM f -> f gr k e mt b r msgs
-eval env t              vs  = evalError ("Cannot reduce term" <+> pp t)
+isCanonicalForm :: Bool -> Value -> Bool
+isCanonicalForm flat  (VClosure {})       = True
+isCanonicalForm flat  (VProd b x d cod)   = isCanonicalForm flat d && isCanonicalForm flat cod
+isCanonicalForm flat  (VRecType fs _)     = all (\(l,_,ty) -> isCanonicalForm flat ty) fs
+isCanonicalForm flat  (VR {})             = True
+isCanonicalForm flat  (VTable d cod)      = isCanonicalForm flat d && isCanonicalForm flat cod
+isCanonicalForm flat  (VT {})             = True
+isCanonicalForm flat  (VV {})             = True
+isCanonicalForm flat  (VSort {})          = True
+isCanonicalForm flat  (VInt {})           = True
+isCanonicalForm flat  (VFlt {})           = True
+isCanonicalForm flat  (VStr {})           = True
+isCanonicalForm flat  VEmpty              = True
+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 . unLoc) vs
+isCanonicalForm flat  (VReset ctl cv v _) = maybe True (isCanonicalForm flat) cv && isCanonicalForm flat v
+isCanonicalForm flat  _ = False
 
-apply v                             []  = return v
-apply (VMeta m vs0)                 vs  = return (VMeta m   (vs0++vs))
-apply (VSusp m k vs0)               vs  = return (VSusp m k (vs0++vs))
-apply (VApp f@(m,p) vs0)            vs
-  | m == cPredef                        = evalPredef p (vs0++vs)
-  | otherwise                           = return (VApp f (vs0++vs))
-apply (VGen i  vs0)                 vs  = return (VGen i (vs0++vs))
-apply (VClosure env (Abs b x t)) (v:vs) = eval ((x,v):env) t vs
+data ConstValue a
+  = Const a
+  | CSusp MetaId (Value -> ConstValue a)
+  | CFV Choice (Variants (ConstValue a))
+  | RunTime
+  | NonExist
 
+instance Functor ConstValue where
+  fmap f (Const c) = Const (f c)
+  fmap f (CFV i vs) = CFV i (fmap (fmap f) vs)
+  fmap f (CSusp i k) = CSusp i (fmap f . k)
+  fmap f RunTime   = RunTime
+  fmap f NonExist  = NonExist
 
-stdPredef :: PredefTable s
-stdPredef = Map.fromList
-  [(cLength, pd 1 $\ \[v]     -> case value2string v of
-                                   Const s -> return (Const (VInt (genericLength s)))
-                                   _       -> return RunTime)
-  ,(cTake,   pd 2 $\ \[v1,v2] -> return (fmap string2value (liftA2 genericTake (value2int v1) (value2string v2))))
-  ,(cDrop,   pd 2 $\ \[v1,v2] -> return (fmap string2value (liftA2 genericDrop (value2int v1) (value2string v2))))
-  ,(cTk,     pd 2 $\ \[v1,v2] -> return (fmap string2value (liftA2 genericTk (value2int v1) (value2string v2))))
-  ,(cDp,     pd 2 $\ \[v1,v2] -> return (fmap string2value (liftA2 genericDp (value2int v1) (value2string v2))))
-  ,(cIsUpper,pd 1 $\ \[v]     -> return (fmap toPBool (liftA (all isUpper) (value2string v))))
-  ,(cToUpper,pd 1 $\ \[v]     -> return (fmap string2value (liftA (map toUpper) (value2string v))))
-  ,(cToLower,pd 1 $\ \[v]     -> return (fmap string2value (liftA (map toLower) (value2string v))))
-  ,(cEqStr,  pd 2 $\ \[v1,v2] -> return (fmap toPBool (liftA2 (==) (value2string v1) (value2string v2))))
-  ,(cOccur,  pd 2 $\ \[v1,v2] -> return (fmap toPBool (liftA2 occur (value2string v1) (value2string v2))))
-  ,(cOccurs, pd 2 $\ \[v1,v2] -> return (fmap toPBool (liftA2 occurs (value2string v1) (value2string v2))))
-  ,(cEqInt,  pd 2 $\ \[v1,v2] -> return (fmap toPBool (liftA2 (==) (value2int v1) (value2int v2))))
-  ,(cLessInt,pd 2 $\ \[v1,v2] -> return (fmap toPBool (liftA2 (<) (value2int v1) (value2int v2))))
-  ,(cPlus,   pd 2 $\ \[v1,v2] -> return (fmap VInt (liftA2 (+) (value2int v1) (value2int v2))))
-  ,(cError,  pd 1 $\ \[v]     -> case value2string v of
-                                   Const msg -> fail msg
-                                   _         -> fail "Indescribable error appeared")
+instance Applicative ConstValue where
+  pure = Const
+
+  (Const f)     <*> (Const x)     = Const (f x)
+  (CFV s vs)    <*> v2            = CFV s (fmap (<*> v2) vs)
+  v1            <*> (CFV s vs)    = CFV s (fmap (v1 <*>) vs)
+  (CSusp i k)   <*> v2            = CSusp i (\v -> k v <*> v2)
+  v1            <*> (CSusp i k)   = CSusp i (\v -> v1 <*> k v)
+  NonExist      <*> _             = NonExist
+  _             <*> NonExist      = NonExist
+  RunTime       <*>  _            = RunTime
+  _             <*>  RunTime      = RunTime
+
+normalForm :: Globals -> Term -> Check Term
+normalForm g t = value2term g [] (bubble (eval g [] unit t []))
+
+normalFlatForm :: Globals -> Term -> Check [Term]
+normalFlatForm g t = runEvalM g (value2termM True [] (eval g [] unit t []))
+
+eval :: Globals -> Env -> Choice -> Term -> [Value] -> Value
+eval g env s (Vr x)         vs  = case lookup x env of
+                                    Nothing -> VError ("Variable" <+> pp x <+> "is not in scope")
+                                    Just v  -> apply g v vs
+eval g env s (Sort sort)    []
+  | sort == cTok                = VSort cStr
+  | otherwise                   = VSort sort
+eval g env s (EInt n)       []  = VInt n
+eval g env s (EFloat d)     []  = VFlt d
+eval g env s (K t)          []  = VStr t
+eval g env s Empty          []  = VEmpty
+eval g env s (App t1 t2)    vs  = let (s1,s2) = split s
+                                  in eval g env s1 t1 (eval g env s2 t2 [] : vs)
+eval g env s (Abs b x t)    []  = VClosure env s (Abs b x t)
+eval g env s (Abs b x t) (v:vs) = eval g ((x,v):env) s t vs
+eval g env s (Meta i)       vs  = VMeta i vs
+eval g env s (ImplArg t)    []  = eval g env s t []
+eval g env s (Prod b x t1 t2)[]
+  | x == identW                 = let (s1,s2) = split s
+                                  in VProd b x (eval g env s1 t1 []) (eval g env s2 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 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 $$
+                                                                                    "in" <+> pp (P t lbl))
+                                                                 Just v  -> apply g v vs
+                                      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 v              = VP v lbl vs
+                                  in project (eval g env s t [])
+eval g env s (ExtR t1 t2)   []  = let (s1,s2) = split s
+
+                                      extend (VR       as1) (VR       as2)   = VR       (foldl (\as (lbl,v) -> update lbl v as) as1 as2)
+                                      extend (VRecType as1 e1) (VRecType as2 e2)=VRecType (foldl (\as (lbl,o,v) -> update3 lbl o v as) as1 as2) (e1 || e2)
+                                      extend (VFV i fvs)    v2               = VFV i (fmap (`extend` v2) fvs)
+                                      extend v1             (VFV i fvs)      = VFV i (fmap (v1 `extend`) fvs)
+                                      extend (VMeta i vs)   v2               = VSusp i (\v -> extend (apply g v vs) v2) []
+                                      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 v1             v2               = VExtR v1 v2
+
+                                  in extend (eval g env s1 t1 []) (eval g env s2 t2 [])
+eval g env s (Table t1 t2)  []  = let (!s1,!s2) = split s
+                                  in VTable (eval g env s1 t1 []) (eval g env s2 t2 [])
+eval g env s (T (TTyped ty) cs)[]=let (!s1,!s2) = split s
+                                  in VT (eval g env s1 ty []) env s2 cs
+eval g env s (T (TWild ty) cs) []=let (!s1,!s2) = split s
+                                  in VT (eval g env s1 ty []) env s2 cs
+eval g env s (V ty ts)      []  = let (!s1,!s2) = split s
+                                  in VV (eval g env s1 ty []) (mapC (\s t -> eval g env s t []) s2 ts)
+eval g env s (S t1 t2)      vs  = let (!s1,!s2) = split s
+                                      v1 = eval g env s1 t1 []
+                                      v2 = eval g env s2 t2 []
+                                      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
+                                                                  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 v1               = v0
+                                          
+                                      -- FIXME: options=[] is definitely not correct and this shouldn't be using value2termM at all
+                                      empty = State [] Map.empty Map.empty []
+
+                                in select v1
+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
+  | otherwise                 = case lookupResDef gr q of
+                                  Ok t    -> eval g env c t vs
+                                  Bad msg -> error msg
+  where
+    Gl gr predef = g
+eval g env s (QC q)         vs  = VApp s q vs
+eval g env s (C t1 t2)      []  = let (!s1,!s2) = split s
+
+                                      concat v1           VEmpty = v1
+                                      concat VEmpty           v2 = v2
+                                      concat (VFV i fvs)      v2 = VFV i (fmap (`concat` v2) fvs)
+                                      concat v1      (VFV i fvs) = VFV i (fmap (v1 `concat`) fvs)
+                                      concat (VMeta i vs)     v2 = VSusp i (\v -> concat (apply g v vs) v2) []
+                                      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 v1               v2 = VC v1 v2
+
+                                  in concat (eval g env s1 t1 []) (eval g env s2 t2 [])
+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
+                                        | q == (cPredef,cNonExist)     = VApp c q []
+                                      glue v             VEmpty        = v
+                                      glue v             (VC v1 v2)    = VC (glue v v1) v2
+                                      glue v             (VApp c q [])
+                                        | q == (cPredef,cNonExist)     = VApp c 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
+                                      glue (VAlts d vas) v             = glue d v
+                                      glue (VFV i fvs)   v2            = VFV i (fmap (`glue` v2) fvs)
+                                      glue v1            (VFV i fvs)   = VFV i (fmap (v1 `glue`) fvs)
+                                      glue (VMeta i vs)  v2            = VSusp i (\v -> glue (apply g v vs) v2) []
+                                      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 v1            v2            = VGlue v1 v2
+
+                                      pre vd []                 s              = glue vd (VStr s)
+                                      pre vd ((v,VStrs ss):vas) s
+                                        | or [startsWith s' s | VStr s' <- ss] = glue v (VStr s)
+                                        | otherwise                            = pre vd vas s
+
+                                  in glue (eval g env s1 t1 []) (eval g env s2 t2 [])
+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)])) []
+eval g env s (ELin c t)     []  = let lbl = lockLabel c
+                                      lt  = R []
+                                  in eval g env s (ExtR t (R [(lbl,(Nothing,lt))])) []
+eval g env s (FV ts)        vs  = VFV s (VarFree (mapC (\s t -> eval g env s t vs) s ts))
+eval g env s (Alts d as)    []  = let (!s1,!s2) = split s
+                                      vd  = eval g env s1 d []
+                                      vas = mapC (\s (t1,t2) -> let (!s1,!s2) = split s
+                                                                in (eval g env s1 t1 [],eval g env s2 t2 [])) s2 as
+                                  in VAlts vd vas
+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 (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]
+eval g env c t@(Opts n cs)  vs  = if null cs
+                                  then VError ("No options in expression:" $$ ppTerm Unqualified 0 t)
+                                  else let (c1,c2,c3) = split3 c
+                                           vn = eval g env c1 n []
+                                           vcs = mapC evalOpt c 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)
+
+evalPredef :: Globals -> Choice -> Ident -> [Value] -> Value
+evalPredef g@(Gl gr pds) c n args =
+  case Map.lookup n pds of
+    Nothing  -> VApp c (cPredef,n) args
+    Just def -> let valueOf (Const res) = res
+                    valueOf (CFV i vs)  = VFV i (fmap valueOf vs)
+                    valueOf (CSusp i k) = VSusp i (valueOf . k) []
+                    valueOf RunTime     = VApp c (cPredef,n) args
+                    valueOf NonExist    = VApp c (cPredef,cNonExist) []
+                in valueOf (runPredef def g c args)
+
+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}))
+  ,(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)))
+  ,(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)))
+  ,(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)))
+  ,(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)))
+  ,(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)))
+  ,(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)))
+  ,(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)))
+  ,(cError,  pdArity 1 $\ \g c [v]     -> fmap (VError . pp) (value2string g v))
   ]
   where
-    pd n = pdArity n . pdForce
     genericTk n = reverse . genericDrop n . reverse
     genericDp n = reverse . genericTake n . reverse
 
-toPBool True  = VApp (cPredef,cPTrue)  []
-toPBool False = VApp (cPredef,cPFalse) []
+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
+  | m == cPredef                            = evalPredef g c n (vs0++vs)
+  | otherwise                               = VApp c 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 v                               []  = v
+
+data BubbleVariants
+  = BubbleFree Int
+  | BubbleOpts Value [Value]
+
+bubble v = snd (bubble v)
+  where
+    bubble (VApp c f vs) = liftL (VApp c 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
+    bubble (VClosure env c t) = liftL' (\env -> VClosure env c t) env
+    bubble (VProd bt x v1 v2) = lift2 (VProd bt x) v1 v2
+    bubble v@(VRecType lbls ext) =
+      let (union,lbls') = mapAccumL descendR Map.empty lbls
+      in (union, addVariants (VRecType lbls' ext) union)
+    bubble (VR as) = liftL' VR as
+    bubble (VP v l vs) = lift1L (\v vs -> VP v l vs) v vs
+    bubble (VExtR v1 v2) = lift2 VExtR v1 v2
+    bubble (VTable v1 v2) = lift2 VTable v1 v2
+    bubble (VT v env c cs) = lift1L' (\v env -> VT v env c cs) v env
+    bubble (VV v vs) = lift1L VV v vs
+    bubble (VS v1 v2 vs) = lift2L VS v1 v2 vs
+    bubble v@(VSort _) = lift0 v
+    bubble v@(VInt _) = lift0 v
+    bubble v@(VFlt _) = lift0 v
+    bubble v@(VStr _) = lift0 v
+    bubble v@VEmpty = lift0 v
+    bubble (VC v1 v2) = lift2 VC v1 v2
+    bubble (VGlue v1 v2) = lift2 VGlue v1 v2
+    bubble v@(VPatt _ _ _) = lift0 v
+    bubble (VPattType v) = lift1 VPattType v
+    bubble v@(VFV c (VarFree vs))
+      | null vs   = (Map.empty, v)
+      | otherwise = let (union,vs') = mapAccumL descend Map.empty vs
+                    in (Map.insert c (BubbleFree (length vs),1) union, VFV c (VarFree vs'))
+    bubble v@(VFV c (VarOpts n os))
+      | null os   = (Map.empty, v)
+      | otherwise = let (union,os') = mapAccumL (\acc (k,v) -> second (k,) $ descend acc v) Map.empty os
+                    in (Map.insert c (BubbleOpts n (map fst os),1) union, VFV c (VarOpts n os'))
+    bubble (VAlts v vs) = lift1L2 VAlts v vs
+    bubble (VStrs vs) = liftL VStrs vs
+    bubble (VMarkup tag attrs vs) =
+      let (union1,attrs') = mapAccumL descend' Map.empty attrs
+          (union2,vs')    = mapAccumL descendL union1 vs
+      in (union2, VMarkup tag attrs' vs')
+    bubble (VReset ctl mb_cv v id) =
+      let (union,v') = bubble v
+      in (Map.empty,VReset ctl mb_cv v' id)
+    bubble (VSymCat d i0 vs) =
+      let (union,vs') = mapAccumL descendC Map.empty vs
+      in (union, addVariants (VSymCat d i0 vs') union)
+    bubble v@(VError _) = lift0 v
+    bubble v@(VInts _ _) = lift0 v
+
+    lift0 v = (Map.empty, v)
+
+    lift1 f v =
+      let (union,v') = bubble v
+      in (union,f v')
+
+    liftL f vs =
+      let (union,vs') = mapAccumL descend Map.empty vs
+      in (union, addVariants (f vs') union)
+
+    liftL' f vs =
+      let (union,vs') = mapAccumL descend' Map.empty vs
+      in (union, addVariants (f vs') union)
+
+    lift1L f v vs =
+      let (choices,v') = bubble v
+          (union, vs') = mapAccumL descend (unitfy choices) vs
+      in (union, addVariants (f v' vs') union)
+
+    lift1L' f v vs =
+      let (choices,v') = bubble v
+          (union, vs') = mapAccumL descend' (unitfy choices) vs
+      in (union, addVariants (f v' vs') union)
+
+    lift1L2 f v vs =
+      let (choices,v') = bubble v
+          (union, vs') = mapAccumL descend2 (unitfy choices) vs
+      in (union, addVariants (f v' vs') union)
+
+    lift2L f v1 v2 vs =
+      let (choices1,v1') = bubble v1
+          (choices2,v2') = bubble v2
+          union = mergeChoices2 choices1 choices2
+          (union', vs') = mapAccumL descend union vs
+      in (union', addVariants (f v1' v2' vs') union')
+
+    lift2 f v1 v2 =
+      let (choices1,v1') = bubble v1
+          (choices2,v2') = bubble v2
+          union = mergeChoices2 choices1 choices2
+      in (union, addVariants (f v1' v2') union)
+
+    descend union v =
+      let (choices,v') = bubble v
+      in (mergeChoices1 union choices,v')
+
+    descend' :: Map.Map Choice (BubbleVariants,Int) -> (a,Value) -> (Map.Map Choice (BubbleVariants,Int),(a,Value))
+    descend' union (x,v) =
+      let (choices,v') = bubble v
+      in (mergeChoices1 union choices,(x,v'))
+
+    descend2 union (v1,v2) =
+      let (choices1,v1') = bubble v1
+          (choices2,v2') = bubble v2
+      in (mergeChoices1 (mergeChoices1 union choices1) choices2,(v1',v2'))
+
+    descendC union (i,(v,ty)) =
+      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'))
+
+    addVariants v = Map.foldrWithKey addVariant v
+      where
+        addVariant c (bvs,cnt) v
+          | cnt > 1   = VFV c $ case bvs of
+                                  BubbleFree k    -> VarFree (replicate k v)
+                                  BubbleOpts n os -> VarOpts n (map (\l -> (l,v)) os)
+          | otherwise = v
+
+    unitfy = fmap (\(n,_) -> (n,1))
+    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 False = VApp poison (cPredef,cPFalse) []
 
 occur s1 []          = False
 occur s1 s2@(_:tail) = check s1 s2
@@ -355,669 +520,710 @@ update lbl v (a@(lbl',_):as)
   | lbl==lbl'                = (lbl,v) : as
   | otherwise                = a : update lbl v as
 
+update3 lbl o v []           = [(lbl,o,v)]
+update3 lbl o v (a@(lbl',o',_):as)
+  | lbl==lbl'                = (lbl,o||o',v) : as
+  | otherwise                = a : update3 lbl o v as
 
-patternMatch v0 []                      = return v0
-patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
+patternMatch g s v0 []                      = v0
+patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
   where
-    match env []              eqs      args  = eval env t args
+    match env []              eqs      args  = eval g env s t args
     match env (PT ty p   :ps) eqs      args  = match env (p:ps) eqs args
     match env (PAlt p1 p2:ps) eqs      args  = match env (p1:ps) ((env,p2:ps,args,t):eqs) args
-    match env (PM q      :ps) eqs      args  = do t <- getResDef q
-                                                  v <- eval [] t []
-                                                  case v of
-                                                    VPatt _ _ p -> match env (p:ps) eqs args
-                                                    _ -> evalError $ hang "Expected pattern macro:" 4
-                                                                          (pp t)
+    match env (PM q      :ps) eqs      args  = case lookupResDef gr q of
+                                                 Ok t    -> case eval g [] unit t [] of
+                                                              VPatt _ _ p -> match env (p:ps) eqs args
+                                                              _ -> error $ render (hang "Expected pattern macro:" 4
+                                                                                        (pp t))
+                                                 Bad msg -> error msg
+                                               where
+                                                 Gl gr _ = g
     match env (PV v      :ps) eqs (arg:args) = 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) = do
-      v <- force arg
-      match' env p ps eqs arg v args
+    match env (p         :ps) eqs (arg:args) = match' env p ps eqs arg args
 
-    match' env p ps eqs arg v args = do
-      case (p,v) of
-        (p,       VMeta i   vs) -> susp i (\v -> apply v vs >>= \v -> match' env p ps eqs arg v args)
-        (p,       VGen  i   vs) -> return v0
-        (p,       VSusp i k vs) -> susp i (\v -> k v >>= \v -> apply v vs >>= \v -> match' env p ps eqs arg v args)
-        (PP q qs, VApp r tnks)
-          | q == r        -> match env (qs++ps) eqs (tnks++args)
-        (PR pas, VR as)   -> matchRec env (reverse pas) as ps eqs args
+    match' env p ps eqs arg args =
+      case (p,arg) of
+        (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)
+          | 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)
-          | s1 == s2      -> match env ps eqs args
+          | s1 == s2            -> match env ps eqs args
         (PString s1, VEmpty)
-          | null s1       -> match env ps eqs args
+          | null s1             -> match env ps eqs args
         (PSeq min1 max1 p1 min2 max2 p2,v)
-                          -> case value2string v of
-                               Const s -> let n  = length s
-                                              lo = min1 `max` (n-fromMaybe n max2)
-                                              hi = (n-min2) `min` fromMaybe n max1
-                                              (ds,cs) = splitAt lo s
-                                          in if lo <= hi
-                                               then do eqs <- matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args
-                                                       patternMatch v0 eqs
-                                               else patternMatch v0 eqs
-                               RunTime -> return v0
-                               NonExist-> patternMatch v0 eqs
+                          -> case value2string g v of
+                               Const str -> let n  = length str
+                                                lo = min1 `max` (n-fromMaybe n max2)
+                                                hi = (n-min2) `min` fromMaybe n max1
+                                                (ds,cs) = splitAt lo str
+
+                                                eqs' = matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args
+
+                                            in patternMatch g s v0 eqs'
+                               RunTime   -> v0
+                               NonExist  -> patternMatch g s v0 eqs
         (PRep minp maxp p, v)
-                          -> case value2string v of
-                               Const s -> do let n = length s `div` (max minp 1)
-                                             eqs <- matchRep env n minp maxp p minp maxp p ps ((env,PString []:ps,(arg:args),t) : eqs) (arg:args)
-                                             patternMatch v0 eqs
-                               RunTime -> return v0
-                               NonExist-> patternMatch v0 eqs
-        (PChar, VStr [c]) -> match env ps eqs args
+                          -> case value2string g v of
+                               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)
+                                            in patternMatch g s v0 eqs'
+                               RunTime   -> v0
+                               NonExist  -> patternMatch g s v0 eqs
+        (PChar, VStr [_]) -> match env ps eqs args
         (PChars cs, VStr [c])
           | elem c cs     -> match env ps eqs args
         (PInt n, VInt m)
           | n == m        -> match env ps eqs args
         (PFloat n, VFlt m)
           | n == m        -> match env ps eqs args
-        _                 -> patternMatch v0 eqs
+        _                 -> patternMatch g s v0 eqs
 
     matchRec env []            as ps eqs args = match env ps eqs args
     matchRec env ((lbl,p):pas) as ps eqs args =
       case lookup lbl as of
         Just tnk -> matchRec env pas as (p:ps) eqs (tnk:args)
-        Nothing  -> evalError ("Missing value for label" <+> pp lbl)
+        Nothing  -> VError ("Missing value for label" <+> pp lbl)
 
-    matchStr env ps eqs i ds []     args = do
-      arg1 <- newEvaluatedThunk (string2value (reverse ds))
-      arg2 <- newEvaluatedThunk (string2value [])
-      return ((env,ps,arg1:arg2:args,t) : eqs)
-    matchStr env ps eqs 0 ds cs     args = do
-      arg1 <- newEvaluatedThunk (string2value (reverse ds))
-      arg2 <- newEvaluatedThunk (string2value cs)
-      return ((env,ps,arg1:arg2:args,t) : eqs)
-    matchStr env ps eqs i ds (c:cs) args = do
-      arg1 <- newEvaluatedThunk (string2value (reverse ds))
-      arg2 <- newEvaluatedThunk (string2value (c:cs))
-      eqs  <- matchStr env ps eqs (i-1 :: Int) (c:ds) cs args
-      return ((env,ps,arg1:arg2:args,t) : eqs)
+    matchStr env ps eqs i ds []     args =
+      (env,ps,(string2value (reverse ds)):(string2value []):args,t) : eqs
+    matchStr env ps eqs 0 ds cs     args =
+      (env,ps,(string2value (reverse ds)):(string2value cs):args,t) : eqs
+    matchStr env ps eqs i ds (c:cs) args =
+      (env,ps,(string2value (reverse ds)):(string2value (c:cs)):args,t) :
+      matchStr env ps eqs (i-1 :: Int) (c:ds) cs args
 
-    matchRep env 0 minp maxp p minq maxq q ps eqs args = do
-      return eqs
-    matchRep env n minp maxp p minq maxq q ps eqs args = do
+    matchRep env 0 minp maxp p minq maxq q ps eqs args = eqs
+    matchRep env n minp maxp p minq maxq q ps eqs args =
       matchRep env (n-1) minp maxp p (minp+minq) (liftM2 (+) maxp maxq) (PSeq minp maxp p minq maxq q) ps ((env,q:ps,args,t) : eqs) args
 
-
-vtableSelect v0 ty tnks tnk2 vs = do
-  v2 <- force tnk2
-  (i,_) <- value2index v2 ty
-  v <- force (tnks !! i)
-  apply v vs
+vtableSelect g v0 ty cs v2 vs =
+  apply g (select (value2index v2 ty)) vs
   where
+    select (Const (i,_)) = cs !! i
+    select (CSusp i k)   = VSusp i (\v -> select (k v)) []
+    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 (VSusp i k vs)    ty = CSusp i (\v -> value2index (apply g (k v) vs) ty)
     value2index (VR as) (RecType lbls) = compute lbls
       where
-        compute []              = return (0,1)
-        compute ((lbl,ty):lbls) = do
+        compute []              = pure (0,1)
+        compute ((lbl,ty):lbls) =
           case lookup lbl as of
-            Just tnk -> do v <- force tnk
-                           (r, cnt ) <- value2index v ty
-                           (r',cnt') <- compute lbls
-                           return (r*cnt'+r',cnt*cnt')
-            Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
-                                   "among" <+> hsep (punctuate (pp ',') (map fst as)))
-    value2index (VApp q tnks) ty = do
-      (r ,ctxt,cnt ) <- getIdxCnt q
-      (r',     cnt') <- compute ctxt tnks
-      return (r+r',cnt)
+            Just v  -> liftA2 (\(r, cnt) (r',cnt') -> (r*cnt'+r',cnt*cnt'))
+                              (value2index v ty)
+                              (compute lbls)
+            Nothing -> error (show ("Missing value for label" <+> pp lbl $$
+                                    "among" <+> hsep (punctuate (pp ',') (map fst as))))
+    value2index (VApp c q args) ty =
+      let (r ,ctxt,cnt ) = getIdxCnt q
+      in fmap (\(r', cnt') -> (r+r',cnt)) (compute ctxt args)
       where
-        getIdxCnt q = do
-          (_,ResValue (L _ ty) idx) <- getInfo q
-          let (ctxt,QC p) = typeFormCnc ty
-          (_,ResParam _ (Just (_,cnt))) <- getInfo p
-          return (idx,ctxt,cnt)
+        getIdxCnt q =
+          let (_,ResValue (L _ ty) idx) = getInfo q
+              (ctxt,QC p) = typeFormCnc ty
+              (_,ResParam _ (Just (_,cnt))) = getInfo p
+          in (idx,ctxt,cnt)
 
-        compute []              []         = return (0,1)
-        compute ((_,_,ty):ctxt) (tnk:tnks) = do
-          v <- force tnk
-          (r, cnt ) <- value2index v ty
-          (r',cnt') <- compute ctxt tnks
-          return (r*cnt'+r',cnt*cnt')
+        compute []              []     = pure (0,1)
+        compute ((_,_,ty):ctxt) (v:vs) =
+          liftA2 (\(r, cnt) (r',cnt') -> (r*cnt'+r',cnt*cnt'))
+                 (value2index v ty)
+                 (compute ctxt vs)
+
+        getInfo :: QIdent -> (ModuleName,Info)
+        getInfo q =
+          case lookupOrigInfo gr q of
+            Ok res  -> res
+            Bad msg -> error msg
+
+        Gl gr _ = g
     value2index (VInt n)          ty
-      | Just max <- isTypeInts ty    = return (fromIntegral n,fromIntegral max+1)
-    value2index (VMeta i vs) ty = do
-      v <- susp i (\v -> apply v vs)
-      value2index v ty
-    value2index (VSusp i k vs) ty = do
-      v <- susp i (\v -> k v >>= \v -> apply v vs)
-      value2index v ty
-    value2index v ty = do t <- value2term True [] v
-                          evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
-                                     "cannot be evaluated at compile time.")
+      | Just max <- isTypeInts ty    = Const (fromIntegral n,fromIntegral max+1)
+    value2index (VFV c vs)        ty = CFV c (fmap (\v -> value2index v ty) vs)
+    value2index v ty = RunTime
 
 
-susp i ki = EvalM $ \globals@(Gl gr _) k e mt d r msgs -> do
-  s <- readSTRef i
-  case s of
-    Narrowing id (QC q) -> case lookupOrigInfo gr q of
-                             Ok (m,ResParam (Just (L _ ps)) _) -> bindParam globals k e mt d r msgs s m ps
-                             Bad msg -> return (Fail (pp msg) msgs)
-    Narrowing id ty
-      | Just max <- isTypeInts ty
-                        -> bindInt globals k e mt d r msgs s 0 max
-    Evaluated _ v       -> case ki v of
-                             EvalM f -> f globals k e mt d r msgs
-    _                   -> k (VSusp i ki []) mt d r msgs
+value2term :: Globals -> [Ident] -> Value -> Check Term
+value2term g xs v = do
+  res <- runEvalM g (value2termM False xs v)
+  case res of
+    [t] -> return t
+    ts  -> return (FV ts)
+
+data MetaState
+  = Bound Scope Value
+  | Narrowing   Choice Type
+  | Residuation Scope
+data OptionInfo
+  = OptionInfo
+      { optChoice  :: Choice
+      , optValue   :: Int
+      , optLabel   :: Value
+      , optChoices :: [Value]
+      }
+data State
+  = State
+      { input    :: [(Choice, Int)]
+      , choices  :: Map.Map Choice Int
+      , metaVars :: Map.Map MetaId MetaState
+      , options  :: [OptionInfo]
+      }
+
+type Cont r = State -> r -> [Message] -> CheckResult r [Message]
+newtype EvalM a = EvalM (forall r . Globals -> (a -> Cont r) -> Cont r)
+
+instance Functor EvalM where
+  fmap f (EvalM m) = EvalM (\g k -> m g (k . f))
+
+instance Applicative EvalM where
+  pure x = EvalM (\g k -> k x)
+  (EvalM f) <*> (EvalM h) = EvalM (\g k -> f g (\fn -> h g (\x -> k (fn x))))
+
+instance Alternative EvalM where
+  empty = EvalM (\g k _ r msgs -> Success r msgs)
+  (EvalM f) <|> (EvalM g) = EvalM $ \gl k state r msgs ->
+     case f gl k state r msgs of
+       Fail msg  msgs -> Fail msg msgs
+       Success r msgs -> g gl k state r msgs
+
+instance Monad EvalM where
+  (EvalM f) >>= h = EvalM (\g k -> f g (\x -> case h x of {EvalM h -> h g k}))
+
+instance MonadFail EvalM where
+  fail msg = EvalM (\g k _ _ msgs -> Fail (pp msg) msgs)
+
+instance MonadPlus EvalM where
+
+evalError msg = EvalM (\g k _ _ msgs -> Fail msg msgs)
+
+evalWarn msg = EvalM (\g k state r msgs -> k () state r (msg:msgs))
+
+runEvalM :: Globals -> EvalM a -> Check [a]
+runEvalM g (EvalM f) = Check $ \(es,ws) ->
+  case f g (\x state xs ws -> Success (x:xs) ws) empty [] ws of
+    Fail   msg ws -> Fail msg (es,ws)
+    Success xs ws -> Success (reverse xs) (es,ws)
   where
-    bindParam gr k e mt d r msgs s m []             = return (Success r msgs)
-    bindParam gr k e mt d r msgs s m ((p, ctxt):ps) = do
-      (mt',tnks) <- mkArgs mt ctxt
-      let v = VApp (m,p) tnks
-      writeSTRef i (Evaluated 0 v)
-      res <- case ki v of
-               EvalM f -> f gr k e mt' d r msgs
-      writeSTRef i s
-      case res of
-        Fail msg  msgs -> return (Fail msg msgs)
-        Success r msgs -> bindParam gr k e mt d r msgs s m ps
+    empty = State [] Map.empty Map.empty []
 
-    mkArgs mt []              = return (mt,[])
-    mkArgs mt ((_,_,ty):ctxt) = do
-      let i = case Map.maxViewWithKey mt of
-                Just ((i,_),_) -> i+1
-                _              -> 0
-      tnk  <- newSTRef (Narrowing i ty)
-      (mt,tnks) <- mkArgs (Map.insert i tnk mt) ctxt
-      return (mt,tnk:tnks)
+runEvalMWithInput :: Globals -> [(Choice,Int)] -> EvalM a -> Check [(a, [OptionInfo])]
+runEvalMWithInput g input (EvalM f) = Check $ \(es,ws) ->
+  case f g (\x (State _ cs mvs os) xs ws -> Success ((x,reverse os):xs) ws) init [] ws of
+    Fail   msg ws -> Fail msg (es,ws)
+    Success xs ws -> Success (reverse xs) (es,ws)
+  where
+    init = State input Map.empty Map.empty []
 
-    bindInt gr k e mt d r msgs s iv max
-      | iv <= max = do
-         let v = VInt iv
-         writeSTRef i (Evaluated 0 v)
-         res <- case ki v of
-                  EvalM f -> f gr k e mt d r msgs
-         writeSTRef i s
-         case res of
-           Fail msg  msgs -> return (Fail msg msgs)
-           Success r msgs -> bindInt gr k e mt d r msgs s (iv+1) max
-      | otherwise = return (Success r msgs)
+reset :: EvalM a -> EvalM [a]
+reset (EvalM f) = EvalM $ \g k state r ws ->
+  case f g (\x state xs ws -> Success (x:xs) ws) state [] ws of
+    Fail   msg ws -> Fail msg ws
+    Success xs ws -> k (reverse xs) state r ws
 
+reset1 :: EvalM a -> EvalM (Maybe a)
+reset1 (EvalM f) = EvalM $ \g k state r ws ->
+  case f g (\x' state x ws -> Success (x <|> Just x') ws) state Nothing ws of
+    Fail  msg ws -> Fail msg ws
+    Success x ws -> k x state r ws
 
-value2term flat xs (VApp q tnks) =
-  foldM (\e1 tnk -> fmap (App e1) (tnk2term flat xs tnk)) (if fst q == cPredef then Q q else QC q) tnks
-value2term flat xs (VMeta m vs) = do
-  s <- getRef m
-  case s of
-    Evaluated _ v       -> do v <- apply v vs
-                              value2term flat xs v
-    Unevaluated env t   -> do v <- eval env t vs
-                              value2term flat xs v
-    Hole i              -> foldM (\e1 tnk -> fmap (App e1) (tnk2term flat xs tnk)) (Meta i) vs
-    Residuation i _ ctr -> case ctr of
-                             Just ctr -> value2term flat xs ctr
-                             Nothing  -> foldM (\e1 tnk -> fmap (App e1) (tnk2term flat xs tnk)) (Meta i) vs
-    Narrowing i _       -> foldM (\e1 tnk -> fmap (App e1) (tnk2term flat xs tnk)) (Meta i) vs
-value2term flat xs (VSusp j k vs) = do
-  v <- k (VGen maxBound vs)
-  value2term flat xs v
-value2term flat xs (VGen j tnks) =
-  foldM (\e1 tnk -> fmap (App e1) (tnk2term flat xs tnk)) (Vr (reverse xs !! j)) tnks
-value2term flat xs (VClosure env (Abs b x t)) = do
-  tnk <- newEvaluatedThunk (VGen (length xs) [])
-  v <- eval ((x,tnk):env) t []
-  let x' = mkFreshVar xs x
-  t <- value2term flat (x':xs) v
+globals :: EvalM Globals
+globals = EvalM (\g k -> k g)
+
+variants :: Choice -> [a] -> EvalM a
+variants c xs = EvalM (\g k state@(State input choices metas opts) r msgs ->
+  case Map.lookup c choices of
+    Just j  -> k (xs !! j) state r msgs
+    Nothing -> backtrack 0 xs k input choices metas opts r msgs)
+  where
+    backtrack j []     k input choices metas opts r msgs = Success r msgs
+    backtrack j (x:xs) k input choices metas opts r msgs =
+      case k x (State input (Map.insert c j choices) metas opts) r msgs of
+        Fail    msg msgs -> Fail msg msgs
+        Success r   msgs -> backtrack (j+1) xs k input choices metas opts r msgs
+
+variants' :: Choice -> (a -> EvalM Term) -> [a] -> EvalM Term
+variants' c f xs = EvalM (\g k state@(State input choices metas opts) r msgs ->
+  case Map.lookup c choices of
+    Just j  -> case f (xs !! j) of
+                 EvalM f -> f g k state r msgs
+    Nothing -> case backtrack g 0 xs input choices metas opts [] msgs of
+                 Fail    msg msgs -> Fail msg msgs
+                 Success ts  msgs -> k (FV (reverse ts)) state r msgs)
+  where
+    backtrack g j []     input choices metas opts ts msgs = Success ts msgs
+    backtrack g j (x:xs) input choices metas opts ts msgs =
+      case f x of
+        EvalM f -> case f g (\t st ts msgs -> Success (t:ts) msgs) (State input (Map.insert c j choices) metas opts) ts msgs of
+                     Fail    msg msgs -> Fail msg msgs
+                     Success ts  msgs -> backtrack g (j+1) xs input choices metas opts ts msgs
+
+try :: Int -> (a -> EvalM b) -> ([b] -> EvalM b) -> [a] -> EvalM b
+try sz f select xs = EvalM (\g k state r msgs ->
+  let (state',res,msgs') = backtrack sz g xs state [] msgs
+  in case select res of
+       EvalM f' -> f' g k state' r msgs')
+  where
+    backtrack sz g []     state res msgs = (state,res,msgs)
+    backtrack sz g (x:xs) state res msgs =
+      case f x of
+        EvalM f -> case f g (\y state' (_,ys) msgs -> Success (cut sz state state',y:ys) msgs) state (state,res) msgs of
+                     Fail msg _               -> backtrack sz g xs state res msgs
+                     Success (state,res) msgs -> backtrack sz g xs state res msgs
+
+    cut sz state state' = state'{metaVars=Map.mapWithKey select (metaVars state')}
+      where
+        select k ms
+          | k <= sz   = ms
+          | otherwise = case Map.lookup k (metaVars state) of
+                          Just ms -> ms
+                          Nothing -> ms
+
+newResiduation :: Scope -> EvalM MetaId
+newResiduation scope = EvalM (\g k (State input choices metas opts) r msgs ->
+  let meta_id = Map.size metas+1
+  in k meta_id (State input choices (Map.insert meta_id (Residuation scope) metas) opts) r msgs)
+
+checkpoint :: EvalM Int
+checkpoint = EvalM (\g k state r msgs ->
+  k (Map.size (metaVars state)) state r msgs)
+
+getMeta :: MetaId -> EvalM MetaState
+getMeta i = EvalM (\g k state r msgs ->
+  case Map.lookup i (metaVars state) of
+    Just ms -> k ms state r msgs
+    Nothing -> Fail ("Metavariable ?"<>pp i<+>"is not defined") msgs) 
+
+setMeta :: MetaId -> MetaState -> EvalM ()
+setMeta i ms = EvalM (\g k (State input choices metas opts) r msgs ->
+  let state' = State input choices (Map.insert i ms metas) opts
+  in k () state' r msgs)
+
+value2termM :: Bool -> [Ident] -> Value -> EvalM Term
+value2termM flat xs (VApp c q vs) =
+  foldM (\t v -> fmap (App t) (value2termM flat xs v)) (if fst q == cPredef then Q q else QC q) vs
+value2termM flat xs (VMeta i vs) = do
+  mv <- getMeta i
+  case mv of
+    Bound scope v -> do g <- globals
+                        value2termM flat (map fst scope) (apply g v vs)
+    Residuation _ -> foldM (\t v -> fmap (App t) (value2termM flat xs v)) (Meta i) vs
+value2termM flat xs (VSusp j k vs) =
+  let v = k (VGen maxBound vs)
+  in value2termM flat xs v
+value2termM flat xs (VGen j tnks) =
+  foldM (\e1 tnk -> fmap (App e1) (value2termM flat xs tnk)) (Vr (reverse xs !! j)) tnks
+value2termM flat xs (VClosure env s (Abs b x t)) = do
+  g <- globals
+  let v  = eval g ((x,VGen (length xs) []):env) s t []
+      x' = mkFreshVar xs x
+  t <- value2termM flat (x':xs) v
   return (Abs b x' t)
-value2term flat xs (VProd b x v1 v2)
-  | x == identW = do t1 <- value2term flat xs v1
-                     v2 <- case v2 of
-                             VClosure env t2 -> eval env t2 []
-                             v2              -> return v2
-                     t2 <- value2term flat xs v2
-                     return (Prod b x t1 t2)
-  | otherwise   = do t1 <- value2term flat xs v1
-                     tnk <- newEvaluatedThunk (VGen (length xs) [])
-                     v2 <- case v2 of
-                             VClosure env t2 -> eval ((x,tnk):env) t2 []
-                             v2              -> return v2
-                     t2 <- value2term flat (x:xs) v2
-                     return (Prod b (mkFreshVar xs x) t1 t2)
-value2term flat xs (VRecType lbls) = do
-  lbls <- mapM (\(lbl,v) -> fmap ((,) lbl) (value2term flat xs v)) lbls
+value2termM flat xs (VClosure env s t) = do
+  return t
+value2termM flat xs (VProd b x v1 (VClosure env c2 t2)) = do
+  g <- globals
+  t1 <- value2termM flat xs v1
+  t2 <- value2termM flat (x:xs) (eval g ((x,VGen (length xs) []):env) c2 t2 [])
+  return (Prod b (mkFreshVar xs x) t1 t2)
+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
+  lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
   return (RecType lbls)
-value2term flat xs (VR as) = do
-  as <- mapM (\(lbl,tnk) -> fmap (\t -> (lbl,(Nothing,t))) (tnk2term flat xs tnk)) as
+value2termM flat xs (VR as) = do
+  as <- mapM (\(lbl,v) -> fmap (\t -> (lbl,(Nothing,t))) (value2termM flat xs v)) as
   return (R as)
-value2term flat xs (VP v lbl tnks) = do
-  t <- value2term flat xs v
-  foldM (\e1 tnk -> fmap (App e1) (tnk2term flat xs tnk)) (P t lbl) tnks
-value2term flat xs (VExtR v1 v2) = do
-  t1 <- value2term flat xs v1
-  t2 <- value2term flat xs v2
+value2termM flat xs (VP v lbl vs) = do
+  t <- value2termM flat xs v
+  foldM (\e1 tnk -> fmap (App e1) (value2termM flat xs tnk)) (P t lbl) vs
+value2termM flat xs (VExtR v1 v2) = do
+  t1 <- value2termM flat xs v1
+  t2 <- value2termM flat xs v2
   return (ExtR t1 t2) 
-value2term flat xs (VTable v1 v2) = do
-  t1 <- value2term flat xs v1
-  t2 <- value2term flat xs v2
+value2termM flat xs (VTable v1 v2) = do
+  t1 <- value2termM flat xs v1
+  t2 <- value2termM flat xs v2
   return (Table t1 t2)
-value2term flat xs (VT vty env cs)= do
-  ty <- value2term flat xs vty
+value2termM flat xs (VT vty env s cs)= do
+  ty <- value2termM flat xs vty
   cs <- forM cs $ \(p,t) -> do
-          (_,xs',env') <- pattVars (length xs,xs,env) p
-          v <- eval env' t []
-          t <- value2term flat xs' v
+          let (_,xs',env') = pattVars (length xs,xs,env) p
+          g <- globals
+          t <- value2termM flat xs' (eval g env' s t [])
           return (p,t)
   return (T (TTyped ty) cs)
-value2term flat xs (VV vty tnks)= do
-  ty <- value2term flat xs vty
-  ts <- mapM (tnk2term flat xs) tnks
+value2termM flat xs (VV vty vs)= do
+  ty <- value2termM flat xs vty
+  ts <- mapM (value2termM flat xs) vs
   return (V ty ts)
-value2term flat xs (VS v1 tnk2 tnks) = do
-  t1 <- value2term flat xs v1
-  t2 <- tnk2term flat xs tnk2
-  foldM (\e1 tnk -> fmap (App e1) (tnk2term flat xs tnk)) (S t1 t2) tnks
-value2term flat xs (VSort s) = return (Sort s)
-value2term flat xs (VStr tok) = return (K tok)
-value2term flat xs (VInt n) = return (EInt n)
-value2term flat xs (VFlt n) = return (EFloat n)
-value2term flat xs VEmpty = return Empty
-value2term flat xs (VC v1 v2) = do
-  t1 <- value2term flat xs v1
-  t2 <- value2term flat xs v2
+value2termM flat xs (VS v1 v2 vs) =
+  case v1 of
+    VT vty env s cs -> do
+          ty <- value2termM flat xs vty
+          g  <- globals
+          cs <- forM cs $ \(p,t) -> do
+                  let (_,xs',env') = pattVars (length xs,xs,env) p
+                  t <- value2termM flat xs' (eval g env' s t vs)
+                  return (p,t)
+          t2 <- value2termM flat xs v2
+          return (S (T (TTyped ty) cs) t2)
+
+    VV vty vs' -> do
+          ty <- value2termM flat xs vty
+          g <- globals
+          ts <- forM vs' $ \v ->
+                  value2termM flat xs (apply g v vs)
+          t2 <- value2termM flat xs v2
+          return (S (V ty ts) t2)
+
+    v1                           -> do
+          t1 <- value2termM flat xs v1
+          t2 <- value2termM flat xs v2
+          foldM (\e1 tnk -> fmap (App e1) (value2termM flat xs tnk)) (S t1 t2) vs
+value2termM flat xs (VSort s) = return (Sort s)
+value2termM flat xs (VStr tok) = return (K tok)
+value2termM flat xs (VInt n) = return (EInt n)
+value2termM flat xs (VFlt n) = return (EFloat n)
+value2termM flat xs VEmpty = return Empty
+value2termM flat xs (VC v1 v2) = do
+  t1 <- value2termM flat xs v1
+  t2 <- value2termM flat xs v2
   return (C t1 t2)
-value2term flat xs (VGlue v1 v2) = do
-  t1 <- value2term flat xs v1
-  t2 <- value2term flat xs v2
+value2termM flat xs (VGlue v1 v2) = do
+  t1 <- value2termM flat xs v1
+  t2 <- value2termM flat xs v2
   return (Glue t1 t2)
-value2term flat xs (VPatt min max p) = return (EPatt min max p)
-value2term flat xs (VPattType v) = do
-  t <- value2term flat xs v
-  return (EPattType t)
-value2term flat xs (VAlts vd vas) = do
-  d <- value2term flat xs vd
+value2termM True xs (VFV i (VarFree vs)) = do
+  v <- variants i vs
+  value2termM True xs v
+value2termM False xs (VFV c (VarFree vs)) = variants' c (value2termM False xs) vs
+value2termM flat xs (VFV c (VarOpts n os)) =
+  EvalM $ \g k (State input choices metas opts) r msgs ->
+    let (j,input',choices',opts') =
+          case Map.lookup c choices of
+            Just j  -> (j,input,choices,opts)
+            Nothing -> case input of
+                         (c',j):input | c == c' -> let oi = OptionInfo c j n (map fst os)
+                                                   in (j,input,Map.insert c j choices,oi:opts)
+                         _                      -> let oi = OptionInfo c 0 n (map fst os)
+                                                   in (0,[],Map.insert c 0 choices,oi:opts)
+    in case os `maybeAt` j of
+         Just (l,t) -> case value2termM flat xs t of
+                         EvalM f -> f g k (State input' choices' metas opts') r msgs
+         Nothing    -> Fail ("Index" <+> j <+> "out of bounds for option:" $$ ppValue Unqualified 0 n) msgs
+value2termM flat xs (VPatt min max p) = return (EPatt min max p)
+value2termM flat xs (VPattType v) = do t <- value2termM flat xs v
+                                       return (EPattType t)
+value2termM flat xs (VAlts vd vas) = do
+  d <- value2termM flat xs vd
   as <- forM vas $ \(vt,vs) -> do
-           t <- value2term flat xs vt
-           s <- value2term flat xs vs
+           t <- value2termM flat xs vt
+           s <- value2termM flat xs vs
            return (t,s)
   return (Alts d as)
-value2term flat xs (VStrs vs) = do
-  ts <- mapM (value2term flat xs) vs
+value2termM flat xs (VStrs vs) = do
+  ts <- mapM (value2termM flat xs) vs
   return (Strs ts)
-value2term flat xs (VMarkup tag as vs) = do
-  as <- mapM (\(id,v) -> value2term flat xs v >>= \t -> return (id,t)) as
-  ts <- mapM (value2term flat xs) vs
-  return (Markup tag as (map noLoc ts))
-value2term flat xs (VCInts (Just i) Nothing) = return (App (Q (cPredef,cInts)) (EInt i))
-value2term flat xs (VCInts Nothing (Just j)) = return (App (Q (cPredef,cInts)) (EInt j))
-value2term flat xs (VCRecType lctrs) = do
-  ltys <- mapM (\(l,o,ctr) -> value2term flat xs ctr >>= \ty -> return (l,ty)) lctrs
-  return (RecType ltys)
-value2term flat xs (VSymCat d r rs) = return (TSymCat d r [(i,(identW,ty)) | (i,(_,ty)) <- rs])
-value2term flat xs v = error (showValue v)
+value2termM flat xs (VMarkup tag as vs) = do
+  as <- mapM (\(id,v) -> value2termM flat xs v >>= \t -> return (id,t)) as
+  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)
+  reduce ctl mb_cv ts
+  where
+    reduce ctl mb_cv ts
+      | ctl == cConcat = do
+         ts <- case mb_cv of
+                 Just (VInt n) -> return (genericTake n ts)
+                 Nothing       -> return ts
+                 _             -> evalError (pp "[concat: .. | ..] requires an integer constant")
+         case ts of
+           [t] -> return t
+           ts  -> return (Markup identW [] (map noLoc ts))
+      | ctl == cConcat' = do
+         ts <- case mb_cv of
+                 Just (VInt n) -> return (genericTake n ts)
+                 Nothing       -> return ts
+                 _             -> evalError (pp "[concat: .. | ..] requires an integer constant")
+         case ts of
+           []  -> mzero
+           [t] -> return t
+           ts  -> return (Markup identW [] (map noLoc ts))
+      | ctl == cOne =
+         case (ts,mb_cv) of
+           ([]  ,Nothing) -> mzero
+           ([]  ,Just v)  -> value2termM flat xs v
+           (t:ts,_)       -> return t
+      | ctl == cSelect =
+         case mb_cv of
+           Just (VInt n) | n >= 0    -> select n      ts'
+                         | otherwise -> select (-n-1) (reverse ts')
+                         where
+                           ts' = sortBy compareKey ts
 
-pattVars st (PP _ ps)    = foldM pattVars st ps
+                           select _ []     = mzero
+                           select 0 (t:ts) =
+                             case t of
+                               R rs -> case lookup (ident2label cp1) rs  of
+                                         Just (_,t) -> return t
+                                         Nothing    -> evalError (pp "Missing label p1")
+                               _    -> 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
+           ([]  ,Just v)  -> value2termM flat xs v
+           (ts,_)         -> msum (map pure ts)
+      | ctl == cList =
+         case (ts,mb_cv) of
+           ([],       _) -> mzero
+           ([t],      _) -> return t
+           (ts,Just cv)  ->
+             do let Just (mn,id) = mb_qid
+                    cat = showIdent id
+                ct <- value2termM flat xs cv
+                t <- listify mn cat ts
+                return (App (App (QC (mn,identS ("Conj"++cat))) ct) t)
+           _             -> evalError (pp "[list: .. | ..] requires an argument")
+      | ctl == cLen =
+         case mb_cv of
+           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)
+    listify mn cat (t1:ts) = do t2 <- listify mn cat ts
+                                return (App (App (QC (mn,identS ("Cons"++cat))) t1) t2)
+
+    compareKey (R rs1) (R rs2) =
+      case (lookup (ident2label cp2) rs1, lookup (ident2label cp2) rs2) of
+        (Just (_,K s1), Just (_,K s2)) -> compare s1 s2
+
+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)
+
+
+pattVars st (PP _ ps)    = foldl pattVars st ps
 pattVars st (PV x)       = case st of
-                             (i,xs,env) -> do tnk <- newEvaluatedThunk (VGen i [])
-                                              return (i+1,x:xs,(x,tnk):env)
-pattVars st (PR as)      = foldM (\st (_,p) -> pattVars st p) st as
+                             (i,xs,env) -> (i+1,x:xs,(x,VGen i []):env)
+pattVars st (PR as)      = foldl (\st (_,p) -> pattVars st p) st as
 pattVars st (PT ty p)    = pattVars st p
-pattVars st (PAs x p)    = do st <- case st of
-                                      (i,xs,env) -> do tnk <- newEvaluatedThunk (VGen i [])
-                                                       return (i+1,x:xs,(x,tnk):env)
-                              pattVars st p
+pattVars st (PAs x p)    = case st of
+                             (i,xs,env) -> pattVars (i+1,x:xs,(x,VGen i []):env) p
 pattVars st (PImplArg p) = pattVars st p
-pattVars st (PSeq _ _ p1 _ _ p2) = do st <- pattVars st p1
-                                      pattVars st p2
-pattVars st _            = return st
+pattVars st (PSeq _ _ p1 _ _ p2) = pattVars (pattVars st p1) p2
+pattVars st _            = st
 
-data ConstValue a
-  = Const a
-  | RunTime
-  | NonExist
 
-instance Functor ConstValue where
-  fmap f (Const c) = Const (f c)
-  fmap f RunTime   = RunTime
-  fmap f NonExist  = NonExist
 
-instance Applicative ConstValue where
-  pure = Const
+ppValue q d (VApp c f vs) = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) 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))
+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 (VClosure env c t) = pp "[|" <> ppTerm q 4 t <> pp "|]"
+ppValue q d (VProd bt x a b) =
+  if x == identW && bt == Explicit
+    then prec d 0 (ppValue q 4 a <+> "->" <+> ppValue q 0 b)
+    else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppValue q 0 a) <+> "->" <+> ppValue q 0 b)
+ppValue q d (VRecType xs ext)
+  | 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 <+> (if o then ":" else ":?") <+> ppValue q 0 v | (l,o,v) <- xs] ++ [pp ".." | ext])))
+ppValue q d (VR _) = pp "VR"
+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)
+ppValue q d (VT t _ _ cs) = "table" <+> ppValue q 0 t <+> '{' $$
+                               nest 2 (vcat (punctuate ';' (map (ppCase q) cs))) $$
+                            '}'
+                            where
+                              ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
+ppValue q d (VV _ _) = pp "VV"
+ppValue q d (VS v1 v2 vs) = prec d 3 (hsep (hang (ppValue q 3 v1) 2 ("!" <+> ppValue q 4 v2) : map (ppValue q 5) vs))
+ppValue q d (VSort s) = pp s
+ppValue q d (VInt n) = pp n
+ppValue q d (VFlt f) = pp f
+ppValue q d (VStr s) = ppTerm q d (K s)
+ppValue q d VEmpty = pp "[]"
+ppValue q d (VC v1 v2) = prec d 1 (hang (ppValue q 2 v1) 2 ("++" <+> ppValue q 1 v2))
+ppValue q d (VGlue v1 v2) = prec d 2 (ppValue q 3 v1 <+> '+'  <+> ppValue q 2 v2)
+ppValue q d (VPatt _ _ p) = prec d 4 ('#' <+> ppPatt q 2 p)
+ppValue q d (VPattType v) = prec d 4 ("pattern" <+> ppValue q 0 v)
+ppValue q d (VFV i vs) = prec d 4 ("variants" <+> pp i <+> braces (fsep (punctuate ';' (map (ppValue q 0) (unvariants vs)))))
+ppValue q d (VAlts e xs) = prec d 4 ("pre" <+> braces (ppValue q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
+ppValue q d (VStrs _) = pp "VStrs"
+ppValue q d (VMarkup _ _ _) = pp "VMarkup"
+ppValue q d (VReset ctl ct t _) = pp "[" <> pp ctl <> 
+                                  maybe PP.empty (\v -> pp ':' <+> ppValue q 6 v) ct <>
+                                  pp "|" <> ppValue q 0 t <>
+                                  pp "]"
+ppValue q d (VSymCat i r rs) = pp '<' <> pp i <> pp ',' <> pp r <> pp '>'
+ppValue q d (VError msg) = prec d 4 (pp "error" <+> ppTerm q 5 (K (show msg)))
+ppValue q d (VInts n ext)
+  | ext       = prec d 4 (pp "Ints" <+> brackets (pp n <> ".."))
+  | otherwise = prec d 4 (pp "Ints" <+> pp n)
 
-  (Const f) <*> (Const x) = Const (f x)
-  NonExist  <*> _         = NonExist
-  _         <*> NonExist  = NonExist
-  RunTime   <*>  _        = RunTime
-  _         <*>  RunTime  = RunTime
+ppAltern q (x,y) = ppValue q 0 x <+> '/' <+> ppValue q 0 y
 
-#if MIN_VERSION_base(4,10,0)
-  liftA2 f (Const a) (Const b) = Const (f a b)
-  liftA2 f NonExist  _         = NonExist
-  liftA2 f _         NonExist  = NonExist
-  liftA2 f RunTime   _         = RunTime
-  liftA2 f _         RunTime   = RunTime
-#endif
+prec d1 d2 doc
+  | d1 > d2   = parens doc
+  | otherwise = doc
 
-instance Foldable ConstValue where
-  foldr f a (Const x) = f x a
-  foldr f a RunTime   = a
-  foldr f a NonExist  = a
+value2string g v = fmap (\(_,ws,_) -> unwords ws) (value2string' g v False [] [])
 
-instance Traversable ConstValue where
-  traverse f (Const x) = Const <$> f x
-  traverse f RunTime   = pure RunTime
-  traverse f NonExist  = pure NonExist
-
-value2string v = fmap (\(_,ws,_) -> unwords ws) (value2string' v False [] [])
-
-value2string' (VStr w1)   True (w2:ws) qs = Const (False,(w1++w2):ws,qs)
-value2string' (VStr w)    _    ws      qs = Const (False,w       :ws,qs)
-value2string' VEmpty      b    ws      qs = Const (b,ws,qs)
-value2string' (VC v1 v2)  b    ws      qs =
-  case value2string' v2 b ws qs of
-    Const (b,ws,qs) -> value2string' v1 b ws qs
-    res             -> res
-value2string' (VApp q []) b    ws      qs
+value2string' g (VMeta i vs)   b ws        qs = CSusp i (\v -> value2string' g (apply g v vs) b ws qs)
+value2string' g (VSusp i k vs) b ws        qs = CSusp i (\v -> value2string' g (apply g (k v) vs) b ws qs)
+value2string' g (VStr w1)     True (w2:ws) qs = Const (False,(w1++w2):ws,qs)
+value2string' g (VStr w)         _ ws      qs = Const (False,w       :ws,qs)
+value2string' g VEmpty           b ws      qs = Const (b,ws,qs)
+value2string' g (VC v1 v2)       b ws      qs = concat v1 (value2string' g v2 b ws qs)
+  where
+    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
   | q == (cPredef,cNonExist)              = NonExist
-value2string' (VApp q []) b    ws      qs
+value2string' g (VApp c q []) b   ws     qs
   | q == (cPredef,cSOFT_SPACE)            = if null ws
                                               then Const (b,ws,q:qs)
                                               else Const (b,ws,qs)
-value2string' (VApp q []) b     ws     qs
+value2string' g (VApp c 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' (VApp q []) b     ws     qs
+value2string' g (VApp c 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' (VApp q []) b     ws     qs
+value2string' g (VApp c q []) b   ws     qs
   | q == (cPredef,cALL_CAPIT) = all_capit ws
   where
     all_capit []       = Const (b,[],q:qs)
     all_capit (w : ws) = Const (b,map toUpper w : ws,qs)
-value2string' (VAlts vd vas) b  ws     qs =
+value2string' g (VAlts vd vas) b  ws     qs =
   case ws of
-    []    -> value2string' vd b ws qs
+    []    -> value2string' g vd b ws qs
     (w:_) -> pre vd vas w b ws qs
   where
-    pre vd []                 w            = value2string' vd
+    pre vd []                 w            = value2string' g vd
     pre vd ((v,VStrs ss):vas) w
-      | or [startsWith s w | VStr s <- ss] = value2string' v
+      | or [startsWith s w | VStr s <- ss] = value2string' g v
       | otherwise                          = pre vd vas w
-value2string' _ _ _ _ = RunTime
+value2string' g (VFV s vs) b      ws     qs =
+  CFV s (fmap (\v -> value2string' g v b ws qs) vs)
+value2string' _ _ _ _ _ = RunTime
 
 startsWith []          _ = True
 startsWith (x:xs) (y:ys)
   | x == y               = startsWith xs ys
 startsWith      _      _ = False
 
-
 string2value s = string2value' (words s)
 
 string2value' []     = VEmpty
 string2value' [w]    = VStr w
 string2value' (w:ws) = VC (VStr w) (string2value' ws)
 
-value2int (VInt n) = Const n
-value2int _        = RunTime
+value2int g (VMeta i vs)     = CSusp i (\v -> value2int g (apply g v vs))
+value2int g (VSusp i k vs)   = CSusp i (\v -> value2int g (apply g (k v) vs))
+value2int g (VInt n)         = Const n
+value2int g (VFV s vs)       = CFV s (fmap (value2int g) vs)
+value2int g _                = RunTime
 
------------------------------------------------------------------------
--- * Global/built-in definitions
+value2float g (VMeta i vs)     = CSusp i (\v -> value2float g (apply g v vs))
+value2float g (VSusp i k vs)   = CSusp i (\v -> value2float g (apply g (k v) vs))
+value2float g (VFlt f)         = Const f
+value2float g (VFV s vs)       = CFV s (fmap (value2float g) vs)
+value2float g _                = RunTime
 
-type PredefImpl a s = [a] -> EvalM s (ConstValue (Value s))
-newtype Predef a s = Predef { runPredef :: PredefImpl a s }
-type PredefCombinator a b s = Predef a s -> Predef b s
+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))
+value2expr g xs (VGen j vs)    = foldl (\e v -> fmap EApp e <*> value2expr g xs v) (pure (EVar (length xs - j - 1))) vs
+value2expr g xs (VClosure env s (Abs b x t)) =
+  let v  = eval g ((x,VGen (length xs) []):env) s t []
+      x' = mkFreshVar xs x
+  in fmap (EAbs b (showIdent x')) (value2expr g (x':xs) v)
+value2expr g xs (VInt n)       = pure (ELit (LInt n))
+value2expr g xs (VFlt f)       = pure (ELit (LFlt f))
+value2expr g xs (VFV s vs)     = CFV s (fmap (value2expr g xs) vs)
+value2expr g xs v              = fmap (ELit . LStr) (value2string g v)
 
-infix 1 $\\
+newtype Choice = Choice { unchoice :: Integer }
+  deriving (Eq,Ord,Pretty,Show)
 
-($\) :: PredefCombinator a b s -> PredefImpl a s -> Predef b s
-k $\ f = k (Predef f)
+unit :: Choice
+unit = Choice 1
 
-pdForce :: PredefCombinator (Value s) (Thunk s) s
-pdForce def = Predef $ \args -> do
-  argValues <- mapM force args
-  runPredef def argValues
+poison :: Choice
+poison = Choice (-1)
 
-pdCanonicalArgs :: PredefCombinator (Value s) (Value s) s
-pdCanonicalArgs def = Predef $ \args ->
-  if all isCanonicalForm args then runPredef def args else return RunTime
+split :: Choice -> (Choice,Choice)
+split (Choice c) = (Choice (2*c), Choice (2*c+1))
 
-pdArity :: Int -> PredefCombinator (Thunk s) (Thunk s) s
-pdArity n def = Predef $ \args ->
-  case splitAt' n args of
-    Nothing                  -> return RunTime
-    Just (usedArgs, remArgs) -> do
-      res <- runPredef def usedArgs
-      forM res $ \v -> apply v remArgs
+split3 :: Choice -> (Choice,Choice,Choice)
+split3 (Choice c) = (Choice (4*c), Choice (4*c+1), Choice (2*c+1))
 
-pdStandard :: Int -> PredefCombinator (Value s) (Thunk s) s
-pdStandard n = pdArity n . pdForce . pdCanonicalArgs
+split4 :: Choice -> (Choice,Choice,Choice,Choice)
+split4 (Choice c) = (Choice (4*c), Choice (4*c+1), Choice (4*c+2), Choice (4*c+3))
 
------------------------------------------------------------------------
--- * Evaluation monad
+mapC :: (Choice -> a -> b) -> Choice -> [a] -> [b]
+mapC f c []     = []
+mapC f c [x]    = [f c x]
+mapC f c (x:xs) =
+  let (!c1,!c2) = split c
+  in f c1 x : mapC f c2 xs
 
-type MetaThunks s = Map.Map MetaId (Thunk s)
-type Do s r = [Message] -> ST s (CheckResult r [Message])
-type Cont s r = MetaThunks s -> Int -> r -> Do s r
-type PredefTable s = Map.Map Ident (Predef (Thunk s) s)
-data Globals = Gl Grammar (forall s . PredefTable s)
-newtype EvalM s a = EvalM (forall r . Globals -> (a -> Cont s r) -> (Message -> Do s r) -> Cont s r)
+forC :: Choice -> [a] -> (Choice -> a -> b) -> [b]
+forC c xs f = mapC f c xs
 
-instance Functor (EvalM s) where
-  fmap f (EvalM g) = EvalM (\gr k e -> g gr (k . f) e)
-
-instance Applicative (EvalM s) where
-  pure x = EvalM (\gr k e -> k x)
-  (EvalM f) <*> (EvalM x) = EvalM (\gr k e -> f gr (\f -> x gr (\x -> k (f x)) e) e)
-
-instance Monad (EvalM s) where
-  (EvalM f) >>= g = EvalM (\gr k e -> f gr (\x -> case g x of
-                                                    EvalM g -> g gr k e) e)
-
-instance Fail.MonadFail (EvalM s) where
-  fail msg = EvalM (\gr k e _ _ r -> e (pp msg))
-
-instance Alternative (EvalM s) where
-  empty = EvalM (\gr k e _ _ r msgs -> return (Success r msgs))
-  (EvalM f) <|> (EvalM g) = EvalM $ \gr k e mt b r msgs -> do
-     res <- f gr k e mt b r msgs
-     case res of
-       Fail msg  msgs -> return (Fail msg msgs)
-       Success r msgs -> g gr k e mt b r msgs
-
-instance MonadPlus (EvalM s) where
-
-runEvalM :: Globals -> (forall s . EvalM s a) -> Check [a]
-runEvalM gr f = Check $ \(es,ws) ->
-  case runST (case f of
-                EvalM f -> f gr (\x mt _ xs ws -> return (Success (x:xs) ws)) (\msg ws -> return (Fail msg ws)) Map.empty maxBound [] ws) of
-    Fail msg   ws -> Fail msg (es,ws)
-    Success xs ws -> Success (reverse xs) (es,ws)
-
-runEvalOneM :: Globals -> (forall s . EvalM s (Term,Type)) -> Check (Term,Type)
-runEvalOneM gr f = Check $ \(es,ws) ->
-  case runST (case f of
-                EvalM f -> f gr (\x mt _ xs ws -> return (Success (x:xs) ws)) (\msg ws -> return (Fail msg ws)) Map.empty maxBound [] ws) of
-    Fail msg      ws -> Fail msg (es,ws)
-    Success []    ws -> Fail (pp "The evaluation produced no results") (es,ws)
-    Success xs ws -> Success (FV (map fst xs),snd (head xs)) (es,ws)
-
-reset :: EvalM s a -> EvalM s [a]
-reset (EvalM f) = EvalM $ \gl k e mt d r ws -> do
-  res <- f gl (\x mt d xs ws -> return (Success (x:xs) ws)) (\msg ws -> return (Fail msg ws)) mt d [] ws
-  case res of
-    Fail msg   ws -> e msg ws
-    Success xs ws -> k (reverse xs) mt d r ws
-
-try :: EvalM s a -> EvalM s a -> EvalM s a
-try (EvalM f) (EvalM g) = EvalM (\gl k e mt d r ws -> f gl k (\msg _ -> g gl k e mt d r ws) mt d r ws)
-
-evalError :: Message -> EvalM s a
-evalError msg = EvalM (\gr k e _ _ r ws -> e msg ws)
-  
-evalWarn :: Message -> EvalM s ()
-evalWarn msg = EvalM (\gr k e mt d r msgs -> k () mt d r (msg:msgs))
-
-evalPredef :: Ident -> [Thunk s] -> EvalM s (Value s)
-evalPredef id args = do
-  res <- EvalM $ \globals@(Gl _ predef) k e mt d r msgs ->
-    case Map.lookup id predef <&> \def -> runPredef def args of
-      Just (EvalM f) -> f globals k e mt d r msgs
-      Nothing        -> k RunTime mt d r msgs
-  case res of
-    Const res -> return res
-    RunTime   -> return $ VApp (cPredef,id) args
-    NonExist  -> return $ VApp (cPredef,cNonExist) []
-
-getResDef :: QIdent -> EvalM s Term
-getResDef q = EvalM $ \(Gl gr _) k e mt d r msgs -> do
-  case lookupResDef gr q of
-    Ok t    -> k t mt d r msgs
-    Bad msg -> e (pp msg) msgs
-
-getInfo :: QIdent -> EvalM s (ModuleName,Info)
-getInfo q = EvalM $ \(Gl gr _) k e mt d r msgs -> do
-  case lookupOrigInfo gr q of
-    Ok res  -> k res mt d r msgs
-    Bad msg -> e (pp msg) msgs
-
-getResType :: QIdent -> EvalM s Type
-getResType q = EvalM $ \(Gl gr _) k e mt d r msgs -> do
-  case lookupResType gr q of
-    Ok t    -> k t mt d r msgs
-    Bad msg -> e (pp msg) msgs
-
-getOverload :: Term -> QIdent -> EvalM s (Term,Type)
-getOverload t q = EvalM $ \(Gl gr _) k e mt d r msgs -> do
-  case lookupOverloadTypes gr q of
-    Ok ttys -> let err = "Overload resolution failed" $$
-                         "of term   " <+> pp t $$
-                         "with types" <+> vcat [ppTerm Terse 0 ty | (_,ty) <- ttys]
-
-                   go r []         = return (Success r msgs)
-                   go r (tty:ttys) = do res <- k tty mt d r msgs
-                                        case res of
-                                          Fail _ _       -> go r ttys
-                                          Success r msgs -> go r ttys
-
-               in go r ttys
-    Bad msg -> e (pp msg) msgs
-
-getAllParamValues :: Type -> EvalM s [Term]
-getAllParamValues ty = EvalM $ \(Gl gr _) k e mt d r msgs ->
-  case allParamValues gr ty of
-    Ok ts   -> k ts mt d r msgs
-    Bad msg -> e (pp msg) msgs
-
-newThunk env t = EvalM $ \gr k e mt d r msgs -> do
- tnk <- newSTRef (Unevaluated env t)
- k tnk mt d r msgs
-
-newEvaluatedThunk v = EvalM $ \gr k e mt d r msgs -> do
- tnk <- newSTRef (Evaluated maxBound v)
- k tnk mt d r msgs
-
-newHole i = EvalM $ \gr k e mt d r msgs ->
-  if i == 0
-    then do tnk <- newSTRef (Hole i)
-            k tnk mt d r msgs
-    else case Map.lookup i mt of
-           Just tnk -> k tnk mt d r msgs
-           Nothing  -> do tnk <- newSTRef (Hole i)
-                          k tnk (Map.insert i tnk mt) d r msgs
-
-newResiduation scope = EvalM $ \gr k e mt d r msgs -> do
-  let i = Map.size mt + 1
-  tnk <- newSTRef (Residuation i scope Nothing)
-  k (i,tnk) (Map.insert i tnk mt) d r msgs
-
-newNarrowing ty = EvalM $ \gr k e mt d r msgs -> do
-  let i = Map.size mt + 1
-  tnk <- newSTRef (Narrowing i ty)
-  k (i,tnk) (Map.insert i tnk mt) d r msgs
-
-withVar d0 (EvalM f) = EvalM $ \gr k e mt d1 r msgs ->
-                                  let !d = min d0 d1
-                                  in f gr k e mt d r msgs
-
-getVariables :: EvalM s [(LVar,LIndex)]
-getVariables = EvalM $ \(Gl gr _) k e mt d ws r -> do
-  ps <- metas2params gr (Map.elems mt)
-  k ps mt d ws r
-  where
-    metas2params gr []         = return []
-    metas2params gr (tnk:tnks) = do
-      st <- readSTRef tnk
-      case st of
-        Narrowing i ty -> do let cnt = case allParamValues gr ty of
-                                         Ok ts   -> length ts
-                                         Bad msg -> error msg
-                             params <- metas2params gr tnks
-                             if cnt > 1
-                               then return ((i-1,cnt):params)
-                               else return params
-        _              -> metas2params gr tnks
-
-getRef tnk = EvalM $ \gr k e mt d r msgs -> readSTRef tnk >>= \st -> k st mt d r msgs
-setRef tnk st = EvalM $ \gr k e mt d r msgs -> do
-  old <- readSTRef tnk
-  writeSTRef tnk st
-  res <- k () mt d r msgs
-  writeSTRef tnk old
-  return res
-
-force tnk = EvalM $ \gr k e mt d r msgs -> do
-  s <- readSTRef tnk
-  case s of
-    Unevaluated env t -> case eval env t [] of
-                           EvalM f -> f gr (\v mt b r msgs -> do let d = length env
-                                                                 writeSTRef tnk (Evaluated d v)
-                                                                 r <- k v mt d r msgs
-                                                                 writeSTRef tnk s
-                                                                 return r) e mt d r msgs
-    Evaluated d v     -> k v mt d r msgs
-    Hole _            -> k (VMeta tnk []) mt d r msgs
-    Residuation _ _ _ -> k (VMeta tnk []) mt d r msgs
-    Narrowing _ _     -> k (VMeta tnk []) mt d r msgs
-
-tnk2term True  xs tnk = force tnk >>= value2term True xs
-tnk2term False xs tnk = EvalM $ \gr k e mt d r msgs ->
-  let join f g = do res <- f
-                    case res of
-                      Fail msg  msgs -> return (Fail msg msgs)
-                      Success r msgs -> g r msgs
-
-      flush []  k1 mt r msgs = k1 mt r msgs
-      flush [x] k1 mt r msgs = join (k x mt d r msgs) (k1 mt)
-      flush xs  k1 mt r msgs = join (k (FV (reverse xs)) mt d r msgs) (k1 mt)
-
-      acc d0 x mt d (r,!c,xs) msgs
-        | d < d0    = flush xs (\mt r msgs -> join (k x mt d r msgs) (\r msgs -> return (Success (r,c+1,[]) msgs))) mt r msgs
-        | otherwise = return (Success (r,c+1,x:xs) msgs)
-
-      err msg msgs = return (Fail msg msgs)
-
-  in do s <- readSTRef tnk
-        case s of
-          Unevaluated env t -> do let d0 = length env
-                                  res <- case eval env t [] of
-                                           EvalM f -> f gr (\v mt d msgs r -> do writeSTRef tnk (Evaluated d0 v)
-                                                                                 r <- case value2term False xs v of
-                                                                                        EvalM f -> f gr (acc d0) err mt d msgs r
-                                                                                 writeSTRef tnk s
-                                                                                 return r) err mt maxBound (r,0,[]) msgs
-                                  case res of
-                                    Fail msg msgs         -> return (Fail msg msgs)
-                                    Success (r,0,xs) msgs -> k (FV []) mt d r msgs
-                                    Success (r,c,xs) msgs -> flush xs (\mt msgs r -> return (Success msgs r)) mt r msgs
-          Evaluated d0 v    -> do res <- case value2term False xs v of
-                                           EvalM f -> f gr (acc d0) err mt maxBound (r,0,[]) msgs
-                                  case res of
-                                    Fail msg msgs         -> return (Fail msg msgs)
-                                    Success (r,0,xs) msgs -> k (FV []) mt d r msgs
-                                    Success (r,c,xs) msgs -> flush xs (\mt r msgs -> return (Success r msgs)) mt r msgs
-          Hole i            -> k (Meta i) mt d r msgs
-          Residuation i _ _ -> k (Meta i) mt d r msgs
-          Narrowing i _     -> k (Meta i) mt d r msgs
-
-scopeEnv   scope = zipWithM (\x i -> newEvaluatedThunk (VGen i []) >>= \tnk -> return (x,tnk)) (reverse scope) [0..]
-
-
-unsafeIOToEvalM :: IO a -> EvalM s a
-unsafeIOToEvalM f = EvalM (\gr k e mt d r msgs -> unsafeIOToST f >>= \x -> k x mt d r msgs)
+mapCM :: Monad m => (Choice -> a -> m b) -> Choice -> [a] -> m [b]
+mapCM f c []     = return []
+mapCM f c [x]    = do y <- f c x
+                      return [y]
+mapCM f c (x:xs) = do
+  let (!c1,!c2) = split c
+  y  <- f c1 x
+  ys <- mapCM f c2 xs
+  return (y:ys)
 
+forCM :: Monad m => Choice -> [a] -> (Choice -> a -> m b) -> m [b]
+forCM c xs f = mapCM f c xs
diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs
deleted file mode 100644
index f0e0d5943..000000000
--- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs
+++ /dev/null
@@ -1,1229 +0,0 @@
-{-# LANGUAGE RankNTypes, BangPatterns, GeneralizedNewtypeDeriving, TupleSections #-}
-
-module GF.Compile.Compute.Concrete2
-           (Env, Scope, Value(..), Variants(..), OptionInfo(..),
-            ConstValue(..), Globals(..), PredefTable, EvalM,
-            mapVariantsC, unvariants,
-            runEvalM, runEvalMWithInput, stdPredef, globals,
-            PredefImpl, Predef(..), ($\),
-            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
-
-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.Grammar
-import GF.Grammar.Macros
-import GF.Grammar.Predef
-import GF.Grammar.Printer hiding (ppValue)
-import GF.Grammar.Lockfield(lockLabel)
-import GF.Text.Pretty hiding (empty)
-import qualified GF.Text.Pretty as PP
-import Control.Monad
-import Control.Applicative hiding (Const)
-import qualified Control.Applicative as A
-import qualified Data.Map as Map
-import Data.Bifunctor (second)
-import Data.Functor ((<&>))
-import Data.Maybe (fromMaybe,fromJust)
-import Data.List
-import Data.Char
-import PGF2(Expr(..),Literal(..))
-
-type PredefImpl = Globals -> Choice -> [Value] -> ConstValue Value
-newtype Predef = Predef { runPredef :: PredefImpl }
-
-infix 1 $\
-
-($\) :: (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 Value
-  = VApp Choice QIdent [Value]
-  | VMeta {-# UNPACK #-} !MetaId [Value]
-  | VSusp {-# UNPACK #-} !MetaId (Value -> Value) [Value]
-  | VGen  {-# UNPACK #-} !Int [Value]
-  | VClosure Env Choice Term
-  | VProd BindType Ident Value Value
-  | VRecType [(Label, Bool, Value)] Bool
-  | VR [(Label, Value)]
-  | VP Value Label [Value]
-  | VExtR Value Value
-  | VTable Value Value
-  | VT Value Env Choice [Case]
-  | VV Value [Value]
-  | VS Value Value [Value]
-  | VSort Ident
-  | VInt Integer
-  | VFlt Double
-  | VStr String
-  | VEmpty
-  | VC Value Value
-  | VGlue Value Value
-  | VPatt Int (Maybe Int) Patt
-  | VPattType Value
-  | VFV Choice (Variants Value)
-  | VAlts Value [(Value, Value)]
-  | VStrs [Value]
-  | VMarkup Ident [(Ident,Value)] [L Value]
-  | VReset Ident (Maybe Value) Value (Maybe QIdent)
-  | VSymCat Int LIndex [(LIndex, (Value, Type))]
-  | VError Doc
-  | VInts Integer Bool
-
-data Variants a
-  = VarFree [a]
-  | VarOpts Value [(Value, a)]
-
-instance Functor Variants where
-    fmap f (VarFree vs)   = VarFree (f <$> vs)
-    fmap f (VarOpts n cs) = VarOpts n (second f <$> cs)
-
-mapVariantsC :: (Choice -> a -> b) -> Choice -> Variants a -> Variants b
-mapVariantsC f c (VarFree vs)   = VarFree (mapC f c vs)
-mapVariantsC f c (VarOpts n cs) = VarOpts n (mapC (\c (x,y) -> (x,f c y)) c cs)
-
-unvariants :: Variants a -> [a]
-unvariants (VarFree vs)   = vs
-unvariants (VarOpts n cs) = snd <$> cs
-
-isCanonicalForm :: Bool -> Value -> Bool
-isCanonicalForm flat  (VClosure {})       = True
-isCanonicalForm flat  (VProd b x d cod)   = isCanonicalForm flat d && isCanonicalForm flat cod
-isCanonicalForm flat  (VRecType fs _)     = all (\(l,_,ty) -> isCanonicalForm flat ty) fs
-isCanonicalForm flat  (VR {})             = True
-isCanonicalForm flat  (VTable d cod)      = isCanonicalForm flat d && isCanonicalForm flat cod
-isCanonicalForm flat  (VT {})             = True
-isCanonicalForm flat  (VV {})             = True
-isCanonicalForm flat  (VSort {})          = True
-isCanonicalForm flat  (VInt {})           = True
-isCanonicalForm flat  (VFlt {})           = True
-isCanonicalForm flat  (VStr {})           = True
-isCanonicalForm flat  VEmpty              = True
-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 . unLoc) vs
-isCanonicalForm flat  (VReset ctl cv v _) = maybe True (isCanonicalForm flat) cv && isCanonicalForm flat v
-isCanonicalForm flat  _ = False
-
-data ConstValue a
-  = Const a
-  | CSusp MetaId (Value -> ConstValue a)
-  | CFV Choice (Variants (ConstValue a))
-  | RunTime
-  | NonExist
-
-instance Functor ConstValue where
-  fmap f (Const c) = Const (f c)
-  fmap f (CFV i vs) = CFV i (fmap (fmap f) vs)
-  fmap f (CSusp i k) = CSusp i (fmap f . k)
-  fmap f RunTime   = RunTime
-  fmap f NonExist  = NonExist
-
-instance Applicative ConstValue where
-  pure = Const
-
-  (Const f)     <*> (Const x)     = Const (f x)
-  (CFV s vs)    <*> v2            = CFV s (fmap (<*> v2) vs)
-  v1            <*> (CFV s vs)    = CFV s (fmap (v1 <*>) vs)
-  (CSusp i k)   <*> v2            = CSusp i (\v -> k v <*> v2)
-  v1            <*> (CSusp i k)   = CSusp i (\v -> v1 <*> k v)
-  NonExist      <*> _             = NonExist
-  _             <*> NonExist      = NonExist
-  RunTime       <*>  _            = RunTime
-  _             <*>  RunTime      = RunTime
-
-normalForm :: Globals -> Term -> Check Term
-normalForm g t = value2term g [] (bubble (eval g [] unit t []))
-
-normalFlatForm :: Globals -> Term -> Check [Term]
-normalFlatForm g t = runEvalM g (value2termM True [] (eval g [] unit t []))
-
-eval :: Globals -> Env -> Choice -> Term -> [Value] -> Value
-eval g env s (Vr x)         vs  = case lookup x env of
-                                    Nothing -> VError ("Variable" <+> pp x <+> "is not in scope")
-                                    Just v  -> apply g v vs
-eval g env s (Sort sort)    []
-  | sort == cTok                = VSort cStr
-  | otherwise                   = VSort sort
-eval g env s (EInt n)       []  = VInt n
-eval g env s (EFloat d)     []  = VFlt d
-eval g env s (K t)          []  = VStr t
-eval g env s Empty          []  = VEmpty
-eval g env s (App t1 t2)    vs  = let (s1,s2) = split s
-                                  in eval g env s1 t1 (eval g env s2 t2 [] : vs)
-eval g env s (Abs b x t)    []  = VClosure env s (Abs b x t)
-eval g env s (Abs b x t) (v:vs) = eval g ((x,v):env) s t vs
-eval g env s (Meta i)       vs  = VMeta i vs
-eval g env s (ImplArg t)    []  = eval g env s t []
-eval g env s (Prod b x t1 t2)[]
-  | x == identW                 = let (s1,s2) = split s
-                                  in VProd b x (eval g env s1 t1 []) (eval g env s2 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 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 $$
-                                                                                    "in" <+> pp (P t lbl))
-                                                                 Just v  -> apply g v vs
-                                      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 v              = VP v lbl vs
-                                  in project (eval g env s t [])
-eval g env s (ExtR t1 t2)   []  = let (s1,s2) = split s
-
-                                      extend (VR       as1) (VR       as2)   = VR       (foldl (\as (lbl,v) -> update lbl v as) as1 as2)
-                                      extend (VRecType as1 e1) (VRecType as2 e2)=VRecType (foldl (\as (lbl,o,v) -> update3 lbl o v as) as1 as2) (e1 || e2)
-                                      extend (VFV i fvs)    v2               = VFV i (fmap (`extend` v2) fvs)
-                                      extend v1             (VFV i fvs)      = VFV i (fmap (v1 `extend`) fvs)
-                                      extend (VMeta i vs)   v2               = VSusp i (\v -> extend (apply g v vs) v2) []
-                                      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 v1             v2               = VExtR v1 v2
-
-                                  in extend (eval g env s1 t1 []) (eval g env s2 t2 [])
-eval g env s (Table t1 t2)  []  = let (!s1,!s2) = split s
-                                  in VTable (eval g env s1 t1 []) (eval g env s2 t2 [])
-eval g env s (T (TTyped ty) cs)[]=let (!s1,!s2) = split s
-                                  in VT (eval g env s1 ty []) env s2 cs
-eval g env s (T (TWild ty) cs) []=let (!s1,!s2) = split s
-                                  in VT (eval g env s1 ty []) env s2 cs
-eval g env s (V ty ts)      []  = let (!s1,!s2) = split s
-                                  in VV (eval g env s1 ty []) (mapC (\s t -> eval g env s t []) s2 ts)
-eval g env s (S t1 t2)      vs  = let (!s1,!s2) = split s
-                                      v1 = eval g env s1 t1 []
-                                      v2 = eval g env s2 t2 []
-                                      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
-                                                                  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 v1               = v0
-                                          
-                                      -- FIXME: options=[] is definitely not correct and this shouldn't be using value2termM at all
-                                      empty = State [] Map.empty Map.empty []
-
-                                in select v1
-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
-  | otherwise                 = case lookupResDef gr q of
-                                  Ok t    -> eval g env c t vs
-                                  Bad msg -> error msg
-  where
-    Gl gr predef = g
-eval g env s (QC q)         vs  = VApp s q vs
-eval g env s (C t1 t2)      []  = let (!s1,!s2) = split s
-
-                                      concat v1           VEmpty = v1
-                                      concat VEmpty           v2 = v2
-                                      concat (VFV i fvs)      v2 = VFV i (fmap (`concat` v2) fvs)
-                                      concat v1      (VFV i fvs) = VFV i (fmap (v1 `concat`) fvs)
-                                      concat (VMeta i vs)     v2 = VSusp i (\v -> concat (apply g v vs) v2) []
-                                      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 v1               v2 = VC v1 v2
-
-                                  in concat (eval g env s1 t1 []) (eval g env s2 t2 [])
-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
-                                        | q == (cPredef,cNonExist)     = VApp c q []
-                                      glue v             VEmpty        = v
-                                      glue v             (VC v1 v2)    = VC (glue v v1) v2
-                                      glue v             (VApp c q [])
-                                        | q == (cPredef,cNonExist)     = VApp c 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
-                                      glue (VAlts d vas) v             = glue d v
-                                      glue (VFV i fvs)   v2            = VFV i (fmap (`glue` v2) fvs)
-                                      glue v1            (VFV i fvs)   = VFV i (fmap (v1 `glue`) fvs)
-                                      glue (VMeta i vs)  v2            = VSusp i (\v -> glue (apply g v vs) v2) []
-                                      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 v1            v2            = VGlue v1 v2
-
-                                      pre vd []                 s              = glue vd (VStr s)
-                                      pre vd ((v,VStrs ss):vas) s
-                                        | or [startsWith s' s | VStr s' <- ss] = glue v (VStr s)
-                                        | otherwise                            = pre vd vas s
-
-                                  in glue (eval g env s1 t1 []) (eval g env s2 t2 [])
-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)])) []
-eval g env s (ELin c t)     []  = let lbl = lockLabel c
-                                      lt  = R []
-                                  in eval g env s (ExtR t (R [(lbl,(Nothing,lt))])) []
-eval g env s (FV ts)        vs  = VFV s (VarFree (mapC (\s t -> eval g env s t vs) s ts))
-eval g env s (Alts d as)    []  = let (!s1,!s2) = split s
-                                      vd  = eval g env s1 d []
-                                      vas = mapC (\s (t1,t2) -> let (!s1,!s2) = split s
-                                                                in (eval g env s1 t1 [],eval g env s2 t2 [])) s2 as
-                                  in VAlts vd vas
-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 (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]
-eval g env c t@(Opts n cs)  vs  = if null cs
-                                  then VError ("No options in expression:" $$ ppTerm Unqualified 0 t)
-                                  else let (c1,c2,c3) = split3 c
-                                           vn = eval g env c1 n []
-                                           vcs = mapC evalOpt c 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)
-
-evalPredef :: Globals -> Choice -> Ident -> [Value] -> Value
-evalPredef g@(Gl gr pds) c n args =
-  case Map.lookup n pds of
-    Nothing  -> VApp c (cPredef,n) args
-    Just def -> let valueOf (Const res) = res
-                    valueOf (CFV i vs)  = VFV i (fmap valueOf vs)
-                    valueOf (CSusp i k) = VSusp i (valueOf . k) []
-                    valueOf RunTime     = VApp c (cPredef,n) args
-                    valueOf NonExist    = VApp c (cPredef,cNonExist) []
-                in valueOf (runPredef def g c args)
-
-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}))
-  ,(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)))
-  ,(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)))
-  ,(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)))
-  ,(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)))
-  ,(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)))
-  ,(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)))
-  ,(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)))
-  ,(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
-
-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
-  | m == cPredef                            = evalPredef g c n (vs0++vs)
-  | otherwise                               = VApp c 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 v                               []  = v
-
-data BubbleVariants
-  = BubbleFree Int
-  | BubbleOpts Value [Value]
-
-bubble v = snd (bubble v)
-  where
-    bubble (VApp c f vs) = liftL (VApp c 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
-    bubble (VClosure env c t) = liftL' (\env -> VClosure env c t) env
-    bubble (VProd bt x v1 v2) = lift2 (VProd bt x) v1 v2
-    bubble v@(VRecType lbls ext) =
-      let (union,lbls') = mapAccumL descendR Map.empty lbls
-      in (union, addVariants (VRecType lbls' ext) union)
-    bubble (VR as) = liftL' VR as
-    bubble (VP v l vs) = lift1L (\v vs -> VP v l vs) v vs
-    bubble (VExtR v1 v2) = lift2 VExtR v1 v2
-    bubble (VTable v1 v2) = lift2 VTable v1 v2
-    bubble (VT v env c cs) = lift1L' (\v env -> VT v env c cs) v env
-    bubble (VV v vs) = lift1L VV v vs
-    bubble (VS v1 v2 vs) = lift2L VS v1 v2 vs
-    bubble v@(VSort _) = lift0 v
-    bubble v@(VInt _) = lift0 v
-    bubble v@(VFlt _) = lift0 v
-    bubble v@(VStr _) = lift0 v
-    bubble v@VEmpty = lift0 v
-    bubble (VC v1 v2) = lift2 VC v1 v2
-    bubble (VGlue v1 v2) = lift2 VGlue v1 v2
-    bubble v@(VPatt _ _ _) = lift0 v
-    bubble (VPattType v) = lift1 VPattType v
-    bubble v@(VFV c (VarFree vs))
-      | null vs   = (Map.empty, v)
-      | otherwise = let (union,vs') = mapAccumL descend Map.empty vs
-                    in (Map.insert c (BubbleFree (length vs),1) union, VFV c (VarFree vs'))
-    bubble v@(VFV c (VarOpts n os))
-      | null os   = (Map.empty, v)
-      | otherwise = let (union,os') = mapAccumL (\acc (k,v) -> second (k,) $ descend acc v) Map.empty os
-                    in (Map.insert c (BubbleOpts n (map fst os),1) union, VFV c (VarOpts n os'))
-    bubble (VAlts v vs) = lift1L2 VAlts v vs
-    bubble (VStrs vs) = liftL VStrs vs
-    bubble (VMarkup tag attrs vs) =
-      let (union1,attrs') = mapAccumL descend' Map.empty attrs
-          (union2,vs')    = mapAccumL descendL union1 vs
-      in (union2, VMarkup tag attrs' vs')
-    bubble (VReset ctl mb_cv v id) =
-      let (union,v') = bubble v
-      in (Map.empty,VReset ctl mb_cv v' id)
-    bubble (VSymCat d i0 vs) =
-      let (union,vs') = mapAccumL descendC Map.empty vs
-      in (union, addVariants (VSymCat d i0 vs') union)
-    bubble v@(VError _) = lift0 v
-    bubble v@(VInts _ _) = lift0 v
-
-    lift0 v = (Map.empty, v)
-
-    lift1 f v =
-      let (union,v') = bubble v
-      in (union,f v')
-
-    liftL f vs =
-      let (union,vs') = mapAccumL descend Map.empty vs
-      in (union, addVariants (f vs') union)
-
-    liftL' f vs =
-      let (union,vs') = mapAccumL descend' Map.empty vs
-      in (union, addVariants (f vs') union)
-
-    lift1L f v vs =
-      let (choices,v') = bubble v
-          (union, vs') = mapAccumL descend (unitfy choices) vs
-      in (union, addVariants (f v' vs') union)
-
-    lift1L' f v vs =
-      let (choices,v') = bubble v
-          (union, vs') = mapAccumL descend' (unitfy choices) vs
-      in (union, addVariants (f v' vs') union)
-
-    lift1L2 f v vs =
-      let (choices,v') = bubble v
-          (union, vs') = mapAccumL descend2 (unitfy choices) vs
-      in (union, addVariants (f v' vs') union)
-
-    lift2L f v1 v2 vs =
-      let (choices1,v1') = bubble v1
-          (choices2,v2') = bubble v2
-          union = mergeChoices2 choices1 choices2
-          (union', vs') = mapAccumL descend union vs
-      in (union', addVariants (f v1' v2' vs') union')
-
-    lift2 f v1 v2 =
-      let (choices1,v1') = bubble v1
-          (choices2,v2') = bubble v2
-          union = mergeChoices2 choices1 choices2
-      in (union, addVariants (f v1' v2') union)
-
-    descend union v =
-      let (choices,v') = bubble v
-      in (mergeChoices1 union choices,v')
-
-    descend' :: Map.Map Choice (BubbleVariants,Int) -> (a,Value) -> (Map.Map Choice (BubbleVariants,Int),(a,Value))
-    descend' union (x,v) =
-      let (choices,v') = bubble v
-      in (mergeChoices1 union choices,(x,v'))
-
-    descend2 union (v1,v2) =
-      let (choices1,v1') = bubble v1
-          (choices2,v2') = bubble v2
-      in (mergeChoices1 (mergeChoices1 union choices1) choices2,(v1',v2'))
-
-    descendC union (i,(v,ty)) =
-      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'))
-
-    addVariants v = Map.foldrWithKey addVariant v
-      where
-        addVariant c (bvs,cnt) v
-          | cnt > 1   = VFV c $ case bvs of
-                                  BubbleFree k    -> VarFree (replicate k v)
-                                  BubbleOpts n os -> VarOpts n (map (\l -> (l,v)) os)
-          | otherwise = v
-
-    unitfy = fmap (\(n,_) -> (n,1))
-    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 False = VApp poison (cPredef,cPFalse) []
-
-occur s1 []          = False
-occur s1 s2@(_:tail) = check s1 s2
-  where
-    check xs        []  = False
-    check []        ys  = True
-    check (x:xs) (y:ys)
-      | x == y          = check xs ys
-    check _      _      = occur s1 tail
-
-occurs cs s2 = any (\c -> elem c s2) cs
-
-update lbl v []              = [(lbl,v)]
-update lbl v (a@(lbl',_):as)
-  | lbl==lbl'                = (lbl,v) : as
-  | otherwise                = a : update lbl v as
-
-update3 lbl o v []           = [(lbl,o,v)]
-update3 lbl o v (a@(lbl',o',_):as)
-  | lbl==lbl'                = (lbl,o||o',v) : as
-  | otherwise                = a : update3 lbl o v as
-
-patternMatch g s v0 []                      = v0
-patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
-  where
-    match env []              eqs      args  = eval g env s t args
-    match env (PT ty p   :ps) eqs      args  = match env (p:ps) eqs args
-    match env (PAlt p1 p2:ps) eqs      args  = match env (p1:ps) ((env,p2:ps,args,t):eqs) args
-    match env (PM q      :ps) eqs      args  = case lookupResDef gr q of
-                                                 Ok t    -> case eval g [] unit t [] of
-                                                              VPatt _ _ p -> match env (p:ps) eqs args
-                                                              _ -> error $ render (hang "Expected pattern macro:" 4
-                                                                                        (pp t))
-                                                 Bad msg -> error msg
-                                               where
-                                                 Gl gr _ = g
-    match env (PV v      :ps) eqs (arg:args) = 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,       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)
-          | 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)
-          | s1 == s2            -> match env ps eqs args
-        (PString s1, VEmpty)
-          | null s1             -> match env ps eqs args
-        (PSeq min1 max1 p1 min2 max2 p2,v)
-                          -> case value2string g v of
-                               Const str -> let n  = length str
-                                                lo = min1 `max` (n-fromMaybe n max2)
-                                                hi = (n-min2) `min` fromMaybe n max1
-                                                (ds,cs) = splitAt lo str
-
-                                                eqs' = matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args
-
-                                            in patternMatch g s v0 eqs'
-                               RunTime   -> v0
-                               NonExist  -> patternMatch g s v0 eqs
-        (PRep minp maxp p, v)
-                          -> case value2string g v of
-                               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)
-                                            in patternMatch g s v0 eqs'
-                               RunTime   -> v0
-                               NonExist  -> patternMatch g s v0 eqs
-        (PChar, VStr [_]) -> match env ps eqs args
-        (PChars cs, VStr [c])
-          | elem c cs     -> match env ps eqs args
-        (PInt n, VInt m)
-          | n == m        -> match env ps eqs args
-        (PFloat n, VFlt m)
-          | n == m        -> match env ps eqs args
-        _                 -> patternMatch g s v0 eqs
-
-    matchRec env []            as ps eqs args = match env ps eqs args
-    matchRec env ((lbl,p):pas) as ps eqs args =
-      case lookup lbl as of
-        Just tnk -> matchRec env pas as (p:ps) eqs (tnk:args)
-        Nothing  -> VError ("Missing value for label" <+> pp lbl)
-
-    matchStr env ps eqs i ds []     args =
-      (env,ps,(string2value (reverse ds)):(string2value []):args,t) : eqs
-    matchStr env ps eqs 0 ds cs     args =
-      (env,ps,(string2value (reverse ds)):(string2value cs):args,t) : eqs
-    matchStr env ps eqs i ds (c:cs) args =
-      (env,ps,(string2value (reverse ds)):(string2value (c:cs)):args,t) :
-      matchStr env ps eqs (i-1 :: Int) (c:ds) cs args
-
-    matchRep env 0 minp maxp p minq maxq q ps eqs args = eqs
-    matchRep env n minp maxp p minq maxq q ps eqs args =
-      matchRep env (n-1) minp maxp p (minp+minq) (liftM2 (+) maxp maxq) (PSeq minp maxp p minq maxq q) ps ((env,q:ps,args,t) : eqs) args
-
-vtableSelect g v0 ty cs v2 vs =
-  apply g (select (value2index v2 ty)) vs
-  where
-    select (Const (i,_)) = cs !! i
-    select (CSusp i k)   = VSusp i (\v -> select (k v)) []
-    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 (VSusp i k vs)    ty = CSusp i (\v -> value2index (apply g (k v) vs) ty)
-    value2index (VR as) (RecType lbls) = compute lbls
-      where
-        compute []              = pure (0,1)
-        compute ((lbl,ty):lbls) =
-          case lookup lbl as of
-            Just v  -> liftA2 (\(r, cnt) (r',cnt') -> (r*cnt'+r',cnt*cnt'))
-                              (value2index v ty)
-                              (compute lbls)
-            Nothing -> error (show ("Missing value for label" <+> pp lbl $$
-                                    "among" <+> hsep (punctuate (pp ',') (map fst as))))
-    value2index (VApp c q args) ty =
-      let (r ,ctxt,cnt ) = getIdxCnt q
-      in fmap (\(r', cnt') -> (r+r',cnt)) (compute ctxt args)
-      where
-        getIdxCnt q =
-          let (_,ResValue (L _ ty) idx) = getInfo q
-              (ctxt,QC p) = typeFormCnc ty
-              (_,ResParam _ (Just (_,cnt))) = getInfo p
-          in (idx,ctxt,cnt)
-
-        compute []              []     = pure (0,1)
-        compute ((_,_,ty):ctxt) (v:vs) =
-          liftA2 (\(r, cnt) (r',cnt') -> (r*cnt'+r',cnt*cnt'))
-                 (value2index v ty)
-                 (compute ctxt vs)
-
-        getInfo :: QIdent -> (ModuleName,Info)
-        getInfo q =
-          case lookupOrigInfo gr q of
-            Ok res  -> res
-            Bad msg -> error msg
-
-        Gl gr _ = g
-    value2index (VInt n)          ty
-      | Just max <- isTypeInts ty    = Const (fromIntegral n,fromIntegral max+1)
-    value2index (VFV c vs)        ty = CFV c (fmap (\v -> value2index v ty) vs)
-    value2index v ty = RunTime
-
-
-value2term :: Globals -> [Ident] -> Value -> Check Term
-value2term g xs v = do
-  res <- runEvalM g (value2termM False xs v)
-  case res of
-    [t] -> return t
-    ts  -> return (FV ts)
-
-data MetaState
-  = Bound Scope Value
-  | Narrowing   Choice Type
-  | Residuation Scope
-data OptionInfo
-  = OptionInfo
-      { optChoice  :: Choice
-      , optValue   :: Int
-      , optLabel   :: Value
-      , optChoices :: [Value]
-      }
-data State
-  = State
-      { input    :: [(Choice, Int)]
-      , choices  :: Map.Map Choice Int
-      , metaVars :: Map.Map MetaId MetaState
-      , options  :: [OptionInfo]
-      }
-
-type Cont r = State -> r -> [Message] -> CheckResult r [Message]
-newtype EvalM a = EvalM (forall r . Globals -> (a -> Cont r) -> Cont r)
-
-instance Functor EvalM where
-  fmap f (EvalM m) = EvalM (\g k -> m g (k . f))
-
-instance Applicative EvalM where
-  pure x = EvalM (\g k -> k x)
-  (EvalM f) <*> (EvalM h) = EvalM (\g k -> f g (\fn -> h g (\x -> k (fn x))))
-
-instance Alternative EvalM where
-  empty = EvalM (\g k _ r msgs -> Success r msgs)
-  (EvalM f) <|> (EvalM g) = EvalM $ \gl k state r msgs ->
-     case f gl k state r msgs of
-       Fail msg  msgs -> Fail msg msgs
-       Success r msgs -> g gl k state r msgs
-
-instance Monad EvalM where
-  (EvalM f) >>= h = EvalM (\g k -> f g (\x -> case h x of {EvalM h -> h g k}))
-
-instance MonadFail EvalM where
-  fail msg = EvalM (\g k _ _ msgs -> Fail (pp msg) msgs)
-
-instance MonadPlus EvalM where
-
-evalError msg = EvalM (\g k _ _ msgs -> Fail msg msgs)
-
-evalWarn msg = EvalM (\g k state r msgs -> k () state r (msg:msgs))
-
-runEvalM :: Globals -> EvalM a -> Check [a]
-runEvalM g (EvalM f) = Check $ \(es,ws) ->
-  case f g (\x state xs ws -> Success (x:xs) ws) empty [] ws of
-    Fail   msg ws -> Fail msg (es,ws)
-    Success xs ws -> Success (reverse xs) (es,ws)
-  where
-    empty = State [] Map.empty Map.empty []
-
-runEvalMWithInput :: Globals -> [(Choice,Int)] -> EvalM a -> Check [(a, [OptionInfo])]
-runEvalMWithInput g input (EvalM f) = Check $ \(es,ws) ->
-  case f g (\x (State _ cs mvs os) xs ws -> Success ((x,reverse os):xs) ws) init [] ws of
-    Fail   msg ws -> Fail msg (es,ws)
-    Success xs ws -> Success (reverse xs) (es,ws)
-  where
-    init = State input Map.empty Map.empty []
-
-reset :: EvalM a -> EvalM [a]
-reset (EvalM f) = EvalM $ \g k state r ws ->
-  case f g (\x state xs ws -> Success (x:xs) ws) state [] ws of
-    Fail   msg ws -> Fail msg ws
-    Success xs ws -> k (reverse xs) state r ws
-
-reset1 :: EvalM a -> EvalM (Maybe a)
-reset1 (EvalM f) = EvalM $ \g k state r ws ->
-  case f g (\x' state x ws -> Success (x <|> Just x') ws) state Nothing ws of
-    Fail  msg ws -> Fail msg ws
-    Success x ws -> k x state r ws
-
-globals :: EvalM Globals
-globals = EvalM (\g k -> k g)
-
-variants :: Choice -> [a] -> EvalM a
-variants c xs = EvalM (\g k state@(State input choices metas opts) r msgs ->
-  case Map.lookup c choices of
-    Just j  -> k (xs !! j) state r msgs
-    Nothing -> backtrack 0 xs k input choices metas opts r msgs)
-  where
-    backtrack j []     k input choices metas opts r msgs = Success r msgs
-    backtrack j (x:xs) k input choices metas opts r msgs =
-      case k x (State input (Map.insert c j choices) metas opts) r msgs of
-        Fail    msg msgs -> Fail msg msgs
-        Success r   msgs -> backtrack (j+1) xs k input choices metas opts r msgs
-
-variants' :: Choice -> (a -> EvalM Term) -> [a] -> EvalM Term
-variants' c f xs = EvalM (\g k state@(State input choices metas opts) r msgs ->
-  case Map.lookup c choices of
-    Just j  -> case f (xs !! j) of
-                 EvalM f -> f g k state r msgs
-    Nothing -> case backtrack g 0 xs input choices metas opts [] msgs of
-                 Fail    msg msgs -> Fail msg msgs
-                 Success ts  msgs -> k (FV (reverse ts)) state r msgs)
-  where
-    backtrack g j []     input choices metas opts ts msgs = Success ts msgs
-    backtrack g j (x:xs) input choices metas opts ts msgs =
-      case f x of
-        EvalM f -> case f g (\t st ts msgs -> Success (t:ts) msgs) (State input (Map.insert c j choices) metas opts) ts msgs of
-                     Fail    msg msgs -> Fail msg msgs
-                     Success ts  msgs -> backtrack g (j+1) xs input choices metas opts ts msgs
-
-try :: Int -> (a -> EvalM b) -> ([b] -> EvalM b) -> [a] -> EvalM b
-try sz f select xs = EvalM (\g k state r msgs ->
-  let (state',res,msgs') = backtrack sz g xs state [] msgs
-  in case select res of
-       EvalM f' -> f' g k state' r msgs')
-  where
-    backtrack sz g []     state res msgs = (state,res,msgs)
-    backtrack sz g (x:xs) state res msgs =
-      case f x of
-        EvalM f -> case f g (\y state' (_,ys) msgs -> Success (cut sz state state',y:ys) msgs) state (state,res) msgs of
-                     Fail msg _               -> backtrack sz g xs state res msgs
-                     Success (state,res) msgs -> backtrack sz g xs state res msgs
-
-    cut sz state state' = state'{metaVars=Map.mapWithKey select (metaVars state')}
-      where
-        select k ms
-          | k <= sz   = ms
-          | otherwise = case Map.lookup k (metaVars state) of
-                          Just ms -> ms
-                          Nothing -> ms
-
-newResiduation :: Scope -> EvalM MetaId
-newResiduation scope = EvalM (\g k (State input choices metas opts) r msgs ->
-  let meta_id = Map.size metas+1
-  in k meta_id (State input choices (Map.insert meta_id (Residuation scope) metas) opts) r msgs)
-
-checkpoint :: EvalM Int
-checkpoint = EvalM (\g k state r msgs ->
-  k (Map.size (metaVars state)) state r msgs)
-
-getMeta :: MetaId -> EvalM MetaState
-getMeta i = EvalM (\g k state r msgs ->
-  case Map.lookup i (metaVars state) of
-    Just ms -> k ms state r msgs
-    Nothing -> Fail ("Metavariable ?"<>pp i<+>"is not defined") msgs) 
-
-setMeta :: MetaId -> MetaState -> EvalM ()
-setMeta i ms = EvalM (\g k (State input choices metas opts) r msgs ->
-  let state' = State input choices (Map.insert i ms metas) opts
-  in k () state' r msgs)
-
-value2termM :: Bool -> [Ident] -> Value -> EvalM Term
-value2termM flat xs (VApp c q vs) =
-  foldM (\t v -> fmap (App t) (value2termM flat xs v)) (if fst q == cPredef then Q q else QC q) vs
-value2termM flat xs (VMeta i vs) = do
-  mv <- getMeta i
-  case mv of
-    Bound scope v -> do g <- globals
-                        value2termM flat (map fst scope) (apply g v vs)
-    Residuation _ -> foldM (\t v -> fmap (App t) (value2termM flat xs v)) (Meta i) vs
-value2termM flat xs (VSusp j k vs) =
-  let v = k (VGen maxBound vs)
-  in value2termM flat xs v
-value2termM flat xs (VGen j tnks) =
-  foldM (\e1 tnk -> fmap (App e1) (value2termM flat xs tnk)) (Vr (reverse xs !! j)) tnks
-value2termM flat xs (VClosure env s (Abs b x t)) = do
-  g <- globals
-  let v  = eval g ((x,VGen (length xs) []):env) s t []
-      x' = mkFreshVar xs x
-  t <- value2termM flat (x':xs) v
-  return (Abs b x' t)
-value2termM flat xs (VClosure env s t) = do
-  return t
-value2termM flat xs (VProd b x v1 (VClosure env c2 t2)) = do
-  g <- globals
-  t1 <- value2termM flat xs v1
-  t2 <- value2termM flat (x:xs) (eval g ((x,VGen (length xs) []):env) c2 t2 [])
-  return (Prod b (mkFreshVar xs x) t1 t2)
-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
-  lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
-  return (RecType lbls)
-value2termM flat xs (VR as) = do
-  as <- mapM (\(lbl,v) -> fmap (\t -> (lbl,(Nothing,t))) (value2termM flat xs v)) as
-  return (R as)
-value2termM flat xs (VP v lbl vs) = do
-  t <- value2termM flat xs v
-  foldM (\e1 tnk -> fmap (App e1) (value2termM flat xs tnk)) (P t lbl) vs
-value2termM flat xs (VExtR v1 v2) = do
-  t1 <- value2termM flat xs v1
-  t2 <- value2termM flat xs v2
-  return (ExtR t1 t2) 
-value2termM flat xs (VTable v1 v2) = do
-  t1 <- value2termM flat xs v1
-  t2 <- value2termM flat xs v2
-  return (Table t1 t2)
-value2termM flat xs (VT vty env s cs)= do
-  ty <- value2termM flat xs vty
-  cs <- forM cs $ \(p,t) -> do
-          let (_,xs',env') = pattVars (length xs,xs,env) p
-          g <- globals
-          t <- value2termM flat xs' (eval g env' s t [])
-          return (p,t)
-  return (T (TTyped ty) cs)
-value2termM flat xs (VV vty vs)= do
-  ty <- value2termM flat xs vty
-  ts <- mapM (value2termM flat xs) vs
-  return (V ty ts)
-value2termM flat xs (VS v1 v2 vs) =
-  case v1 of
-    VT vty env s cs -> do
-          ty <- value2termM flat xs vty
-          g  <- globals
-          cs <- forM cs $ \(p,t) -> do
-                  let (_,xs',env') = pattVars (length xs,xs,env) p
-                  t <- value2termM flat xs' (eval g env' s t vs)
-                  return (p,t)
-          t2 <- value2termM flat xs v2
-          return (S (T (TTyped ty) cs) t2)
-
-    VV vty vs' -> do
-          ty <- value2termM flat xs vty
-          g <- globals
-          ts <- forM vs' $ \v ->
-                  value2termM flat xs (apply g v vs)
-          t2 <- value2termM flat xs v2
-          return (S (V ty ts) t2)
-
-    v1                           -> do
-          t1 <- value2termM flat xs v1
-          t2 <- value2termM flat xs v2
-          foldM (\e1 tnk -> fmap (App e1) (value2termM flat xs tnk)) (S t1 t2) vs
-value2termM flat xs (VSort s) = return (Sort s)
-value2termM flat xs (VStr tok) = return (K tok)
-value2termM flat xs (VInt n) = return (EInt n)
-value2termM flat xs (VFlt n) = return (EFloat n)
-value2termM flat xs VEmpty = return Empty
-value2termM flat xs (VC v1 v2) = do
-  t1 <- value2termM flat xs v1
-  t2 <- value2termM flat xs v2
-  return (C t1 t2)
-value2termM flat xs (VGlue v1 v2) = do
-  t1 <- value2termM flat xs v1
-  t2 <- value2termM flat xs v2
-  return (Glue t1 t2)
-value2termM True xs (VFV i (VarFree vs)) = do
-  v <- variants i vs
-  value2termM True xs v
-value2termM False xs (VFV c (VarFree vs)) = variants' c (value2termM False xs) vs
-value2termM flat xs (VFV c (VarOpts n os)) =
-  EvalM $ \g k (State input choices metas opts) r msgs ->
-    let (j,input',choices',opts') =
-          case Map.lookup c choices of
-            Just j  -> (j,input,choices,opts)
-            Nothing -> case input of
-                         (c',j):input | c == c' -> let oi = OptionInfo c j n (map fst os)
-                                                   in (j,input,Map.insert c j choices,oi:opts)
-                         _                      -> let oi = OptionInfo c 0 n (map fst os)
-                                                   in (0,[],Map.insert c 0 choices,oi:opts)
-    in case os `maybeAt` j of
-         Just (l,t) -> case value2termM flat xs t of
-                         EvalM f -> f g k (State input' choices' metas opts') r msgs
-         Nothing    -> Fail ("Index" <+> j <+> "out of bounds for option:" $$ ppValue Unqualified 0 n) msgs
-value2termM flat xs (VPatt min max p) = return (EPatt min max p)
-value2termM flat xs (VPattType v) = do t <- value2termM flat xs v
-                                       return (EPattType t)
-value2termM flat xs (VAlts vd vas) = do
-  d <- value2termM flat xs vd
-  as <- forM vas $ \(vt,vs) -> do
-           t <- value2termM flat xs vt
-           s <- value2termM flat xs vs
-           return (t,s)
-  return (Alts d as)
-value2termM flat xs (VStrs vs) = do
-  ts <- mapM (value2termM flat xs) vs
-  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 (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)
-  reduce ctl mb_cv ts
-  where
-    reduce ctl mb_cv ts
-      | ctl == cConcat = do
-         ts <- case mb_cv of
-                 Just (VInt n) -> return (genericTake n ts)
-                 Nothing       -> return ts
-                 _             -> evalError (pp "[concat: .. | ..] requires an integer constant")
-         case ts of
-           [t] -> return t
-           ts  -> return (Markup identW [] (map noLoc ts))
-      | ctl == cConcat' = do
-         ts <- case mb_cv of
-                 Just (VInt n) -> return (genericTake n ts)
-                 Nothing       -> return ts
-                 _             -> evalError (pp "[concat: .. | ..] requires an integer constant")
-         case ts of
-           []  -> mzero
-           [t] -> return t
-           ts  -> return (Markup identW [] (map noLoc ts))
-      | ctl == cOne =
-         case (ts,mb_cv) of
-           ([]  ,Nothing) -> mzero
-           ([]  ,Just v)  -> value2termM flat xs v
-           (t:ts,_)       -> return t
-      | ctl == cSelect =
-         case mb_cv of
-           Just (VInt n) | n >= 0    -> select n      ts'
-                         | otherwise -> select (-n-1) (reverse ts')
-                         where
-                           ts' = sortBy compareKey ts
-
-                           select _ []     = mzero
-                           select 0 (t:ts) =
-                             case t of
-                               R rs -> case lookup (ident2label cp1) rs  of
-                                         Just (_,t) -> return t
-                                         Nothing    -> evalError (pp "Missing label p1")
-                               _    -> 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
-           ([]  ,Just v)  -> value2termM flat xs v
-           (ts,_)         -> msum (map pure ts)
-      | ctl == cList =
-         case (ts,mb_cv) of
-           ([],       _) -> mzero
-           ([t],      _) -> return t
-           (ts,Just cv)  ->
-             do let Just (mn,id) = mb_qid
-                    cat = showIdent id
-                ct <- value2termM flat xs cv
-                t <- listify mn cat ts
-                return (App (App (QC (mn,identS ("Conj"++cat))) ct) t)
-           _             -> evalError (pp "[list: .. | ..] requires an argument")
-      | ctl == cLen =
-         case mb_cv of
-           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)
-    listify mn cat (t1:ts) = do t2 <- listify mn cat ts
-                                return (App (App (QC (mn,identS ("Cons"++cat))) t1) t2)
-
-    compareKey (R rs1) (R rs2) =
-      case (lookup (ident2label cp2) rs1, lookup (ident2label cp2) rs2) of
-        (Just (_,K s1), Just (_,K s2)) -> compare s1 s2
-
-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)
-
-
-pattVars st (PP _ ps)    = foldl pattVars st ps
-pattVars st (PV x)       = case st of
-                             (i,xs,env) -> (i+1,x:xs,(x,VGen i []):env)
-pattVars st (PR as)      = foldl (\st (_,p) -> pattVars st p) st as
-pattVars st (PT ty p)    = pattVars st p
-pattVars st (PAs x p)    = case st of
-                             (i,xs,env) -> pattVars (i+1,x:xs,(x,VGen i []):env) p
-pattVars st (PImplArg p) = pattVars st p
-pattVars st (PSeq _ _ p1 _ _ p2) = pattVars (pattVars st p1) p2
-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 (VMeta i vs) = prec d 4 (hsep ((if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs))
-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 (VClosure env c t) = pp "[|" <> ppTerm q 4 t <> pp "|]"
-ppValue q d (VProd bt x a b) =
-  if x == identW && bt == Explicit
-    then prec d 0 (ppValue q 4 a <+> "->" <+> ppValue q 0 b)
-    else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppValue q 0 a) <+> "->" <+> ppValue q 0 b)
-ppValue q d (VRecType xs ext)
-  | 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 <+> (if o then ":" else ":?") <+> ppValue q 0 v | (l,o,v) <- xs] ++ [pp ".." | ext])))
-ppValue q d (VR _) = pp "VR"
-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)
-ppValue q d (VT t _ _ cs) = "table" <+> ppValue q 0 t <+> '{' $$
-                               nest 2 (vcat (punctuate ';' (map (ppCase q) cs))) $$
-                            '}'
-                            where
-                              ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
-ppValue q d (VV _ _) = pp "VV"
-ppValue q d (VS v1 v2 vs) = prec d 3 (hsep (hang (ppValue q 3 v1) 2 ("!" <+> ppValue q 4 v2) : map (ppValue q 5) vs))
-ppValue q d (VSort s) = pp s
-ppValue q d (VInt n) = pp n
-ppValue q d (VFlt f) = pp f
-ppValue q d (VStr s) = ppTerm q d (K s)
-ppValue q d VEmpty = pp "[]"
-ppValue q d (VC v1 v2) = prec d 1 (hang (ppValue q 2 v1) 2 ("++" <+> ppValue q 1 v2))
-ppValue q d (VGlue v1 v2) = prec d 2 (ppValue q 3 v1 <+> '+'  <+> ppValue q 2 v2)
-ppValue q d (VPatt _ _ p) = prec d 4 ('#' <+> ppPatt q 2 p)
-ppValue q d (VPattType v) = prec d 4 ("pattern" <+> ppValue q 0 v)
-ppValue q d (VFV i vs) = prec d 4 ("variants" <+> pp i <+> braces (fsep (punctuate ';' (map (ppValue q 0) (unvariants vs)))))
-ppValue q d (VAlts e xs) = prec d 4 ("pre" <+> braces (ppValue q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
-ppValue q d (VStrs _) = pp "VStrs"
-ppValue q d (VMarkup _ _ _) = pp "VMarkup"
-ppValue q d (VReset ctl ct t _) = pp "[" <> pp ctl <> 
-                                  maybe PP.empty (\v -> pp ':' <+> ppValue q 6 v) ct <>
-                                  pp "|" <> ppValue q 0 t <>
-                                  pp "]"
-ppValue q d (VSymCat i r rs) = pp '<' <> pp i <> pp ',' <> pp r <> pp '>'
-ppValue q d (VError msg) = prec d 4 (pp "error" <+> ppTerm q 5 (K (show msg)))
-ppValue q d (VInts n ext)
-  | ext       = prec d 4 (pp "Ints" <+> brackets (pp n <> ".."))
-  | otherwise = prec d 4 (pp "Ints" <+> pp n)
-
-ppAltern q (x,y) = ppValue q 0 x <+> '/' <+> ppValue q 0 y
-
-prec d1 d2 doc
-  | d1 > d2   = parens doc
-  | otherwise = doc
-
-value2string g v = fmap (\(_,ws,_) -> unwords ws) (value2string' g v False [] [])
-
-value2string' g (VMeta i vs)   b ws        qs = CSusp i (\v -> value2string' g (apply g v vs) b ws qs)
-value2string' g (VSusp i k vs) b ws        qs = CSusp i (\v -> value2string' g (apply g (k v) vs) b ws qs)
-value2string' g (VStr w1)     True (w2:ws) qs = Const (False,(w1++w2):ws,qs)
-value2string' g (VStr w)         _ ws      qs = Const (False,w       :ws,qs)
-value2string' g VEmpty           b ws      qs = Const (b,ws,qs)
-value2string' g (VC v1 v2)       b ws      qs = concat v1 (value2string' g v2 b ws qs)
-  where
-    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
-  | q == (cPredef,cNonExist)              = NonExist
-value2string' g (VApp c 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
-  | 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
-  | 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
-  | q == (cPredef,cALL_CAPIT) = all_capit ws
-  where
-    all_capit []       = Const (b,[],q:qs)
-    all_capit (w : ws) = Const (b,map toUpper w : ws,qs)
-value2string' g (VAlts vd vas) b  ws     qs =
-  case ws of
-    []    -> value2string' g vd b ws qs
-    (w:_) -> pre vd vas w b ws qs
-  where
-    pre vd []                 w            = value2string' g vd
-    pre vd ((v,VStrs ss):vas) w
-      | or [startsWith s w | VStr s <- ss] = value2string' g v
-      | otherwise                          = pre vd vas w
-value2string' g (VFV s vs) b      ws     qs =
-  CFV s (fmap (\v -> value2string' g v b ws qs) vs)
-value2string' _ _ _ _ _ = RunTime
-
-startsWith []          _ = True
-startsWith (x:xs) (y:ys)
-  | x == y               = startsWith xs ys
-startsWith      _      _ = False
-
-string2value s = string2value' (words s)
-
-string2value' []     = VEmpty
-string2value' [w]    = VStr w
-string2value' (w:ws) = VC (VStr w) (string2value' ws)
-
-value2int g (VMeta i vs)     = CSusp i (\v -> value2int g (apply g v vs))
-value2int g (VSusp i k vs)   = CSusp i (\v -> value2int g (apply g (k v) vs))
-value2int g (VInt n)         = Const n
-value2int g (VFV s vs)       = CFV s (fmap (value2int g) vs)
-value2int g _                = RunTime
-
-value2float g (VMeta i vs)     = CSusp i (\v -> value2float g (apply g v vs))
-value2float g (VSusp i k vs)   = CSusp i (\v -> value2float g (apply g (k v) vs))
-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)
-  | 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))
-value2expr g xs (VGen j vs)    = foldl (\e v -> fmap EApp e <*> value2expr g xs v) (pure (EVar (length xs - j - 1))) vs
-value2expr g xs (VClosure env s (Abs b x t)) =
-  let v  = eval g ((x,VGen (length xs) []):env) s t []
-      x' = mkFreshVar xs x
-  in fmap (EAbs b (showIdent x')) (value2expr g (x':xs) v)
-value2expr g xs (VInt n)       = pure (ELit (LInt n))
-value2expr g xs (VFlt f)       = pure (ELit (LFlt f))
-value2expr g xs (VFV s vs)     = CFV s (fmap (value2expr g xs) vs)
-value2expr g xs v              = fmap (ELit . LStr) (value2string g v)
-
-newtype Choice = Choice { unchoice :: Integer }
-  deriving (Eq,Ord,Pretty,Show)
-
-unit :: Choice
-unit = Choice 1
-
-poison :: Choice
-poison = Choice (-1)
-
-split :: Choice -> (Choice,Choice)
-split (Choice c) = (Choice (2*c), Choice (2*c+1))
-
-split3 :: Choice -> (Choice,Choice,Choice)
-split3 (Choice c) = (Choice (4*c), Choice (4*c+1), Choice (2*c+1))
-
-split4 :: Choice -> (Choice,Choice,Choice,Choice)
-split4 (Choice c) = (Choice (4*c), Choice (4*c+1), Choice (4*c+2), Choice (4*c+3))
-
-mapC :: (Choice -> a -> b) -> Choice -> [a] -> [b]
-mapC f c []     = []
-mapC f c [x]    = [f c x]
-mapC f c (x:xs) =
-  let (!c1,!c2) = split c
-  in f c1 x : mapC f c2 xs
-
-forC :: Choice -> [a] -> (Choice -> a -> b) -> [b]
-forC c xs f = mapC f c xs
-
-mapCM :: Monad m => (Choice -> a -> m b) -> Choice -> [a] -> m [b]
-mapCM f c []     = return []
-mapCM f c [x]    = do y <- f c x
-                      return [y]
-mapCM f c (x:xs) = do
-  let (!c1,!c2) = split c
-  y  <- f c1 x
-  ys <- mapCM f c2 xs
-  return (y:ys)
-
-forCM :: Monad m => Choice -> [a] -> (Choice -> a -> m b) -> m [b]
-forCM c xs f = mapCM f c xs
diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index 6bfcbeabf..c1a1f5aee 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -13,7 +13,7 @@ import GF.Grammar.Macros
 import GF.Grammar.Predef
 import GF.Grammar.Printer hiding (ppValue)
 import GF.Text.Pretty hiding (empty)
-import GF.Compile.Compute.Concrete2 hiding ( getMeta, setMeta, globals, variants )
+import GF.Compile.Compute.Concrete hiding ( getMeta, setMeta, globals, variants )
 import qualified GF.Text.Pretty as PP
 import qualified Data.Map as Map
 import qualified Data.Set as Set
diff --git a/src/compiler/api/GF/Compile/GrammarToCanonical.hs b/src/compiler/api/GF/Compile/GrammarToCanonical.hs
index c251c933e..7b859b1d1 100644
--- a/src/compiler/api/GF/Compile/GrammarToCanonical.hs
+++ b/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.Concrete
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Data.Maybe(mapMaybe,fromMaybe)
diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index a4ffa1ab1..d0caa76ff 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -10,7 +10,7 @@ import GF.Grammar hiding (Env, VGen, VApp, VRecType, ppValue)
 import GF.Grammar.Lookup
 import GF.Grammar.Predef
 import GF.Grammar.Lockfield
-import GF.Compile.Compute.Concrete2
+import GF.Compile.Compute.Concrete
 import GF.Infra.CheckM
 import GF.Data.ErrM ( Err(Ok, Bad) )
 import Control.Applicative(Applicative(..),(<|>))
diff --git a/src/compiler/api/GF/Interactive.hs b/src/compiler/api/GF/Interactive.hs
index 802c914e5..e6f04309d 100644
--- a/src/compiler/api/GF/Interactive.hs
+++ b/src/compiler/api/GF/Interactive.hs
@@ -14,8 +14,7 @@ import GF.Command.Abstract
 import GF.Command.Parse(readCommandLine,pCommand,readTransactionCommand)
 import GF.Compile.Rename(renameSourceTerm)
 import GF.Compile.TypeCheck.Concrete(inferLType)
-import qualified GF.Compile.Compute.Concrete as O(normalForm,stdPredef,Globals(..))
-import GF.Compile.Compute.Concrete2(stdPredef,Globals(..))
+import GF.Compile.Compute.Concrete(stdPredef,normalForm,Globals(..))
 import GF.Compile.GeneratePMCFG(pmcfgForm,type2fields)
 import GF.Data.Operations (Err(..))
 import GF.Data.Utilities(whenM,repeatM)
@@ -316,18 +315,18 @@ 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)
       (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
-      let g = Gl sgr (stdPredef g)
       rules <- pmcfgForm g t ctxt res_ty
       return (rules,type2fields sgr res_ty)
 
diff --git a/src/compiler/api/GF/Term.hs b/src/compiler/api/GF/Term.hs
deleted file mode 100644
index 0b2bd2626..000000000
--- a/src/compiler/api/GF/Term.hs
+++ /dev/null
@@ -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
diff --git a/src/compiler/gf.cabal b/src/compiler/gf.cabal
index e79a7fdad..802f58b58 100644
--- a/src/compiler/gf.cabal
+++ b/src/compiler/gf.cabal
@@ -76,7 +76,6 @@ library
     GF.Interactive
     GF.Compiler
     GF.Grammar
-    GF.Term
     GF.Compile
     GF.CompileInParallel
     GF.Data.ErrM
@@ -106,7 +105,6 @@ library
     GF.Compile.CFGtoPGF
     GF.Compile.CheckGrammar
     GF.Compile.Compute.Concrete
-    GF.Compile.Compute.Concrete2
     GF.Compile.ExampleBased
     GF.Compile.Export
     GF.Compile.GenerateBC

From 8282b3e4ce61372be684fcd5fed75a25b1e72823 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 14 Nov 2025 11:04:11 +0100
Subject: [PATCH 059/144] fixing the lock fields

---
 src/compiler/api/GF/Compile/CheckGrammar.hs |  5 +--
 src/compiler/api/GF/Grammar/Lockfield.hs    | 34 ++++++++++-----------
 src/compiler/api/GF/Grammar/Lookup.hs       | 26 +++++-----------
 3 files changed, 27 insertions(+), 38 deletions(-)

diff --git a/src/compiler/api/GF/Compile/CheckGrammar.hs b/src/compiler/api/GF/Compile/CheckGrammar.hs
index c734d8cb7..350e2c81c 100644
--- a/src/compiler/api/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/api/GF/Compile/CheckGrammar.hs
@@ -33,6 +33,7 @@ import GF.Compile.Compute.Concrete(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
@@ -198,9 +199,9 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
 
     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 g 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
diff --git a/src/compiler/api/GF/Grammar/Lockfield.hs b/src/compiler/api/GF/Grammar/Lockfield.hs
index 53e58a3ad..9eb487723 100644
--- a/src/compiler/api/GF/Grammar/Lockfield.hs
+++ b/src/compiler/api/GF/Grammar/Lockfield.hs
@@ -14,29 +14,28 @@
 -- 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
-lockRecType c t@(RecType rs) = 
-  let lab = lockLabel c in
-  return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"]
-    then t --- don't add an extra copy of lock field, nor predef cats
-    else RecType (rs ++ [(lockLabel c,  RecType [])])
-lockRecType c t = plusRecType t $ RecType [(lockLabel c,  RecType [])]
-
-unlockRecord :: Monad m => Ident -> Term -> m Term
-unlockRecord c ft = do
-  let (xs,t) = termFormCnc ft
-  let lock = R [(lockLabel c,  (Just (RecType []),R []))]
-  case plusRecord t lock of
-    Ok t' -> return $ mkAbs xs t'
-    _ -> return $ mkAbs xs (ExtR t lock)
+lock :: Ident -> Term -> Term
+lock c t@(RecType rs) =
+  let lbl = lockLabel c
+  in if elem lbl (map fst rs) || elem c [cString,cInt]
+       then t --- don't add an extra copy of lock field, nor predef cats
+       else RecType (rs ++ [(lbl, RecType [])])
+lock c t@(R rs) =
+  let lbl = lockLabel c
+  in if elem lbl (map fst rs)
+       then t
+       else R (rs ++ [(lbl, (Just (RecType []),R []))])
+lock c (Abs b x t) = Abs b x (lock c t)
+lock c (FV ts)     = FV (map (lock c) ts)
+lock c t           = t
 
 lockLabel :: Ident -> Label
 lockLabel c = LIdent $! prefixRawIdent lockPrefix (ident2raw c)
@@ -46,5 +45,4 @@ isLockLabel l = case l of
   LIdent c -> isPrefixOf lockPrefix c
   _        -> False
 
-
 lockPrefix = rawIdentS "lock_"
diff --git a/src/compiler/api/GF/Grammar/Lookup.hs b/src/compiler/api/GF/Grammar/Lookup.hs
index b756a2abb..6d427fc5d 100644
--- a/src/compiler/api/GF/Grammar/Lookup.hs
+++ b/src/compiler/api/GF/Grammar/Lookup.hs
@@ -45,10 +45,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 =
@@ -101,7 +97,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 +105,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 _ _ _ _ _        -> lock c defLinType
+        CncCat (Just (L _ ty)) _ _ _ _ -> return (lock c ty)
+        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 +124,8 @@ lookupResType gr (m,c) = do
 
     -- used in reused concrete
     CncCat _ _ _ _ _ -> return typeType
-    CncFun (Just (_,cat,cont,val)) _ _ _ -> do
-          val' <- lock cat val
-          return $ mkProd cont val' []
+    CncFun (Just (args,cat,cont,val)) _ _ _ ->
+           return $ (mkFunType (zipWith (\cat (_,_,ty) -> lock cat ty) args cont) (lock cat val))
     AnyInd _ n        -> lookupResType gr (n,c)
     ResParam _ _    -> return typePType
     ResValue (L _ t) _ -> return t
@@ -145,8 +140,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 val' []
+          ret $ mkProd cont (lock cat val) []
     ResParam _ _    -> ret typePType
     ResValue (L _ t) _ -> ret t
     ResOverload os tysts -> do
@@ -265,13 +259,9 @@ allOpers gr =
       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

From 08bd669200092d89d7e02d5dea596751c2efd688 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 14 Nov 2025 11:27:18 +0100
Subject: [PATCH 060/144] more user friendly error for overload resolution
 failure

---
 .../api/GF/Compile/TypeCheck/Concrete.hs      | 20 ++++++++++++-------
 1 file changed, 13 insertions(+), 7 deletions(-)

diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index d0caa76ff..f51798215 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -632,14 +632,14 @@ resolveOverloads scope c t0 q args mb_ty = do
                           (c2,c3)  = split c23
                       (t,ty) <- reapply1 scope c1 t (eval g [] c2 ty []) args
                       instSigma scope c3 t ty mb_ty
-    Ok ttys     -> do let (c1,c23) = split c
+    Ok ttys0    -> do let (c1,c23) = split c
                           (c2,c3)  = split c23
                       sz <- checkpoint
                       arg_tys <- mapCM (checkArg g) c1 args
-                      let v_ttys = mapC (\c (t,ty) -> (t,eval g [] c ty [])) c2 ttys
+                      let v_ttys = mapC (\c (t,ty) -> (t,eval g [] c ty [])) c2 ttys0
                       try sz
                           (\(fun,fun_ty) -> reapply2 scope c3 fun fun_ty arg_tys mb_ty)
-                          (\ttys -> fmap (\(ts,ty) -> (mkFV ts,ty)) (snd (minimum g ttys)))
+                          (\ttys -> fmap (\(ts,ty) -> (mkFV ts,ty)) (snd (minimum g ttys0 arg_tys ttys)))
                           v_ttys
   where
     checkArg g c (ImplArg arg) = do
@@ -656,12 +656,18 @@ resolveOverloads scope c t0 q args mb_ty = do
     mkFV [t] = t
     mkFV ts  = FV ts
 
-    minimum g []                    = (maxBound,err)
+    minimum g ttys0 arg_tys []                    = (maxBound,err)
       where
-        err = evalError (pp "Overload resolution failed")
-    minimum g (tty@(t,ty):ttys) =
+        err = evalError ("Overload resolution failed" $$ 
+                         "of term " <+> pp (foldl App (Q q) args) $$
+                         "with alternatives" $$
+                         nest 4 (vcat [pp (snd q) <+> pp ':' <+> ppTerm Terse 0 ty | (_,ty) <- ttys0]) $$
+                         "and argument types" $$
+                         nest 4 (fsep (punctuate (pp ',') [ppValue Terse 0 ty | (_,_,ty) <- arg_tys])))
+
+    minimum g ttys0 arg_tys (tty@(t,ty):ttys) =
       let a        = arity ty
-          (a',res) = minimum g ttys
+          (a',res) = minimum g ttys0 arg_tys ttys
       in case compare a a' of
            GT -> (a',res)
            EQ -> (a',join t ty res)

From 6c9a197b37d38e650e9b86fbf54351d252a3029c Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 14 Nov 2025 12:05:11 +0100
Subject: [PATCH 061/144] more helpful error when lin X is missing

---
 src/compiler/api/GF/Compile/SubExOpt.hs           |  3 ++-
 src/compiler/api/GF/Compile/TypeCheck/Concrete.hs | 13 ++++++++++---
 src/compiler/api/GF/Grammar/Lockfield.hs          |  4 ++--
 src/compiler/api/GF/Infra/Ident.hs                |  6 ++++--
 4 files changed, 18 insertions(+), 8 deletions(-)

diff --git a/src/compiler/api/GF/Compile/SubExOpt.hs b/src/compiler/api/GF/Compile/SubExOpt.hs
index 09ec3e568..6b9d908b9 100644
--- a/src/compiler/api/GF/Compile/SubExOpt.hs
+++ b/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''")
diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index f51798215..80c71ac8c 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -6,6 +6,7 @@ module GF.Compile.TypeCheck.Concrete ( checkLType, checkLType', inferLType, infe
 -- Practical type inference for arbitrary-rank types.
 -- 14 September 2011
 
+import Prelude hiding ((<>))
 import GF.Grammar hiding (Env, VGen, VApp, VRecType, ppValue)
 import GF.Grammar.Lookup
 import GF.Grammar.Predef
@@ -1083,15 +1084,21 @@ subsCheckRho scope t ty1@(VRecType rs1 ext1) ty2@(VRecType rs2 ext2) = do      -
       mkField scope l (mb_ty,t) (Just ty1) ty2 = do
         (t,ty1,ty2) <- subsCheckRho scope t ty1 ty2
         return ((l, (mb_ty,t)), (l, True, ty1))
-      mkField scope l (mb_ty,t) Nothing    ty2
-        | isLockLabel l = return ((l, (Just (RecType []),R [])), (l, True, ty2))
-        | otherwise     = return ((l, (mb_ty,t)), (l, True, ty2))
+      mkField scope l (mb_ty,t) Nothing    ty2 =
+        case isLockLabel l of
+          Just _  -> return ((l, (Just (RecType []),R [])), (l, True, ty2))
+          Nothing -> return ((l, (mb_ty,t)), (l, True, ty2))
 
   (scope,mkProj,wrap) <- mkAccess scope t
 
   let fields = [(l,o2,ty2,lookup3 l rs1) | (l,o2,ty2) <- rs2]
   case [l | (l,_,_,Nothing) <- fields, not ext1] of
     []      -> return ()
+    [field] -> evalError ("In the term" <+> pp t $$
+                          "there is no value for field" <+> field <>
+                          case isLockLabel field of
+                            Just cat -> ", try wrapping with lin"<+>pp cat
+                            Nothing  -> empty)
     missing -> evalError ("In the term" <+> pp t $$
                           "there are no values for fields:" <+> hsep missing)
   rs <- sequence [mkField scope l t mb_ty1 ty2 | (l,_,ty2,mb_ty1) <- fields, Just t <- [mkProj l]]
diff --git a/src/compiler/api/GF/Grammar/Lockfield.hs b/src/compiler/api/GF/Grammar/Lockfield.hs
index 9eb487723..cab066811 100644
--- a/src/compiler/api/GF/Grammar/Lockfield.hs
+++ b/src/compiler/api/GF/Grammar/Lockfield.hs
@@ -40,9 +40,9 @@ lock c t           = t
 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_"
diff --git a/src/compiler/api/GF/Infra/Ident.hs b/src/compiler/api/GF/Infra/Ident.hs
index e202512f4..fbad6e694 100644
--- a/src/compiler/api/GF/Infra/Ident.hs
+++ b/src/compiler/api/GF/Infra/Ident.hs
@@ -26,7 +26,7 @@ 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)
@@ -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)

From 761b89d690cc9d4d3756cf89e79ee14cd732c106 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 14 Nov 2025 15:04:30 +0100
Subject: [PATCH 062/144] yet another variation of the overloading error

---
 src/compiler/api/GF/Compile/TypeCheck/Concrete.hs | 14 +++++++++-----
 1 file changed, 9 insertions(+), 5 deletions(-)

diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index 80c71ac8c..733b8eb23 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -659,12 +659,16 @@ resolveOverloads scope c t0 q args mb_ty = do
 
     minimum g ttys0 arg_tys []                    = (maxBound,err)
       where
-        err = evalError ("Overload resolution failed" $$ 
-                         "of term " <+> pp (foldl App (Q q) args) $$
-                         "with alternatives" $$
-                         nest 4 (vcat [pp (snd q) <+> pp ':' <+> ppTerm Terse 0 ty | (_,ty) <- ttys0]) $$
+        err = evalError ("no overload instance in the term" $$
+                         nest 4 (pp (foldl App (Q q) args)) $$
+                         (case mb_ty of
+                            Just vty -> pp "with value type" $$
+                                        nest 4 (ppValue Unqualified 0 vty)
+                            Nothing  -> empty) $$
                          "and argument types" $$
-                         nest 4 (fsep (punctuate (pp ',') [ppValue Terse 0 ty | (_,_,ty) <- arg_tys])))
+                         nest 4 (fsep (punctuate (pp ',') [ppValue Terse 0 ty | (_,_,ty) <- arg_tys])) $$
+                         "among alternatives" $$
+                         nest 4 (vcat [pp (snd q) <+> pp ':' <+> ppTerm Terse 0 ty | (_,ty) <- ttys0]))
 
     minimum g ttys0 arg_tys (tty@(t,ty):ttys) =
       let a        = arity ty

From 80786ad7705fb48d01b04a475aba83a88e36f632 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sat, 15 Nov 2025 09:39:08 +0100
Subject: [PATCH 063/144] remove redundant import

---
 src/compiler/api/GF/Compile/GeneratePMCFG.hs | 1 -
 1 file changed, 1 deletion(-)

diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index c1a1f5aee..25f55da23 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -23,7 +23,6 @@ import Control.Monad.Fix
 import Data.Maybe
 import Data.List(mapAccumL,sortBy,intersperse)
 import Prelude hiding ((<>))
-import System.Environment
 
 
 generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule

From 970c989fb633b23c88285124b7b56a1a8e097db7 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sat, 15 Nov 2025 10:06:00 +0100
Subject: [PATCH 064/144] pretty printing for record value

---
 src/compiler/api/GF/Compile/Compute/Concrete.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete.hs b/src/compiler/api/GF/Compile/Compute/Concrete.hs
index f35dd3f54..3bb518cb3 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete.hs
@@ -1063,7 +1063,8 @@ ppValue q d (VRecType xs ext)
   | otherwise          = doc
   where
     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)

From d02eeb7568cd29ef109074203b223e42d9ae4120 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sat, 15 Nov 2025 11:53:24 +0100
Subject: [PATCH 065/144] fix string matching in case of metavariables

---
 .../api/GF/Compile/Compute/Concrete.hs        | 35 ++++++++++---------
 1 file changed, 19 insertions(+), 16 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete.hs b/src/compiler/api/GF/Compile/Compute/Concrete.hs
index 3bb518cb3..c84c950d3 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete.hs
@@ -559,24 +559,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
-                               Const str -> let n  = length str
-                                                lo = min1 `max` (n-fromMaybe n max2)
-                                                hi = (n-min2) `min` fromMaybe n max1
-                                                (ds,cs) = splitAt lo str
+                    -> let match_seq (Const str) = let n  = length str
+                                                       lo = min1 `max` (n-fromMaybe n max2)
+                                                       hi = (n-min2) `min` fromMaybe n max1
+                                                       (ds,cs) = splitAt lo str
 
-                                                eqs' = matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args
-
-                                            in patternMatch g s v0 eqs'
-                               RunTime   -> v0
-                               NonExist  -> patternMatch g s v0 eqs
+                                                       eqs' = matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args
+                                                   in patternMatch g s v0 eqs'
+                           match_seq (CSusp i k) = VSusp i (match_seq . k) []
+                           match_seq (CFV c vs)  = VFV c (fmap match_seq vs)
+                           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
-                               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)
-                                            in patternMatch g s v0 eqs'
-                               RunTime   -> v0
-                               NonExist  -> patternMatch g s v0 eqs
+                    -> let match_rep (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)
+                                                   in patternMatch g s v0 eqs'
+                           match_rep (CSusp i k) = VSusp i (match_rep . k) []
+                           match_rep (CFV c vs)  = VFV c (fmap match_rep vs)
+                           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

From 9263d1eb173f4a021712c45928edab2dc3d64971 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sat, 15 Nov 2025 12:18:22 +0100
Subject: [PATCH 066/144] avoid using value2termM

---
 .../api/GF/Compile/Compute/Concrete.hs        | 31 ++++++++-----------
 src/compiler/api/GF/Compile/GeneratePMCFG.hs  |  2 +-
 2 files changed, 14 insertions(+), 19 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete.hs b/src/compiler/api/GF/Compile/Compute/Concrete.hs
index c84c950d3..9b6f16176 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete.hs
@@ -224,12 +224,7 @@ 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
-                                                                  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 (VV vty tvs)     = vtableSelect g v0 vty 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)) []
@@ -615,19 +610,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 (VSusp i k vs)    ty = CSusp i (\v -> value2index (apply g (k v) vs) ty)
-    value2index (VR as) (RecType lbls) = compute lbls
+    value2index (VMeta i vs)      vty = CSusp i (\v -> value2index (apply g v vs) vty)
+    value2index (VSusp i k vs)    vty = CSusp i (\v -> value2index (apply g (k v) vs) vty)
+    value2index (VR as) (VRecType lbls _) = compute lbls
       where
-        compute []              = pure (0,1)
-        compute ((lbl,ty):lbls) =
+        compute []                 = pure (0,1)
+        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 c q args) vty =
       let (r ,ctxt,cnt ) = getIdxCnt q
       in fmap (\(r', cnt') -> (r+r',cnt)) (compute ctxt args)
       where
@@ -640,7 +635,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)
@@ -650,10 +645,10 @@ vtableSelect g v0 ty cs v2 vs =
             Bad msg -> error msg
 
         Gl gr _ = g
-    value2index (VInt n)          ty
-      | Just max <- isTypeInts ty    = Const (fromIntegral n,fromIntegral max+1)
-    value2index (VFV c vs)        ty = CFV c (fmap (\v -> value2index v ty) vs)
-    value2index v ty = RunTime
+    value2index (VInt n) (VApp _ c [VInt max])
+      | Q c == cnPredef cInts         = Const (fromIntegral n,fromIntegral max+1)
+    value2index (VFV c vs)        vty = CFV c (fmap (\v -> value2index v vty) vs)
+    value2index v vty = RunTime
 
 
 value2term :: Globals -> [Ident] -> Value -> Check Term
diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index 25f55da23..a9777c06d 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -223,7 +223,7 @@ breakDown g ms c r rs v (Table p q) fn0 fn = do
   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 p tvs v2 []
+    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) []

From e34edd414f42e5cb473af50a106ff6c6e605860a Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Mon, 17 Nov 2025 16:51:29 +0100
Subject: [PATCH 067/144] fix item completion

---
 src/runtime/c/pgf/parser.cxx | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index 894d69e25..d319f5e4a 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -232,6 +232,10 @@ void PgfAbstractParser::complete(Item *item, const PgfTextSpot &spot, bool bind)
     case PgfConcrLin::tag: {
         auto lin = ref<PgfConcrLin>::untagged(item->rule->container);
 
+        if (strcmp(lin->name.text, "ComplSlash") == 0) {
+            printf("complete ComplSlash\n");
+        }
+
         size_t max_value = 1;
 
         size_t n_inst_vars = 0;
@@ -352,10 +356,7 @@ void PgfAbstractParser::complete(Item *item, const PgfTextSpot &spot, bool bind)
                         size_t lin_idx = it.first;
                         Cont  *cont    = it.second;
                         if (cont != NULL) {
-                            size_t n_items = cont->suspended.size();
-                            for (size_t i = 0; i < n_items; i++) {
-                                td_predict(next,cont,prod,lin_idx);
-                            }
+                            td_predict(next,cont,prod,lin_idx);
                         }
                     }
                     next = next->next;

From a8ba57d822a957a53f5bae543982c2780756c97a Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Mon, 17 Nov 2025 17:01:08 +0100
Subject: [PATCH 068/144] remove trace message

---
 src/runtime/c/pgf/parser.cxx | 4 ----
 1 file changed, 4 deletions(-)

diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index d319f5e4a..a79a4e35b 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -232,10 +232,6 @@ void PgfAbstractParser::complete(Item *item, const PgfTextSpot &spot, bool bind)
     case PgfConcrLin::tag: {
         auto lin = ref<PgfConcrLin>::untagged(item->rule->container);
 
-        if (strcmp(lin->name.text, "ComplSlash") == 0) {
-            printf("complete ComplSlash\n");
-        }
-
         size_t max_value = 1;
 
         size_t n_inst_vars = 0;

From 603bca8afd6c1611603910cedff0ab6f409c690f Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Mon, 17 Nov 2025 21:44:29 +0100
Subject: [PATCH 069/144] fix memory leaks

---
 src/runtime/c/pgf/parser.cxx | 40 ++++++++++++++++++++++++------------
 1 file changed, 27 insertions(+), 13 deletions(-)

diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index a79a4e35b..f1383f5a3 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -148,7 +148,7 @@ void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, P
                     cont->state = state;
                 }
 
-                cont->suspended.push_back(item);
+                cont->suspended.push_back(new_item);
 
                 if (cont->suspended.size() == 1) {
                     for (Production *prod : cont->ccat->prods) {
@@ -174,6 +174,8 @@ void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, P
                     }
                 }
             }
+
+            delete item;
         }
         break;
     }
@@ -202,7 +204,7 @@ void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, P
             process(new_item, spot, bind);
         }
 
-        // delete item;
+        delete item;
         break;
     }
     case PgfSymbolBIND::tag: {
@@ -212,10 +214,14 @@ void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, P
     case PgfSymbolSOFTBIND::tag:
     case PgfSymbolSOFTSPACE::tag: {
         item->dot++;
-        process(item, spot, true);
-        process(item, spot, false);
+        process(new (item) Item, spot, true);
+        process(new (item) Item, spot, false);
+        delete item;
         break;
     }
+    case PgfSymbolNE::tag:
+        delete item;
+        break;
     case PgfSymbolCAPIT::tag:
     case PgfSymbolALLCAPIT::tag:
         item->dot++;
@@ -340,9 +346,9 @@ void PgfAbstractParser::complete(Item *item, const PgfTextSpot &spot, bool bind)
             if (ccat->prods.size() == 1) {
                 if (ccat->cont->ccat == NULL)
                     bu_predict(concr->phrasetable, state, ccat);
-                size_t n_items = item->cont->suspended.size();
+                size_t n_items = ccat->cont->suspended.size();
                 for (size_t i = 0; i < n_items; i++) {
-                    Item *new_item = new (item->cont->suspended[i]) Item;
+                    Item *new_item = new (ccat->cont->suspended[i]) Item;
                     combine(state,new_item,ccat);
                 };
             } else {
@@ -367,6 +373,8 @@ void PgfAbstractParser::complete(Item *item, const PgfTextSpot &spot, bool bind)
         break;
     }
     }
+
+    delete item;
 }
 
 bool PgfAbstractParser::Item::instantiate(ref<PgfLParam> lparam,size_t value)
@@ -575,11 +583,11 @@ void PgfAbstractParser::combine(State *state, Item *item, CCat *ccat)
     auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
 
     if (!item->instantiate(item->rule->args[sym_cat->d],ccat->value)) {
-        // delete item;
+        delete item;
         return;
     }
     if (!item->instantiate(ref<PgfLParam>::from_ptr(&sym_cat->r),ccat->lin_idx)) {
-        // delete item;
+        delete item;
         return;
     }
     item->dot++;
@@ -1220,19 +1228,19 @@ void PgfAbstractParser::td_predict(State *state, Cont *cont, Production *prod, s
             item->rule    = rule;
 
             if (!item->instantiate(item->rule->res, cont->ccat->value)) {
-                // delete item;
+                delete item;
                 continue;
             }
 
             if (!item->instantiate(item->rule->lin_idx, lin_idx)) {
-                // delete item;
+                delete item;
                 continue;
             }
 
             for (size_t i = 0; i < item->args.size(); i++) {
                 if (prod->args[i] != NULL) {
                     if (!item->instantiate(item->rule->args[i], prod->args[i]->value)) {
-                        // delete item;
+                        delete item;
                         goto next;
                     }
                 } else {
@@ -1272,10 +1280,14 @@ void PgfParser::suspend(State *state,ref<PgfConcrLincat> lincat,Item *item)
                 Item *new_item = new (item) Item;
                 PgfSymbol sym = new_item->rule->syms[new_item->dot];
                 auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
-                if (!new_item->instantiate(new_item->rule->args[sym_cat->d],symcf->value))
+                if (!new_item->instantiate(new_item->rule->args[sym_cat->d],symcf->value)) {
+                    delete new_item;
                     return;
-                if (!new_item->instantiate(ref<PgfLParam>::from_ptr(&sym_cat->r),symcf->lin_idx))
+                }
+                if (!new_item->instantiate(ref<PgfLParam>::from_ptr(&sym_cat->r),symcf->lin_idx)) {
+                    delete new_item;
                     return;
+                }
 
                 new_item->dot++;
                 new_item->args[sym_cat->d] =
@@ -1398,6 +1410,7 @@ void PgfParseTableMaker::symbol_token(Item *item, const PgfTextSpot &spot, bool
     auto pitem = clone_item(item);
     auto phrasetable = phrasetable_insert(concr->phrasetable,sym,pitem);
     concr->phrasetable = phrasetable;
+    delete item;
 }
 
 void PgfParseTableMaker::symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym)
@@ -1405,6 +1418,7 @@ void PgfParseTableMaker::symbol_bind(Item *item, const PgfTextSpot &spot, PgfSym
     auto pitem = clone_item(item);
     auto phrasetable = phrasetable_insert(concr->phrasetable,sym,pitem);
     concr->phrasetable = phrasetable;
+    delete item;
 }
 
 void PgfParseTableMaker::suspend(State *state,ref<PgfConcrLincat> lincat,Item *item)

From ddce3738b1cfd4f54efd2b01bf4d3971929d1669 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 18 Nov 2025 09:27:10 +0100
Subject: [PATCH 070/144] fix how probabilities are computed

---
 src/runtime/c/pgf/parser.cxx | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index f1383f5a3..45f9c78b9 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -1009,7 +1009,7 @@ PgfExpr PgfParser::process_expr(ExprState *estate, prob_t *prob)
         for (ExprState *parent : estate->res->pending) {
             ExprState *app_state = new(parent->n_args) ExprState;
             app_state->expr  = parent->expr ? u->eapp(parent->expr, estate->expr) : estate->expr;
-            app_state->prob  = parent->prob+estate->prob;
+            app_state->prob  = parent->prob+prob;
             app_state->hash  = parent->hash * 31 + estate->hash;
             app_state->res   = parent->res;
             app_state->index = parent->index+1;

From d5651f24c55fdcfc1118325a03ed8160bf3eeb0d Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 18 Nov 2025 15:32:25 +0100
Subject: [PATCH 071/144] added missing case

---
 src/runtime/c/pgf/parser.cxx | 10 ++++++++++
 1 file changed, 10 insertions(+)

diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index 45f9c78b9..e6693b1bc 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -1296,6 +1296,16 @@ void PgfParser::suspend(State *state,ref<PgfConcrLincat> lincat,Item *item)
                 process(new_item, state->start, false);
             };
         phrasetable_iter(concr->phrasetable,lincat,f);
+    } else {
+        auto it1 = state->completed.find(cont);
+        if (it1 != state->completed.end()) {
+            for (auto it2 : it1->second) {
+                for (auto it3 : it2.second) {
+                    Item *new_item = new (item) Item;
+                    combine(state, new_item, it3.second);
+                }
+            }
+        }
     }
 }
 

From d18969a6fbf8982a498f7731cfcc5a4b1049642c Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 18 Nov 2025 16:23:35 +0100
Subject: [PATCH 072/144] initialize phrasetable to 0

---
 src/runtime/c/pgf/reader.cxx | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/runtime/c/pgf/reader.cxx b/src/runtime/c/pgf/reader.cxx
index 53b08e0f0..ee7c94e2a 100644
--- a/src/runtime/c/pgf/reader.cxx
+++ b/src/runtime/c/pgf/reader.cxx
@@ -725,6 +725,7 @@ ref<PgfConcrPrintname> PgfReader::read_printname()
 ref<PgfConcr> PgfReader::read_concrete()
 {
     concrete = read_name(&PgfConcr::name);
+    concrete->phrasetable = 0;
 
 	auto cflags = read_namespace<PgfFlag>(&PgfReader::read_flag);
 	concrete->cflags = cflags;

From 0a33204ee4c2189b8d6eae1794861977503b42e4 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 2 Jan 2026 08:20:52 +0100
Subject: [PATCH 073/144] faster and correct dependency checking

---
 src/compiler/api/GF/Compile/CheckGrammar.hs |  6 +--
 src/compiler/api/GF/Data/Operations.hs      | 24 ------------
 src/compiler/api/GF/Grammar/Grammar.hs      | 10 +++--
 src/compiler/api/GF/Grammar/Macros.hs       | 42 +++++++++++----------
 src/compiler/api/GF/Speech/CFGToFA.hs       |  1 -
 5 files changed, 31 insertions(+), 52 deletions(-)

diff --git a/src/compiler/api/GF/Compile/CheckGrammar.hs b/src/compiler/api/GF/Compile/CheckGrammar.hs
index 350e2c81c..34fc9fa44 100644
--- a/src/compiler/api/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/api/GF/Compile/CheckGrammar.hs
@@ -53,8 +53,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
-  foldM (foldM (checkInfo opts cwd sgr)) mo infoss
+  infos <- checkInModule cwd mi NoLoc empty $ topoSortJments mo
+  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
@@ -71,7 +71,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:" $$
diff --git a/src/compiler/api/GF/Data/Operations.hs b/src/compiler/api/GF/Data/Operations.hs
index 539b77c8f..ffd860976 100644
--- a/src/compiler/api/GF/Data/Operations.hs
+++ b/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
diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs
index 2ae64c5b7..c113fe8d3 100644
--- a/src/compiler/api/GF/Grammar/Grammar.hs
+++ b/src/compiler/api/GF/Grammar/Grammar.hs
@@ -77,6 +77,7 @@ import GF.Data.Operations
 import PGF2(BindType(..),PGF)
 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
@@ -276,10 +277,11 @@ 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
-   Left  is     -> is
-   Right cycles -> error $ render ("Cyclic abstract modules:" <+> vcat (map hsep cycles))
+allAbstracts gr =
+ let scc = stronglyConnComp [(mn,mn,extends mo) | (mn,mo) <- modules gr, mtype mo == MTAbstract]
+ in case [mns | CyclicSCC mns <- scc] of
+      []     -> [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
diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs
index ad3adfd5d..004fcdd59 100644
--- a/src/compiler/api/GF/Grammar/Macros.hs
+++ b/src/compiler/api/GF/Grammar/Macros.hs
@@ -28,10 +28,11 @@ 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.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.
@@ -538,16 +539,25 @@ sortRec = sortBy ordLabel where
 
 -- | 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 (concatMap opty (pts 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
+
+    opersInPatt p = case p of
+      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]
       ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
@@ -560,22 +570,14 @@ allDependencies ism b =
 
 topoSortJments :: ErrorMonad m => SourceModule -> m [(Ident,Info)]
 topoSortJments (m,mi) = do
-  is <- either
-          return
-          (\cyc -> raise (render ("circular definitions:" <+> fsep (head cyc))))
-          (topoTest (allDependencies (==m) (jments mi)))
-  return (reverse [(i,info) | i <- is, Just info <- [Map.lookup i (jments mi)]])
-
-topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]]
-topoSortJments2 (m,mi) = do
-  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]
-
+  let sccs = stronglyConnComp (map toNode (allDependencies (==m) (jments mi)))
+      cycles = [map fst jmts | CyclicSCC jmts <- sccs]
+  case cycles of
+    [] -> return [jmt | AcyclicSCC jmt <- sccs]
+    _  -> raise (render ("circular definitions:" $$
+                             nest 3 (vcat (map fsep cycles))))
+  where
+    toNode (id,info,deps) = ((id,info),id,deps)
 
 mkStrs p = case p of
  PAlt a b -> do
diff --git a/src/compiler/api/GF/Speech/CFGToFA.hs b/src/compiler/api/GF/Speech/CFGToFA.hs
index 08b966354..a905c0c48 100644
--- a/src/compiler/api/GF/Speech/CFGToFA.hs
+++ b/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
 

From d42614afad10c6f5c6c5dba8466e39eb9d4dd0ab Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sat, 3 Jan 2026 16:14:51 +0100
Subject: [PATCH 074/144] partial implementation for dependently typed records

---
 .../api/GF/Compile/Compute/Concrete.hs        |  30 +++--
 .../api/GF/Compile/ConcreteToHaskell.hs       |   2 +-
 src/compiler/api/GF/Compile/GeneratePMCFG.hs  |  34 ++---
 .../api/GF/Compile/GrammarToCanonical.hs      |   2 +-
 src/compiler/api/GF/Compile/Rename.hs         |  12 ++
 .../api/GF/Compile/TypeCheck/Concrete.hs      | 117 +++++++++++-------
 src/compiler/api/GF/Compile/TypeCheck/TC.hs   |   4 +-
 src/compiler/api/GF/Grammar/Analyse.hs        |   2 +-
 src/compiler/api/GF/Grammar/Grammar.hs        |   4 +-
 src/compiler/api/GF/Grammar/JSON.hs           |   4 +-
 src/compiler/api/GF/Grammar/Lockfield.hs      |   4 +-
 src/compiler/api/GF/Grammar/Lookup.hs         |   4 +-
 src/compiler/api/GF/Grammar/Macros.hs         |  29 ++---
 src/compiler/api/GF/Grammar/Parser.y          |  43 ++++---
 src/compiler/api/GF/Grammar/Printer.hs        |   7 +-
 src/compiler/api/GF/Grammar/Unify.hs          |   2 +-
 16 files changed, 174 insertions(+), 126 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute/Concrete.hs b/src/compiler/api/GF/Compile/Compute/Concrete.hs
index 9b6f16176..55494815f 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete.hs
+++ b/src/compiler/api/GF/Compile/Compute/Concrete.hs
@@ -186,7 +186,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 $$
@@ -289,7 +296,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))])) []
@@ -315,7 +322,7 @@ 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 =
@@ -356,7 +363,7 @@ apply g (VSusp i k vs0)                 vs  = VSusp i k (vs0++vs)
 apply g (VApp c f@(m,n)  vs0)           vs
   | m == cPredef                            = evalPredef g c n (vs0++vs)
   | otherwise                               = VApp c f (vs0++vs)
-apply g (VGen i  vs0)                   vs  = VGen i (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
@@ -837,9 +844,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
-  lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
+value2termM flat xs (VRecType lbls ext) = do
+  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)
@@ -1048,7 +1062,7 @@ 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 (VMeta i vs) = prec d 4 (hsep ((if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs))
 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
@@ -1060,7 +1074,7 @@ 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 "<>" -- 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))
diff --git a/src/compiler/api/GF/Compile/ConcreteToHaskell.hs b/src/compiler/api/GF/Compile/ConcreteToHaskell.hs
index 03da6ac83..1a7cb52e5 100644
--- a/src/compiler/api/GF/Compile/ConcreteToHaskell.hs
+++ b/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)
diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index a9777c06d..7ce0377f6 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -106,7 +106,7 @@ type2fields gr = map show . type2fields PP.empty
   where
     type2fields d (Sort s) | s == cStr = [show d]
     type2fields d (RecType lbls) =
-      concatMap (\(lbl,ty) -> type2fields (d <+> pp lbl) ty) 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
@@ -127,7 +127,7 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
                        Ok (v:_) -> return v
                        Bad msg  -> fail msg
        RecType r -> do
-         let (ls,ts) = unzip r
+         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
@@ -150,21 +150,21 @@ mkLinReference gr typ = do
         _ | 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
+    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))))
+          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
@@ -199,9 +199,9 @@ breakDown g ms s r rs v (Sort sort)    fn0 fn
       in return (ms,r+1,fn0,fn')
 breakDown g ms s r rs v (RecType lbls) fn0 fn = traverse ms r rs lbls fn0 fn
   where
-    traverse ms r rs []              fn0 fn = return (ms,r,fn0,fn)
-    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
-                                                 traverse ms r rs lbls fn0 fn
+    traverse ms r rs []                fn0 fn = return (ms,r,fn0,fn)
+    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
+                                                   traverse ms r rs lbls fn0 fn
       where
         project (VR as)       = case lookup lbl as of
                                   Nothing -> error (render ("Missing value for label" <+> pp lbl $$
@@ -373,8 +373,8 @@ params2int' r0 rs = do
 
 param2int (VR as) (RecType lbls) = compute lbls
   where
-    compute []              = return (0,[],1)
-    compute ((lbl,ty):lbls) = do
+    compute []                = return (0,[],1)
+    compute ((lbl,_,ty):lbls) = do
       case lookup lbl as of
         Just v   -> do (r, rs ,cnt ) <- param2int v ty
                        (r',rs',cnt') <- compute lbls
@@ -513,7 +513,7 @@ chooseMetaValue s ptyp = GenM $ \g@(Gl gr _) k svs ms r ->
           (ms',args) = mkVars (Map.insert i (Narrowing c1 ty) ms) c2 ctxt
       in (ms',VMeta i []:args)
 
-    mkField c (l,ty) = do
+    mkField c (l,_,ty) = do
        let (c1,c2) = split c
        v <- chooseMetaValue c1 ty
        return (c2,(l,v))
diff --git a/src/compiler/api/GF/Compile/GrammarToCanonical.hs b/src/compiler/api/GF/Compile/GrammarToCanonical.hs
index 7b859b1d1..ced7d309a 100644
--- a/src/compiler/api/GF/Compile/GrammarToCanonical.hs
+++ b/src/compiler/api/GF/Compile/GrammarToCanonical.hs
@@ -111,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
diff --git a/src/compiler/api/GF/Compile/Rename.hs b/src/compiler/api/GF/Compile/Rename.hs
index 6015f3a7a..b6233b8f7 100644
--- a/src/compiler/api/GF/Compile/Rename.hs
+++ b/src/compiler/api/GF/Compile/Rename.hs
@@ -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 =
diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
index 733b8eb23..3594927ae 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
@@ -201,7 +201,7 @@ tcRho scope c (FV ts) mb_ty = do
 tcRho scope s t@(Sort _) mb_ty = do
   instSigma scope s t vtypeType mb_ty
 tcRho scope c t@(RecType rs) Nothing   = do
-  (rs,mb_ty) <- tcRecTypeFields scope c [] rs Nothing
+  (rs,mb_ty) <- tcRecTypeFields scope c rs Nothing
   return (RecType rs,fromMaybe vtypePType mb_ty)
 tcRho scope c t@(RecType rs) (Just ty) = do
   (scope,f,ty') <- skolemise scope ty
@@ -215,7 +215,7 @@ tcRho scope c t@(RecType rs) (Just ty) = do
     ty        -> do ty <- value2termM False (scopeVars scope) ty
                     evalError ("The record type" <+> ppTerm Unqualified 0 t $$
                                "cannot be of type" <+> ppTerm Unqualified 0 ty)
-  (rs,mb_ty) <- tcRecTypeFields scope c [] rs (Just ty')
+  (rs,mb_ty) <- tcRecTypeFields scope c rs (Just ty')
   return (f (RecType rs),ty)
 tcRho scope s t@(Table p res) mb_ty = do
   let (s1,s23) = split s
@@ -298,7 +298,7 @@ tcRho scope c (R rs) Nothing = do
 tcRho scope c (R rs) (Just ty) = do
   (scope,f,ty') <- skolemise scope ty
   case ty' of
-    (VRecType ltys _)->do lttys <- checkRecFields scope c [] rs ltys
+    (VRecType ltys _)->do lttys <- checkRecFields scope c rs [] ltys
                           rs <- mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
                           return ((f . R)  rs,
                                   VRecType [(l,True,ty) | (l,t,ty) <- lttys] False
@@ -334,7 +334,7 @@ tcRho scope c t@(ExtR t1 t2) mb_ty =
        (t1,ty1@(VRecType ltys1 ext)) <- tcRho scope c1 t1 (Just (VRecType [field | field@(l,_,_) <- ltys, not (elem l ll2)] ext))
        let (scope',proj1,wrap) = access scope t1 ty1
 
-       lttys2 <- checkRecFields scope' c2 [] rs [field | field@(l,_,_) <- ltys, elem l ll2]
+       lttys2 <- checkRecFields scope' c2 rs [] [field | field@(l,_,_) <- ltys, elem l ll2]
        let proj2 l =
              case [(Nothing,t) | (l',t,_) <- lttys2, l'==l] of
                []    -> Nothing
@@ -366,7 +366,7 @@ tcRho scope c t@(ExtR t1 t2) mb_ty =
                              )
     access scope (RecType rs) ty
                            = (scope
-                             ,\l -> fmap ((,) Nothing) (lookup l rs)
+                             ,\l -> fmap ((,) Nothing) (lookup3 l rs)
                              ,id
                              )
     access scope t@(Vr x) ty
@@ -416,7 +416,7 @@ tcRho scope c t@(ExtR t1 t2) mb_ty =
 tcRho scope c (ELin cat t) mb_ty = do  -- this could be done earlier, i.e. in the parser
   tcRho scope c (ExtR t (R [(lockLabel cat,(Just (RecType []),R []))])) mb_ty
 tcRho scope c (ELincat cat t) mb_ty = do  -- this could be done earlier, i.e. in the parser
-  tcRho scope c (ExtR t (RecType [(lockLabel cat,RecType [])])) mb_ty
+  tcRho scope c (ExtR t (RecType [(lockLabel cat,[],RecType [])])) mb_ty
 tcRho scope c (Alts t ss) mb_ty = do
   let (c1,c2,c3,c4) = split4 c
   (t,_) <- tcRho scope c1 t (Just vtypeStr)
@@ -906,26 +906,35 @@ inferRecFields scope c ls ((l,t):lts)
       lts <- inferRecFields scope c2 (l:ls) lts
       return (lt:lts)
 
-checkRecFields scope c ls []          ltys
-  | null ltys                            = return []
-  | otherwise                            = evalError ("Missing fields:" <+> hsep [l | (l,_,_) <- ltys])
-checkRecFields scope c ls ((l,t):lts) ltys
-  | elem l ls = evalError ("Repeated definition for field" <+> l)
-  | otherwise =
-      case takeIt l ltys of
-        (Just ty,ltys) -> do let (c1,c2) = split c
-                             ltty  <- tcRecField scope c1 l t (Just ty)
-                             lttys <- checkRecFields scope c2 ls lts ltys
-                             return (ltty : lttys)
-        (Nothing,ltys) -> do evalWarn ("Discarded field:" <+> l)
-                             lttys <- checkRecFields scope c ls lts ltys
-                             return lttys     -- ignore the field
+checkRecFields scope c lts env [] = do
+  unless (null lts) $
+    evalWarn ("Discarded fields:" <+> hsep [l | (l,_) <- lts])
+  return []
+checkRecFields scope c lts env ((l,_,ty):ltys) =
+  case takeIt l lts of
+    ([], lts) -> evalError ("Missing field" <+> l)
+    ([t],lts) -> do g <- globals
+                    let (c1,c23) = split c
+                        (c2,c3)  = split c23
+                        env' = (label2ident l,eval g (scopeEnv scope) c3 (snd t) []):env
+                    ltty  <- tcRecField scope c1 l t (Just (uncover g env ty))
+                    lttys <- checkRecFields scope c2 lts env' ltys
+                    return (ltty : lttys)
+    (_,  lts) -> evalError ("Multiple definitions for field" <+> l)
   where
-    takeIt l1 []  = (Nothing, [])
-    takeIt l1 (lty@(l2,_,ty):ltys)
-      | l1 == l2  = (Just ty,ltys)
-      | otherwise = let (mb_ty,ltys') = takeIt l1 ltys
-                    in (mb_ty,lty:ltys')
+    takeIt l1 []  = ([],[])
+    takeIt l1 (lt@(l2,t):lts)
+      | l1 == l2  = let (ts,lts') = takeIt l1 lts
+                    in (t:ts,lts')
+      | otherwise = let (ts,lts') = takeIt l1 lts
+                    in (ts,lt:lts')
+
+    uncover g env' (VClosure env c (Abs b x ty)) = case lookup x env' of
+                                                     Just v  -> uncover g env' (VClosure ((x,v):env) c ty)
+                                                     Nothing -> error "Missing field"
+    uncover g env' (VClosure env c ty)           = eval g env c ty []
+    uncover g _    v                             = v
+
 
 tcRecField scope c l (mb_ann_ty,t) mb_ty = do
   (t,ty) <- case mb_ann_ty of
@@ -938,22 +947,28 @@ tcRecField scope c l (mb_ann_ty,t) mb_ty = do
               Nothing     -> tcRho scope c t mb_ty
   return (l,t,ty)
 
-tcRecTypeFields scope c ls []          mb_ty = return ([],mb_ty)
-tcRecTypeFields scope c ls ((l,ty):rs) mb_ty
-  | elem l ls = evalError ("Repeated definition for field" <+> l)
-  | otherwise = do
-      let (c1,c2) = split c
-      (ty,sort) <- tcRho scope c1 ty mb_ty
-      mb_ty <- case sort of
-                 VSort s
-                    | s == cType  -> return (Just sort)
-                    | s == cPType -> return mb_ty
-                 VMeta _ _       -> return mb_ty
-                 _               -> do sort <- value2termM False (scopeVars scope) sort
-                                       evalError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$
-                                                  "cannot be of type" <+> ppTerm Unqualified 0 sort)
-      (rs,mb_ty) <- tcRecTypeFields scope c2 (l:ls) rs mb_ty
-      return ((l,ty):rs,mb_ty)
+tcRecTypeFields scope c rs mb_ty = go c [] rs [] mb_ty
+  where
+    go c ls []               env mb_ty = return ([],mb_ty)
+    go c ls ((l,deps,ty):rs) env mb_ty
+      | elem l ls = evalError ("Multiple definitions for field" <+> l)
+      | otherwise = do
+          let (c1,c23) = split c
+              (c2,c3)  = split c23
+
+          let scope' = [x | x@(l,vty) <- env, l `elem` deps]++scope
+          (ty,sort) <- tcRho scope' c1 ty mb_ty
+          mb_ty <- case sort of
+                     VSort s
+                       | s == cType  -> return (Just sort)
+                       | s == cPType -> return mb_ty
+                     VMeta _ _       -> return mb_ty
+                     _               -> do sort <- value2termM False (scopeVars scope) sort
+                                           evalError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$
+                                                      "cannot be of type" <+> ppTerm Unqualified 0 sort)
+          g <- globals
+          (rs,mb_ty) <- go c2 (l:ls) rs ((label2ident l, eval g (scopeEnv scope) c3 ty []):scope) mb_ty
+          return ((l,deps,ty):rs,mb_ty)
 
 -- | Invariant: if the third argument is (Just rho),
 --              then rho is in weak-prenex form
@@ -1085,13 +1100,21 @@ subsCheckRho scope t ty1@(VRecType rs1 ext1) ty2@(VRecType rs2 ext2) = do      -
           is_selection _        = False
       is_trivial x _      = False
 
-      mkField scope l (mb_ty,t) (Just ty1) ty2 = do
-        (t,ty1,ty2) <- subsCheckRho scope t ty1 ty2
-        return ((l, (mb_ty,t)), (l, True, ty1))
-      mkField scope l (mb_ty,t) Nothing    ty2 =
+      mkField scope l (mb_ty,t_proj) (Just ty1) ty2 = do
+        g <- globals
+        (t,ty1,ty2) <- subsCheckRho scope t_proj (uncover g ty1) ty2
+        return ((l, (mb_ty,t_proj)), (l, True, ty1))
+        where
+          uncover g (VClosure env c (Abs b x ty)) = let (c1,c2) = split c
+                                                        v = eval g (scopeEnv scope) c2 (P t (ident2label x)) []
+                                                    in uncover g (VClosure ((x,v):env) c1 ty)
+          uncover g (VClosure env c ty)           = eval g env c ty []
+          uncover g v                             = v
+
+      mkField scope l (mb_ty,t_proj) Nothing    ty2 =
         case isLockLabel l of
           Just _  -> return ((l, (Just (RecType []),R [])), (l, True, ty2))
-          Nothing -> return ((l, (mb_ty,t)), (l, True, ty2))
+          Nothing -> return ((l, (mb_ty,t_proj)), (l, True, ty2))
 
   (scope,mkProj,wrap) <- mkAccess scope t
 
@@ -1105,7 +1128,7 @@ subsCheckRho scope t ty1@(VRecType rs1 ext1) ty2@(VRecType rs2 ext2) = do      -
                             Nothing  -> empty)
     missing -> evalError ("In the term" <+> pp t $$
                           "there are no values for fields:" <+> hsep missing)
-  rs <- sequence [mkField scope l t mb_ty1 ty2 | (l,_,ty2,mb_ty1) <- fields, Just t <- [mkProj l]]
+  rs <- sequence [mkField scope l t_proj mb_ty1 ty2 | (l,_,ty2,mb_ty1) <- fields, Just t_proj <- [mkProj l]]
   return (wrap (R (map fst rs)),VRecType (foldl (\rs (_,(l,o,ty)) -> update3 l o ty rs) rs1 rs) ext2,ty2)
 subsCheckRho scope t ty1 (VFV c (VarFree vs)) = do
   ty2 <- variants c vs
diff --git a/src/compiler/api/GF/Compile/TypeCheck/TC.hs b/src/compiler/api/GF/Compile/TypeCheck/TC.hs
index e06c5b5a9..fb9049aaa 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/TC.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck/TC.hs
@@ -91,7 +91,7 @@ eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
   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
+  RecType xs -> do xs <- mapM (\(l,_,e) -> eval env e >>= \e -> return (l,e)) xs
                    return (VRecType xs)
   _ -> return $ VClos env e
 
@@ -212,7 +212,7 @@ inferExp th tenv@(k,rho,gamma) e = case e of
    _ -> 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
+checkLabelling th tenv (lbl,_,typ) = do
   (atyp,cs) <- checkType th tenv typ
   return ((lbl,atyp),cs)
 
diff --git a/src/compiler/api/GF/Grammar/Analyse.hs b/src/compiler/api/GF/Grammar/Analyse.hs
index 64a7fa4d4..4277f9aeb 100644
--- a/src/compiler/api/GF/Grammar/Analyse.hs
+++ b/src/compiler/api/GF/Grammar/Analyse.hs
@@ -87,7 +87,7 @@ 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]
   V ty cc      -> 1 + sizeTerm ty + sum [1 + sizeTerm v | v <- cc]
diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs
index c113fe8d3..642b696e3 100644
--- a/src/compiler/api/GF/Grammar/Grammar.hs
+++ b/src/compiler/api/GF/Grammar/Grammar.hs
@@ -463,8 +463,8 @@ 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 Assign = (Label, (Maybe Type, Term)) 
+type Labelling = (Label, [Ident], Type)
+type Assign = (Label, (Maybe Type, Term))
 type Option = (Maybe Term, Term)
 type Case = (Patt, Term) 
 --type Cases = ([Patt], Term) 
diff --git a/src/compiler/api/GF/Grammar/JSON.hs b/src/compiler/api/GF/Grammar/JSON.hs
index 7cb76054c..65a48e213 100644
--- a/src/compiler/api/GF/Grammar/JSON.hs
+++ b/src/compiler/api/GF/Grammar/JSON.hs
@@ -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))]
@@ -184,7 +184,7 @@ json2term o  = Vr      <$> o!:"vr"
     <|>        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))
diff --git a/src/compiler/api/GF/Grammar/Lockfield.hs b/src/compiler/api/GF/Grammar/Lockfield.hs
index cab066811..da2056d67 100644
--- a/src/compiler/api/GF/Grammar/Lockfield.hs
+++ b/src/compiler/api/GF/Grammar/Lockfield.hs
@@ -25,9 +25,9 @@ import GF.Data.Operations(ErrorMonad,Err(..))
 lock :: Ident -> Term -> Term
 lock c t@(RecType rs) =
   let lbl = lockLabel c
-  in if elem lbl (map fst rs) || elem c [cString,cInt]
+  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
-       else RecType (rs ++ [(lbl, RecType [])])
+       else RecType (rs ++ [(lbl, [], RecType [])])
 lock c t@(R rs) =
   let lbl = lockLabel c
   in if elem lbl (map fst rs)
diff --git a/src/compiler/api/GF/Grammar/Lookup.hs b/src/compiler/api/GF/Grammar/Lookup.hs
index 6d427fc5d..6c133e085 100644
--- a/src/compiler/api/GF/Grammar/Lookup.hs
+++ b/src/compiler/api/GF/Grammar/Lookup.hs
@@ -194,7 +194,7 @@ allParamValues cnc ptyp =
     QC c -> lookupParamValues cnc c
     Q  c -> lookupResDef cnc c >>= allParamValues cnc
     RecType r -> do
-       let (ls,tys) = unzip $ sortByFst r
+       let (ls,lls,tys) = unzip3 $ sortByLbl r
        tss <- mapM (allParamValues cnc) tys
        return [R (zipAssign ls ts) | ts <- sequence tss]
     Table pt vt -> do
@@ -204,7 +204,7 @@ allParamValues cnc ptyp =
     _ -> 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])
 lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs
index 004fcdd59..952ac069b 100644
--- a/src/compiler/api/GF/Grammar/Macros.hs
+++ b/src/compiler/api/GF/Grammar/Macros.hs
@@ -29,7 +29,7 @@ import Control.Monad.Identity(Identity(..))
 import qualified Data.Traversable as T(mapM)
 import qualified Data.Map as Map
 import Control.Monad (liftM, liftM2, liftM3, forM)
-import Data.List (sortBy,nub)
+import Data.List (nub)
 import Data.Monoid
 import Data.Graph
 import GF.Text.Pretty(render,(<+>),($$),hsep,fsep,vcat,nest)
@@ -180,6 +180,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
@@ -194,7 +197,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
@@ -261,7 +264,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]
@@ -278,7 +281,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)
@@ -294,7 +297,7 @@ plusRecord t1 t2 =
 
 -- | default linearization type
 defLinType :: Type
-defLinType = RecType [(theLinLabel,  typeStr)]
+defLinType = RecType [(theLinLabel, [], typeStr)]
 
 -- | refreshing variables
 mkFreshVar :: [Ident] -> Ident -> Ident
@@ -402,7 +405,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)
@@ -453,8 +456,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
-  RecType r    -> mconcatMap (co . snd) r
+  R r          -> mconcatMap (\(_,(mt,a)) -> maybe mempty co mt <> co a) 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
@@ -525,16 +528,6 @@ 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
diff --git a/src/compiler/api/GF/Grammar/Parser.y b/src/compiler/api/GF/Grammar/Parser.y
index 54381807d..9ffc2b30a 100644
--- a/src/compiler/api/GF/Grammar/Parser.y
+++ b/src/compiler/api/GF/Grammar/Parser.y
@@ -381,18 +381,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] } 
-  | ListIdent '=' Exp         { [(lab,Nothing,Just $3) | lab <- $1] }
-  | ListIdent ':' Exp '=' Exp { [(lab,Just $3,Just $5) | lab <- $1] }
+  : '$' Ident ':' Exp         { [($2,True,Just $4,Nothing)] }
+  | ListIdent ':' Exp         { [(lab,False,Just $3,Nothing) | 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] }
-  | ListIdent ':' Exp '=' Tag { [(lab,Just $3,Just $5) | lab <- $1] }
+  : '$' Ident '=' Tag         { [($2,False,Nothing,Just $4)] }
+  | 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 +445,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)])
-                                         t          -> RecType [(tupleLabel 1,$1), (tupleLabel 2,$3)]  }
+                                         RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),[],$3)])
+                                         t          -> RecType [(tupleLabel 1,[],$1), (tupleLabel 2,[],$3)]  }
   | Exp3 '**' Exp4                   { ExtR $1 $3    }
   | Exp4                             { $1            }
 
@@ -479,7 +481,7 @@ Exp5
 
 Exp6 :: { Term }
 Exp6 
-  : Ident                 { Vr $1 } 
+  : Ident                 { Vr  $1 }
   | Sort                  { Sort $1 }
   | String                { words2term (words $1) }
   | Integer               { EInt $1 }
@@ -805,20 +807,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,_  ,_     ) = fail ("local definition of" +++ showIdent c +++ "without value")
+tryLoc (c,False,mty,Just e) = return (c,(mty,e))
+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
-    _                     -> mapM tryR  fs >>= return . R
+    (lab,_,Just ty,Nothing) ->   tryRT [] fs >>= return . RecType
+    _                       -> mapM tryR  fs >>= return . R
   where
-    tryRT (lab,Just ty,Nothing) = return (ident2label lab,ty)
-    tryRT (lab,_      ,_      ) = fail $ "illegal record type field" +++ showIdent lab --- manifest fields ?!
+    tryRT deps []                                = return []
+    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,_  ,_     ) = fail $ "illegal record field" +++ showIdent lab
+    tryR (lab,False,mty,Just t) = return (ident2label lab,(mty,t))
+    tryR (lab,_    ,_  ,_     ) = fail $ "illegal record field" +++ showIdent lab
 
 mkOverload pdt pdf@(Just (L loc df)) =
   case appForm df of
diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs
index ff6817f5c..33442db89 100644
--- a/src/compiler/api/GF/Grammar/Printer.hs
+++ b/src/compiler/api/GF/Grammar/Printer.hs
@@ -35,7 +35,7 @@ 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
@@ -245,12 +245,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)
diff --git a/src/compiler/api/GF/Grammar/Unify.hs b/src/compiler/api/GF/Grammar/Unify.hs
index 3a7f0edef..4446cfb32 100644
--- a/src/compiler/api/GF/Grammar/Unify.hs
+++ b/src/compiler/api/GF/Grammar/Unify.hs
@@ -111,5 +111,5 @@ val2term v = case v of
   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)
+  VRecType xs -> RecType (map (\(l,v) -> (l,[],val2term v)) xs)
   VType       -> typeType

From 72682d6eb3e3b06f1fe24093cff9ea1b463d745e Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 8 Jan 2026 08:53:01 +0100
Subject: [PATCH 075/144] eliminate repeated rules

---
 src/compiler/api/GF/Compile/GeneratePMCFG.hs | 3 ++-
 src/runtime/haskell/PGF2/Transactions.hsc    | 6 +-----
 2 files changed, 3 insertions(+), 6 deletions(-)

diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index 7ce0377f6..8bfe3ff6d 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -22,6 +22,7 @@ import Control.Monad (foldM,zipWithM,liftM,liftM2,forM,MonadPlus(..))
 import Control.Monad.Fix
 import Data.Maybe
 import Data.List(mapAccumL,sortBy,intersperse)
+import Data.Containers.ListUtils(nubOrd)
 import Prelude hiding ((<>))
 
 
@@ -73,7 +74,7 @@ pmcfgForm g t ctxt ty = do
   let (ms,s',t',arg_params) = apply 0 Map.empty unit ctxt t []
   let v = eval g [] s' t' []
   (ms,_,_,fn) <- breakDown g ms unit 0 [] v ty (return []) empty
-  runGenM g ms [] $ do
+  fmap nubOrd $ runGenM g ms [] $ do
     (r,rs,v,res_params) <- fn
     arg_params <- mapM params2int arg_params
     res_params <- params2int res_params
diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc
index d3a197a3b..67f9e03d4 100644
--- a/src/runtime/haskell/PGF2/Transactions.hsc
+++ b/src/runtime/haskell/PGF2/Transactions.hsc
@@ -231,7 +231,6 @@ setConcreteFlag name value = Transaction $ \c_db _ c_revision c_exn ->
 
 type Token  = String
 
-type SeqId  = Int
 type LIndex = Int
 type LVar   = Int
 data LParam  = LParam {-# UNPACK #-} !LIndex [(LIndex,LVar)]
@@ -253,14 +252,11 @@ data Symbol
 
 type Quantifiers = [(LVar,Int)]
 data Rule = Rule Quantifiers LParam [LParam] LParam [Symbol]
-                 deriving (Eq,Show)
+                 deriving (Eq,Ord,Show)
 
 data PArg = PArg [(LIndex,LIndex)] {-# UNPACK #-} !LParam
             deriving (Eq,Show)
 
-data Production = Production [(LVar,LIndex)] [PArg] LParam [SeqId]
-                 deriving (Eq,Show)
-
 createLincat :: Cat -> [String] -> [Rule] -> [Rule] -> Transaction Concr ()
 createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr c_revision c_exn ->
   let n_fields = length fields

From fbfb54c9b223bac009c933813489d7830e75850e Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Mon, 12 Jan 2026 11:03:04 +0100
Subject: [PATCH 076/144] bugfix

---
 src/runtime/c/pgf/linearizer.cxx | 43 +++++++++++++++++---------------
 1 file changed, 23 insertions(+), 20 deletions(-)

diff --git a/src/runtime/c/pgf/linearizer.cxx b/src/runtime/c/pgf/linearizer.cxx
index ee02d237f..987257e21 100644
--- a/src/runtime/c/pgf/linearizer.cxx
+++ b/src/runtime/c/pgf/linearizer.cxx
@@ -242,34 +242,37 @@ bool PgfLinearizer::TreeLinNode::resolve(PgfLinearizer *linearizer)
             arg->check_category(linearizer, &hypos[i].type->name);
 
             if (!item->instantiate(item->rule->args[i], arg->value))
-                break;
+                goto next;
 
             arg = arg->next_arg;  i++;
         }
 
-        size_t max_value = 1;
-        for (size_t i = 0; i < item->vars.size(); i++) {
-            if (item->vars[i] == 0)
-                max_value *= item->rule->vars[i].range;
-        }
-
-        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->vars[i].range;
-                    new_item->vars[i] = (v % range)+1;
-                    v = v / range;
-                }
+        {
+            size_t max_value = 1;
+            for (size_t i = 0; i < item->vars.size(); i++) {
+                if (item->vars[i] == 0)
+                    max_value *= item->rule->vars[i].range;
             }
 
-            size_t lin_idx = new_item->eval(new_item->rule->lin_idx);
-            items[lin_idx] = new_item;
+            for (size_t value = 0; value < max_value; value++) {
+                Item *new_item = new (item) Item;
 
-            this->value = new_item->eval(new_item->rule->res);
+                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->vars[i].range;
+                        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;
 
         rule_index++;

From 21f4c009ab87b73299e5b5913b98bea314fa9caf Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Mon, 12 Jan 2026 14:36:41 +0100
Subject: [PATCH 077/144] an interval based parser

---
 src/runtime/c/pgf/data.h          |    7 +-
 src/runtime/c/pgf/intervalmap.h   |  388 ++++++++++
 src/runtime/c/pgf/parser.cxx      | 1177 +++++++++++++++--------------
 src/runtime/c/pgf/parser.h        |   62 +-
 src/runtime/c/pgf/pgf.cxx         |    2 +
 src/runtime/c/pgf/phrasetable.cxx |   37 +-
 src/runtime/c/pgf/phrasetable.h   |    8 +-
 src/runtime/c/pgf/printer.cxx     |    5 +-
 src/runtime/c/pgf/reader.cxx      |    2 +
 9 files changed, 1095 insertions(+), 593 deletions(-)
 create mode 100644 src/runtime/c/pgf/intervalmap.h

diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h
index a96e45eaf..70657ccb5 100644
--- a/src/runtime/c/pgf/data.h
+++ b/src/runtime/c/pgf/data.h
@@ -89,6 +89,7 @@ struct PgfConcr;
 #include "namespace.h"
 #include "probspace.h"
 #include "expr.h"
+#include "intervalmap.h"
 
 struct PGF_INTERNAL_DECL PgfFlag {
     PgfLiteral value;
@@ -266,8 +267,9 @@ struct PGF_INTERNAL_DECL PgfSymbolACat {
 struct PGF_INTERNAL_DECL PgfSymbolCCat {
     static const uint8_t tag = 12;
     ref<PgfConcrLincat> lincat;
-    size_t value;
-    size_t lin_idx;
+    interval_t value;
+    interval_t lin_idx;
+    PgfMetaId fid;
 };
 
 struct PGF_INTERNAL_DECL PgfConcrPrintname {
@@ -287,6 +289,7 @@ struct PGF_INTERNAL_DECL PgfConcr {
     Namespace<PgfConcrLincat> lincats;
     PgfPhrasetable phrasetable;
     Namespace<PgfConcrPrintname> printnames;
+    PgfMetaId last_fid;
 
     PgfText name;
 
diff --git a/src/runtime/c/pgf/intervalmap.h b/src/runtime/c/pgf/intervalmap.h
new file mode 100644
index 000000000..aff038ed5
--- /dev/null
+++ b/src/runtime/c/pgf/intervalmap.h
@@ -0,0 +1,388 @@
+#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;
+
+        V value;
+
+        Node *left;
+        Node *right;
+
+        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 (node->start < start)
+            cmp = -1;
+        else if (node->start > start)
+            cmp = 1;
+        else if (node->end < end)
+            cmp = -1;
+        else if (node->end > 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
+    V *lookup(Node *node, size_t start, size_t end)
+    {
+        if (node == NULL) {
+            return NULL;
+        }
+
+        int cmp;
+        if (node->start < start)
+            cmp = -1;
+        else if (node->start > start)
+            cmp = 1;
+        else if (node->end < end)
+            cmp = -1;
+        else if (node->end > end)
+            cmp = 1;
+        else
+            cmp = 0;
+
+        if (cmp < 0) {
+            return lookup(node->left, start, end);
+        } else if (cmp > 0) {
+            return lookup(node->right, start, end);
+        } else {
+            return &node->value;
+        }
+    }
+
+    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();
+    }
+};
+
+#endif
diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index e6693b1bc..3236a2d43 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -2,8 +2,8 @@
 #include "printer.h"
 #include "parser.h"
 
-// #define DEBUG_PARSER
-// #define DEBUG_EXPRS
+//#define DEBUG_PARSER
+//#define DEBUG_EXPRS
 
 PgfAbstractParser::PgfAbstractParser(ref<PgfConcr> concr)
 {
@@ -11,7 +11,24 @@ PgfAbstractParser::PgfAbstractParser(ref<PgfConcr> concr)
 
     this->first_state = NULL;
     this->current_state = NULL;
-    this->last_fid = 0;
+    this->initial_fid = concr->last_fid;
+    this->last_fid = concr->last_fid;
+}
+
+void PgfAbstractParser::get_info(CCat *ccat, ref<PgfConcrRule> *prule, size_t **pvalues)
+{
+    if (ccat->fid > initial_fid) {
+        Production *prod = ccat->prods[0];
+        *prule = prod->rule;
+        *pvalues = &prod->vars[0];
+    } else {
+        size_t n_items;
+        vector<ref<PgfItem>> items =
+            phrasetable_lookup(concr->phrasetable, ccat->epsilons, &n_items);
+        ref<PgfItem> pitem = items[0];
+        *prule = pitem->rule;
+        *pvalues = &pitem->vars[0];
+    }
 }
 
 PgfAbstractParser::CCat::~CCat()
@@ -36,11 +53,11 @@ PgfAbstractParser::~PgfAbstractParser()
     State *state = first_state;
     while (state != NULL) {
         for (auto it1 : state->completed) {
-            for (auto it2 : it1.second) {
-                for (auto it3 : it2.second) {
-                    delete it3.second;
+     /*       for (auto it2 : it1) {
+                for (auto it3 : it2) {
+                    delete it3;
                 }
-            }
+            }*/
         }
         for (auto it : state->conts1) {
             delete it.second;
@@ -109,73 +126,54 @@ void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, P
                 suspend(state,lincat,item);
             }
         } else {
-            size_t max_value = 1;
-            for (size_t i = 0; i < symcat->r.n_terms; i++) {
-                size_t var = symcat->r.terms[i].var;
-                for (size_t j = 0; j < item->vars.size(); j++) {
-                    if (item->rule->vars[j].var == var && item->vars[j] == 0) {
-                        max_value *= item->rule->vars[j].range;
-                        break;
-                    }
-                }
+            interval_t lin_idx = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
+
+            Cont *&cont = state->conts2[ccat][lin_idx];
+            if (cont == NULL) {
+                cont = new Cont;
+                cont->ccat = ccat;
+                if (ccat->fid <= initial_fid)
+                    cont->lincat = ref<PgfSymbolCCat>::untagged(ccat->epsilons)->lincat;
+                else
+                    cont->lincat = ccat->cont->lincat;
+                cont->state = state;
             }
 
-            for (size_t value = 0; value < max_value; value++) {
-                Item *new_item = new (item) Item;
+            cont->suspended.push_back(item);
 
-                size_t value_ = value;
-                size_t lin_idx = symcat->r.i0;
-                for (size_t i = 0; i < symcat->r.n_terms; i++) {
-                    size_t var = symcat->r.terms[i].var;
-                    for (size_t j = 0; j < new_item->vars.size(); j++) {
-                        if (new_item->rule->vars[j].var == var) {
-                            if (new_item->vars[j] == 0) {
-                                size_t range = new_item->rule->vars[j].range;
-                                new_item->vars[j] = (value_ % range) + 1;
-                                value_ = value_ / range;
-                            }
-                            lin_idx += symcat->r.terms[i].factor * (new_item->vars[j]-1);
-                            break;
-                        }
-                    }
-                }
+            if (cont->suspended.size() == 1) {
+                if (ccat->fid <= initial_fid) {
+                    size_t n_items = 0;
+                    vector<ref<PgfItem>> items =
+                        phrasetable_lookup(concr->phrasetable, ccat->epsilons, &n_items);
 
-                Cont *&cont = state->conts2[ccat][lin_idx];
-                if (cont == NULL) {
-                    cont = new Cont;
-                    cont->ccat = ccat;
-                    cont->lincat = ccat->cont->lincat;
-                    cont->state = state;
-                }
-
-                cont->suspended.push_back(new_item);
-
-                if (cont->suspended.size() == 1) {
-                    for (Production *prod : cont->ccat->prods) {
-                        td_predict(state,cont,prod,lin_idx);
+                    for (size_t i = 0; i < n_items; i++) {
+                        ref<PgfItem> pitem = items[i];
+                        td_epsilon(state,cont,pitem,item,item->rule->args[symcat->d],ref<PgfLParam>::from_ptr(&symcat->r));
                     }
                 } else {
-                    State *next = state;
-                    while (next != NULL) {
-                        
-                        auto it1 = next->completed.find(cont);
-                        if (it1 != next->completed.end()) {
-                            auto it2 = it1->second.find(ccat->value);
-                            if (it2 != it1->second.end()) {
-                                auto it3 = it2->second.find(lin_idx);
-                                if (it3 != it2->second.end()) {
-                                    CCat *arg = it3->second;
-                                    Item *new_item = new (item) Item;
-                                    combine(next, new_item, arg);
-                                }
-                            }
-                        }
-                        next = next->next;
+                    for (Production *prod : ccat->prods) {
+                        td_predict(state,cont,prod,item,item->rule->args[symcat->d],ref<PgfLParam>::from_ptr(&symcat->r));
                     }
                 }
+            } else {
+                State *next = state;
+                while (next != NULL) {                   
+                    auto it1 = next->completed.find(cont);
+                    if (it1 != next->completed.end()) {
+                        auto *it2 = it1->second.lookup(ccat->value);
+                        if (it2 != NULL) {
+                            auto *it3 = it2->lookup(lin_idx);
+                            if (it3 != NULL) {
+                                CCat *arg = *it3;
+                                Item *new_item = new (item) Item;
+                                combine(next, new_item, arg);
+                            }
+                        }
+                    }
+                    next = next->next;
+                }
             }
-
-            delete item;
         }
         break;
     }
@@ -238,138 +236,88 @@ void PgfAbstractParser::complete(Item *item, const PgfTextSpot &spot, bool bind)
     case PgfConcrLin::tag: {
         auto lin = ref<PgfConcrLin>::untagged(item->rule->container);
 
-        size_t max_value = 1;
+        interval_t res = item->interval(item->rule->res);
+        interval_t lin_idx = item->interval(item->rule->lin_idx);
+        CCat *&ccat = state->completed[item->cont][res][lin_idx];
+        if (ccat == NULL) {
+            ccat = new CCat;
+            ccat->fid = (++last_fid);
+            ccat->cont  = item->cont;
+            ccat->state = state;
+            ccat->lin_idx = lin_idx;
+            ccat->value = res;
+            ccat->covered = false;
 
-        size_t n_inst_vars = 0;
-        size_t *inst_vars  = (size_t*)
-            alloca(sizeof(size_t)*item->vars.size());
-
-        // Compute which variables to assign to get determinate
-        // values of res and lin_idx
-        for (size_t i = 0; i < item->vars.size(); i++) {
-            if (item->vars[i] != 0)
-                continue;
-
-            size_t var = item->rule->vars[i].var;
-            for (size_t j = 0; j < item->rule->res->n_terms; j++) {
-                if (item->rule->res->terms[j].var == var) {
-                    goto found;
+#ifdef DEBUG_PARSER
+            {
+                PgfPrinter printer(NULL,0,NULL);
+                if (item->rule->vars.size() > 0) {
+                    printer.lvar_ranges(item->rule->vars, &item->vars[0]);
+                    printer.puts(" ");
                 }
-            }
-            for (size_t j = 0; j < item->rule->lin_idx->n_terms; j++) {
-                if (item->rule->lin_idx->terms[j].var == var) {
-                    goto found;
+                printer.nprintf(64,"complete [%zd-%zd; ",item->cont->state->end.pos,state->start.pos);
+                if (ccat->cont->ccat == NULL) {
+                    printer.efun(&ccat->cont->lincat->name);
+                    printer.puts("(");
+                    printer.lparam(item->rule->res);
+                    printer.puts(")");
+                } else {
+                     printer.emeta(ccat->cont->ccat->fid);
                 }
+                printer.puts("; ");
+                printer.lparam(item->rule->lin_idx);
+                printer.puts("; ");
+                printer.emeta(ccat->fid);
+                printer.puts("]");
+                PgfText *text = printer.get_text();
+                fprintf(stderr, "%s\n", text->text);
+                free(text);
             }
-
-            continue;
-
-        found:
-            inst_vars[n_inst_vars++] = i;
-            max_value *= item->rule->vars[i].range;
+#endif
         }
 
-        // Go through all possible assignments and create a production
-        for (size_t value = 0; value < max_value; value++) {
-            size_t value_ = value;
-            for (size_t i = 0; i < n_inst_vars; i++) {
-                size_t var   = inst_vars[i];
-                size_t range = item->rule->vars[var].range;
-                item->vars[var] = (value_ % range) + 1;
-                value_ = value_ / range;
-            }
-
-            size_t res = item->rule->res->i0;
-            for (size_t i = 0; i < item->rule->res->n_terms; i++) {
-                term t = item->rule->res->terms[i];
-                for (size_t j = 0; j < item->vars.size(); j++) {
-                    if (t.var == item->rule->vars[j].var) {
-                        res += t.factor * (item->vars[j]-1);
-                        break;
-                    }
-                }
-            }
-            size_t lin_idx = item->rule->lin_idx->i0;
-            for (size_t i = 0; i < item->rule->lin_idx->n_terms; i++) {
-                term t = item->rule->lin_idx->terms[i];
-                for (size_t j = 0; j < item->vars.size(); j++) {
-                    if (t.var == item->rule->vars[j].var) {
-                        lin_idx += t.factor * (item->vars[j]-1);
-                        break;
-                    }
-                }
-            }
-
-            CCat *&ccat = state->completed[item->cont][res][lin_idx];
-            if (ccat == NULL) {
-                ccat = new CCat;
-                ccat->fid = (++last_fid);
-                ccat->cont  = item->cont;
-                ccat->state = state;
-                ccat->lin_idx = lin_idx;
-                ccat->value = res;
-                ccat->covered = false;
+        auto prod = new(item) Production;
+        prod->rule = item->rule;
+        for (size_t i = 0; i < prod->args.size(); i++) {
+            if (prod->args[i] != NULL && prod->args[i] != ccat)
+                prod->args[i]->covered = true;
+        }
+        ccat->prods.push_back(prod);
 
 #ifdef DEBUG_PARSER
-                {
-                    PgfPrinter printer(NULL,0,NULL);
-                    printer.nprintf(64,"[%zd-%zd; ",item->cont->state->end.pos,state->start.pos);
-                    if (ccat->cont->ccat == NULL) {
-                        printer.efun(&ccat->cont->lincat->name);
-                        printer.nprintf(64,"(%zd)",ccat->value);
-                    } else {
-                        printer.emeta(ccat->cont->ccat->fid);
-                    }
-                    printer.nprintf(64,"; %zd; ",ccat->lin_idx);
-                    printer.emeta(ccat->fid);
-                    printer.puts("]");
-                    PgfText *text = printer.get_text();
-                    fprintf(stderr, "%s\n", text->text);
-                    free(text);
-                }
+        print_prod(ccat, prod);
 #endif
-            }
+        final_item(state, ccat, item, res, lin_idx);
 
-            auto prod = new(item) Production;
-            prod->rule = item->rule;
-            for (size_t i = 0; i < prod->args.size(); i++) {
-                if (prod->args[i] != NULL && prod->args[i] != ccat)
-                    prod->args[i]->covered = true;
-            }
-            ccat->prods.push_back(prod);
-            
-#ifdef DEBUG_PARSER
-            print_prod(ccat, prod);
-#endif
-            final_item(state, item, res, lin_idx);
-
-            if (ccat->prods.size() == 1) {
-                if (ccat->cont->ccat == NULL)
-                    bu_predict(concr->phrasetable, state, ccat);
-                size_t n_items = ccat->cont->suspended.size();
-                for (size_t i = 0; i < n_items; i++) {
-                    Item *new_item = new (ccat->cont->suspended[i]) Item;
-                    combine(state,new_item,ccat);
-                };
-            } else {
-                State *next = state;
-                while (next != NULL) {
-                    for (auto it : next->conts2[ccat]) {
-                        size_t lin_idx = it.first;
-                        Cont  *cont    = it.second;
-                        if (cont != NULL) {
-                            td_predict(next,cont,prod,lin_idx);
-                        }
+        if (ccat->prods.size() == 1) {
+            if (ccat->cont->ccat == NULL)
+                bu_predict(state, ccat);
+            size_t n_items = ccat->cont->suspended.size();
+            for (size_t i = 0; i < n_items; i++) {
+                Item *new_item = new (ccat->cont->suspended[i]) Item;
+                combine(state,new_item,ccat);
+            };
+        } else {
+            State *next = state;
+            while (next != NULL) {
+                for (auto it : next->conts2[ccat]) {
+                    interval_t lin_idx = it.first;
+                    Cont *cont = it.second;
+                    if (cont != NULL) {
+                        Item *item = cont->suspended[0];
+                        auto symcat = ref<PgfSymbolCat>::untagged(item->syms[item->dot]);
+                        td_predict(next,cont,prod,item,item->rule->args[symcat->d],ref<PgfLParam>::from_ptr(&symcat->r));
                     }
-                    next = next->next;
                 }
+                next = next->next;
             }
         }
         break;
     }
     case PgfConcrLincat::tag: {
         auto lincat = ref<PgfConcrLincat>::untagged(item->rule->container);
-        final_item(state, item, 0, 0);
+        interval_t zero = {0,0};
+        final_item(state, NULL, item, zero, zero);
         break;
     }
     }
@@ -377,204 +325,172 @@ void PgfAbstractParser::complete(Item *item, const PgfTextSpot &spot, bool bind)
     delete item;
 }
 
-bool PgfAbstractParser::Item::instantiate(ref<PgfLParam> lparam,size_t value)
+interval_t PgfAbstractParser::Item::interval(ref<PgfLParam> lparam) const
 {
-    if (value < lparam->i0)
-        return false;
-    value -= lparam->i0;
-
-    for (size_t j = 0; j < lparam->n_terms; j++) {
-        term t = lparam->terms[j];
-        for (size_t k = 0; k < vars.size(); k++) {
-            if (rule->vars[k].var == t.var) {
-                if (vars[k] > 0) {
-                    if (value < vars[k]-1)
-                        return false;
-                    value -= vars[k]-1;
+    interval_t interval;
+    interval.first  = lparam->i0;
+    interval.second = interval.first;
+    for (size_t i = 0; i < lparam->n_terms; i++) {
+        size_t var = lparam->terms[i].var;
+        for (size_t j = 0; j < vars.size(); j++) {
+            if (rule->vars[j].var == var) {
+                if (vars[j] == 0) {
+                    interval.second += lparam->terms[i].factor * (rule->vars[j].range-1);
+                } else {
+                    size_t value = lparam->terms[i].factor * (vars[j]-1);
+                    interval.first  += value;
+                    interval.second += value;
                 }
                 break;
             }
         }
     }
-
-    for (size_t j = 0; j < lparam->n_terms; j++) {
-        term t = lparam->terms[j];
-        for (size_t k = 0; k < vars.size(); k++) {
-            if (rule->vars[k].var == t.var) {
-                if (vars[k] == 0) {
-                    size_t v_val = value / t.factor;
-                    if (v_val >= rule->vars[k].range)
-                        return false;
-                    vars[k] = v_val + 1;
-                    value %= t.factor;
-                }
-                break;
-            }
-        }
-    }
-
-    return (value == 0);
+    return interval;
 }
 
-bool PgfAbstractParser::Item::instantiate(ref<PgfLParam> lparam,ref<PgfLParam> value,Item *other)
+bool PgfAbstractParser::Item::instantiate(ref<PgfLParam> lparam1,
+                                          PgfConcrRule *rule, size_t *values, ref<PgfLParam> lparam2)
 {
-    size_t i = 0;
-    size_t i0_lparam = lparam->i0;
-
-    size_t j = 0;
-    size_t i0_value  = value->i0;
-
-    while (i < lparam->n_terms && j < value->n_terms) {
-        size_t max_lparam = 0, k_lparam = 0;
-        while (i < lparam->n_terms) {
-            for (k_lparam = 0; k_lparam < this->rule->vars.size(); k_lparam++) {
-                if (this->rule->vars[k_lparam].var == lparam->terms[i].var) {
-                    break;
+    size_t i01 = lparam1->i0;
+    for (size_t i = 0; i < lparam1->n_terms; i++) {
+        for (size_t k = 0; k < this->vars.size(); k++) {
+            if (this->rule->vars[k].var == lparam1->terms[i].var) {
+                if (this->vars[k] > 0) {
+                    i01 += lparam1->terms[i].factor * (this->vars[k]-1);
                 }
-            }
-            if (this->vars[k_lparam] > 0) {
-                i0_lparam += lparam->terms[i].factor * (this->vars[k_lparam]-1);
-                i++;
-            } else {
-                max_lparam = lparam->terms[i].factor * this->rule->vars[k_lparam].range;
                 break;
             }
         }
+    }
 
-        size_t max_value = 0, k_value = 0;
-        while (j < value->n_terms) {
-            for (k_value = 0; k_value < other->rule->vars.size(); k_value++) {
-                if (other->rule->vars[k_value].var == value->terms[j].var) {
-                    break;
+    size_t i02 = lparam2->i0;
+    for (size_t i = 0; i < lparam2->n_terms; i++) {
+        for (size_t k = 0; k < rule->vars.size(); k++) {
+            if (rule->vars[k].var == lparam2->terms[i].var) {
+                if (values[k] > 0) {
+                    i02 += lparam2->terms[i].factor * (values[k]-1);
                 }
-            }
-            if (other->vars[k_value] > 0) {
-                i0_lparam += value->terms[j].factor * (other->vars[k_value]-1);
-                j++;
-            } else {
-                max_value = value->terms[j].factor * other->rule->vars[k_value].range;
                 break;
             }
         }
+    }
 
-        if (max_lparam > max_value) {
-            this->vars[k_lparam] = i0_value / this->rule->vars[k_lparam].range;
-            i0_value = i0_value % this->rule->vars[k_lparam].range;
-            i++;
+    if (i01 > i02) {
+        i01 -= i02;
+        i02  = 0;
+    } else {
+        i02 -= i01;
+        i01  = 0;
+    }
+
+    size_t i1 = 0, i2 = 0;
+    while (i1 < lparam1->n_terms || i2 < lparam2->n_terms) {
+        size_t scale1  = 0;
+        size_t factor1 = 0;
+        size_t var1    = 0;
+        size_t k1      = 0;
+        if (i1 < lparam1->n_terms) {
+            factor1 = lparam1->terms[i1].factor;
+            var1    = lparam1->terms[i1].var;
+            for (k1 = 0; k1 < this->vars.size(); k1++) {
+                if (this->rule->vars[k1].var == var1)
+                    break;
+            }
+            if (this->vars[k1] > 0) {
+                i1++;
+                continue;
+            }
+            scale1 = factor1 * this->rule->vars[k1].range;
+        }
+
+        size_t scale2  = 0;
+        size_t factor2 = 0;
+        size_t var2    = 0;
+        size_t k2      = 0;
+        if (i2 < lparam2->n_terms) {
+            factor2 = lparam2->terms[i2].factor;
+            var2    = lparam2->terms[i2].var;
+            for (k2 = 0; k2 < rule->vars.size(); k2++) {
+                if (rule->vars[k2].var == var2)
+                    break;
+            }
+            if (values[k2] > 0) {
+                i2++;
+                continue;
+            }
+            scale2 = factor2 * rule->vars[k2].range;
+        }
+
+        if (scale1 > scale2) {
+            size_t min = (i02 / factor1);
+            size_t max = min;
+            while (i2 < lparam2->n_terms) {
+                factor2 = lparam2->terms[i2].factor;
+                size_t f = factor2 / factor1;
+                if (f == 0)
+                    break;
+
+                var2 = lparam2->terms[i2].var;
+                for (k2 = 0; k2 < rule->vars.size(); k2++) {
+                    if (rule->vars[k2].var == var2) {
+                        if (values[k2] == 0) {
+                            max += f * (rule->vars[k2].range-1);
+                        }
+                        break;
+                    }
+                }
+                i2++;
+            }
+            i02 %= factor1;
+
+            if (min >= this->rule->vars[k1].range)
+                return false;
+
+            if (min == max) {
+                if (this->vars[k1] == 0)
+                    this->vars[k1] = min+1;
+                else if (this->vars[k1] != min+1)
+                    return false;
+            }
+
+            i1++;
         } else {
-            //other->vars[k_value] = i0_lparam / other->rule->vars[k_value].range;
-            i0_lparam = i0_lparam % other->rule->vars[k_value].range;
-            j++;
-        }
-    }
+            size_t min = (i01 / factor2);
+            size_t max = min;
+            while (i1 < lparam1->n_terms) {
+                factor1 = lparam1->terms[i1].factor;
+                size_t f = factor1 / factor2;
+                if (f == 0)
+                    break;
 
-    return (i0_lparam == i0_value);
-}
-
-void PgfAbstractParser::bu_predict(PgfPhrasetable phrasetable,
-                                   State *state, CCat *ccat)
-{
-    if (phrasetable == 0) {
-        return;
-	}
-
-    int cmp;
-    uint8_t tag = ref<PgfSymbol>::get_tag(phrasetable->sym);
-    if (PgfSymbolACat::tag != tag) {
-		cmp = ((int) PgfSymbolACat::tag) - ((int) tag);
-	} else {
-        auto symcf = ref<PgfSymbolACat>::untagged(phrasetable->sym);
-        cmp = textcmp(&ccat->cont->lincat->name, &symcf->name);
-    }
-    if (cmp < 0) {
-        bu_predict(phrasetable->left,state,ccat);
-    } else if (cmp > 0) {
-        bu_predict(phrasetable->right,state,ccat);
-    } else {        
-        for (size_t i = 0; i < phrasetable->n_items; i++) {
-            auto new_item = bu_item(ccat->cont->state, phrasetable->items[i]);
-            combine(state,new_item,ccat);
-        }
-    }
-}
-
-PgfAbstractParser::Item *PgfAbstractParser::bu_item(State *state, ref<PgfItem> pitem)
-{
-    Item *item = NULL;
-
-    switch (ref<object>::get_tag(pitem->rule->container)) {
-    case PgfConcrLin::tag: {
-        auto lin = ref<PgfConcrLin>::untagged(pitem->rule->container);
-
-        Cont *&cont = state->conts1[lin->lincat];
-        if (cont == NULL) {
-            cont = new Cont;
-            cont->ccat = NULL;
-            cont->lincat = lin->lincat;
-            cont->state = state;
-        }
-
-        item = new(pitem->rule) Item;
-        item->cont    = cont;
-        item->pre_alt = pitem->pre_alt;
-        item->pre_dot = pitem->pre_dot;
-        item->dot     = pitem->dot;
-        item->syms    = pitem->rule->syms.as_vector();
-        item->rule    = pitem->rule;
-        break;
-    }
-    case PgfConcrLincat::tag: {
-        auto lincat = ref<PgfConcrLincat>::untagged(pitem->rule->container);
-
-        Cont *&cont = state->conts1[0];
-        if (cont == NULL) {
-            cont = new Cont;
-            cont->ccat = NULL;
-            cont->lincat = 0;
-            cont->state = state;
-        }
-
-        item = new(pitem->rule) Item;
-        item->cont    = cont;
-        item->pre_alt = pitem->pre_alt;
-        item->pre_dot = pitem->pre_dot;
-        item->dot     = pitem->dot;
-        item->syms    = pitem->rule->syms.as_vector();
-        item->rule    = pitem->rule;
-        break;
-    }
-    }
-
-    if (item->pre_alt > 0) {
-        auto symkp = ref<PgfSymbolKP>::untagged(item->syms[item->pre_dot]);
-
-        if (item->pre_alt == 1)
-            item->syms = symkp->default_form;
-        else
-            item->syms = symkp->alts[item->pre_alt-2].form;
-    }
-
-    memcpy(&item->vars[0], &pitem->vars[0], sizeof(size_t) * item->vars.size());
-
-    for (size_t i = 0; i < pitem->args.size(); i++) {
-        ref<PgfSymbolCCat> arg = pitem->args[i];
-
-        item->args[i] = 0;
-
-        if (arg != 0) {
-            Cont *&arg_cont = state->conts1[arg->lincat];
-            if (arg_cont == NULL) {
-                arg_cont = new Cont;
-                arg_cont->ccat = NULL;
-                arg_cont->lincat = arg->lincat;
-                arg_cont->state = state;
+                var1 = lparam1->terms[i1].var;
+                for (k1 = 0; k1 < rule->vars.size(); k1++) {
+                    if (rule->vars[k1].var == var1) {
+                        if (values[k1] == 0) {
+                            max += f * (rule->vars[k1].range-1);
+                        }
+                        break;
+                    }
+                }
+                i1++;
             }
-            item->args[i] =
-                td_epsilon(state, arg_cont, arg);
+            i01 %= factor2;
+
+            if (min >= rule->vars[k2].range)
+                return false;
+
+            if (min == max) {
+                if (values[k2] == 0) {
+                    // we don't update the production;
+                } else if (values[k2] != min+1)
+                    return false;
+            }
+
+            i2++;
         }
     }
-
-    return item;
+    
+    return (i01 == i02);
 }
 
 void PgfAbstractParser::combine(State *state, Item *item, CCat *ccat)
@@ -582,20 +498,131 @@ void PgfAbstractParser::combine(State *state, Item *item, CCat *ccat)
     PgfSymbol sym = item->rule->syms[item->dot];
     auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
 
-    if (!item->instantiate(item->rule->args[sym_cat->d],ccat->value)) {
+    ref<PgfConcrRule> rule;
+    size_t *values;
+    get_info(ccat, &rule,&values);
+    if (!item->instantiate(item->rule->args[sym_cat->d], rule, values, rule->res)) {
         delete item;
         return;
     }
-    if (!item->instantiate(ref<PgfLParam>::from_ptr(&sym_cat->r),ccat->lin_idx)) {
+    if (!item->instantiate(ref<PgfLParam>::from_ptr(&sym_cat->r), rule, values, rule->lin_idx)) {
         delete item;
         return;
     }
+
     item->dot++;
     item->args[sym_cat->d] = ccat;
-
     process(item, state->start, false);
 }
 
+void PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref<PgfItem> pitem, Item *xitem, ref<PgfLParam> value, ref<PgfLParam> lin_idx)
+{
+    switch (ref<object>::get_tag(pitem->rule->container)) {
+    case PgfConcrLin::tag: {
+        auto lin = ref<PgfConcrLin>::untagged(pitem->rule->container);
+
+        for (ref<PgfConcrRule> rule : lin->rules) {
+            Item *item = new (rule) Item;
+            item->cont    = cont;
+            item->dot     = 0;
+            item->pre_alt = 0;
+            item->pre_dot = 0;
+            item->syms    = rule->syms.as_vector();
+            item->rule    = rule;
+
+            if (!item->instantiate(item->rule->res, xitem->rule, &xitem->vars[0], value)) {
+                delete item;
+                continue;
+            }
+            if (!item->instantiate(item->rule->lin_idx, xitem->rule, &xitem->vars[0], lin_idx)) {
+                delete item;
+                continue;
+            }
+
+            for (size_t i = 0; i < pitem->args.size(); i++) {
+                ref<PgfSymbolCCat> arg = pitem->args[i];
+
+                if (arg != 0) {
+                    CCat *&arg_ccat = epsilons[arg->lincat][arg->value][arg->lin_idx];
+                    if (arg_ccat == NULL) {
+                        arg_ccat = new CCat;
+                        arg_ccat->fid = arg->fid;
+                        arg_ccat->epsilons = arg.tagged();
+                        arg_ccat->state = NULL;
+                        arg_ccat->lin_idx = arg->lin_idx;
+                        arg_ccat->value = arg->value;
+                        arg_ccat->covered = true;
+                    }
+                    item->args[i] = arg_ccat;
+
+/*                    if (!item->instantiate(item->rule->args[i], pitem->args[i]->value)) {
+                        delete item;
+                        goto next;
+                    }*/
+                } else {
+                    /*if (!item->instantiate(item->rule->args[i], pitem->args[i]->value)) {
+                        delete item;
+                        continue;
+                    }*/
+                }
+            }
+
+            process(item, state->start, false);
+        }
+    }
+    default:;
+        // should not happend
+    }
+}
+
+void PgfAbstractParser::td_predict(State *state, Cont *cont, Production *prod, Item *xitem, ref<PgfLParam> value, ref<PgfLParam> lin_idx)
+{
+    switch (ref<object>::get_tag(prod->rule->container)) {
+    case PgfConcrLin::tag: {
+        auto lin = ref<PgfConcrLin>::untagged(prod->rule->container);
+
+        for (ref<PgfConcrRule> rule : lin->rules) {
+            Item *item = new (rule) Item;
+            item->cont    = cont;
+            item->dot     = 0;
+            item->pre_alt = 0;
+            item->pre_dot = 0;
+            item->syms    = rule->syms.as_vector();
+            item->rule    = rule;
+
+            if (!item->instantiate(item->rule->res, xitem->rule, &xitem->vars[0], value)) {
+                delete item;
+                continue;
+            }
+
+            if (!item->instantiate(item->rule->lin_idx, xitem->rule, &xitem->vars[0], lin_idx)) {
+                delete item;
+                continue;
+            }
+
+            for (size_t i = 0; i < item->args.size(); i++) {
+                if (prod->args[i] != NULL) {
+/*                    if (!item->instantiate(item->rule->args[i], prod->args[i]->value)) {
+                        delete item;
+                        goto next;
+                    }*/
+                } else {
+                    /*if (!item->instantiate(item->rule->args[i], prod->args[i]->value)) {
+                        delete item;
+                        continue;
+                    }*/
+                }
+                item->args[i] = prod->args[i];
+            }
+
+            process(item, state->start, false);
+        }
+    }
+    default:;
+        // should not happend
+    }
+}
+
 #ifdef DEBUG_PARSER
 static
 void print_symbols(PgfPrinter &printer, PgfConcrRule *rule, vector<PgfSymbol> syms, size_t pre_alt, size_t pre_dot, size_t dot)
@@ -790,6 +817,9 @@ PgfParser::~PgfParser()
         for (auto it1 : state->completed) {
             for (auto it2 : it1.second) {
                 for (auto it3 : it2.second) {
+                    if (it3.second->fid <= initial_fid)
+                        continue;
+
                     for (ExprState *estate : it3.second->pending) {
                         if (estate->expr != 0)
                             u->free_ref(estate->expr);
@@ -803,6 +833,20 @@ PgfParser::~PgfParser()
 
         state = state->next;
     }
+
+    for (auto it1 : epsilons) {
+        for (auto it2 : it1.second) {
+            for (auto it3 : it2.second) {
+                for (ExprState *estate : it3.second->pending) {
+                    if (estate->expr != 0)
+                        u->free_ref(estate->expr);
+                }
+                for (ExprProb &ep : it3.second->exprs) {
+                    u->free_ref(ep.expr);
+                }
+            }
+        }
+    }
 }
 
 void PgfParser::bu_predict(PgfPhrasetable phrasetable,
@@ -838,10 +882,12 @@ void PgfParser::bu_predict(PgfPhrasetable phrasetable,
 
         if (len > 0) {
             for (size_t i = 0; i < phrasetable->n_items; i++) {
+                std::map<ref<PgfConcrLincat>, bool> visited;
+                //if (!td_reachable(state, phrasetable->items[i], visited))
+                //    continue;
                 Item *item = bu_item(state, phrasetable->items[i]);
                 item->dot++;
-                if (item != NULL)
-                    process(item, current, false);
+                process(item, current, false);
             }
         }
 
@@ -850,6 +896,134 @@ void PgfParser::bu_predict(PgfPhrasetable phrasetable,
      }
 }
 
+void PgfParser::bu_predict(State *state, CCat *ccat)
+{
+    size_t n_items = 0;
+    vector<ref<PgfItem>> items =
+        phrasetable_lookup(concr->phrasetable,
+                           ccat->cont->lincat,
+                           &n_items);
+    for (size_t i = 0; i < n_items; i++) {
+        std::map<ref<PgfConcrLincat>, bool> visited;
+        //if (!td_reachable(ccat->cont->state, items[i], visited))
+        //    continue;
+        auto new_item = bu_item(ccat->cont->state, items[i]);
+        combine(state,new_item,ccat);
+    }
+}
+
+bool PgfParser::td_reachable(State *state, ref<PgfItem> pitem,
+                             std::map<ref<PgfConcrLincat>, bool> &visited)
+{
+    switch (ref<object>::get_tag(pitem->rule->container)) {
+    case PgfConcrLin::tag: {
+        auto lin = ref<PgfConcrLin>::untagged(pitem->rule->container);
+
+        if (visited[lin->lincat])
+            return false;
+        visited[lin->lincat] = true;
+
+        auto it = state->conts1.find(lin->lincat);
+        if (it != state->conts1.end()) {
+            return true;
+        }
+
+        size_t n_items = 0;
+        vector<ref<PgfItem>> items =
+            phrasetable_lookup(concr->phrasetable,
+                               lin->lincat,
+                               &n_items);
+        for (size_t i = 0; i < n_items; i++) {
+            if (td_reachable(state, items[i], visited))
+                return true;
+        }
+        break;
+    }
+    }
+    return false;
+}
+
+PgfAbstractParser::Item *PgfParser::bu_item(State *state, ref<PgfItem> pitem)
+{
+    Item *item = NULL;
+
+    switch (ref<object>::get_tag(pitem->rule->container)) {
+    case PgfConcrLin::tag: {
+        auto lin = ref<PgfConcrLin>::untagged(pitem->rule->container);
+
+        Cont *&cont = state->conts1[lin->lincat];
+        if (cont == NULL) {
+            cont = new Cont;
+            cont->ccat = NULL;
+            cont->lincat = lin->lincat;
+            cont->state = state;
+        }
+
+        item = new(pitem->rule) Item;
+        item->cont    = cont;
+        item->pre_alt = pitem->pre_alt;
+        item->pre_dot = pitem->pre_dot;
+        item->dot     = pitem->dot;
+        item->syms    = pitem->rule->syms.as_vector();
+        item->rule    = pitem->rule;
+        break;
+    }
+    case PgfConcrLincat::tag: {
+        auto lincat = ref<PgfConcrLincat>::untagged(pitem->rule->container);
+
+        Cont *&cont = state->conts1[0];
+        if (cont == NULL) {
+            cont = new Cont;
+            cont->ccat = NULL;
+            cont->lincat = 0;
+            cont->state = state;
+        }
+
+        item = new(pitem->rule) Item;
+        item->cont    = cont;
+        item->pre_alt = pitem->pre_alt;
+        item->pre_dot = pitem->pre_dot;
+        item->dot     = pitem->dot;
+        item->syms    = pitem->rule->syms.as_vector();
+        item->rule    = pitem->rule;
+        break;
+    }
+    }
+
+    if (item->pre_alt > 0) {
+        auto symkp = ref<PgfSymbolKP>::untagged(item->syms[item->pre_dot]);
+
+        if (item->pre_alt == 1)
+            item->syms = symkp->default_form;
+        else
+            item->syms = symkp->alts[item->pre_alt-2].form;
+    }
+
+    memcpy(&item->vars[0], &pitem->vars[0], sizeof(size_t) * item->vars.size());
+
+    for (size_t i = 0; i < pitem->args.size(); i++) {
+        ref<PgfSymbolCCat> arg = pitem->args[i];
+
+        item->args[i] = 0;
+
+        if (arg != 0) {
+            CCat *&arg_ccat = epsilons[arg->lincat][arg->value][arg->lin_idx];
+            if (arg_ccat == NULL) {
+                arg_ccat = new CCat;
+                arg_ccat->fid = arg->fid;
+                arg_ccat->epsilons = arg.tagged();
+                arg_ccat->state = NULL;
+                arg_ccat->lin_idx = arg->lin_idx;
+                arg_ccat->value = arg->value;
+                arg_ccat->covered = true;
+            }
+            item->args[i] = arg_ccat;
+        }
+    }
+
+    return item;
+}
+
 void PgfParser::make_chunks(State *state, std::vector<CCat*> &chunks, prob_t prob)
 {
     if (state->completed.size() == 0) {
@@ -883,6 +1057,10 @@ void PgfParser::make_chunks(State *state, std::vector<CCat*> &chunks, prob_t pro
 
 void PgfParser::prepare(ref<PgfConcrLincat> start)
 {
+#ifdef DEBUG_PARSER
+    fprintf(stderr, "------------------------------------------\n");
+#endif
+
     PgfTextSpot start_spot = {0, (uint8_t *) sentence->text};
     State *state = new_state(start_spot);
     state->needs_bind = false;
@@ -954,24 +1132,66 @@ PgfExpr PgfParser::process_expr(ExprState *estate, prob_t *prob)
             ccat->pending.push_back(estate);
 
             if (ccat->pending.size() == 1) {
-                for (Production *prod : ccat->prods) {
-                    auto lin = ref<PgfConcrLin>::untagged(prod->rule->container);
+                if (ccat->fid <= initial_fid) {
+                    size_t n_items = 0;
+                    vector<ref<PgfItem>> items =
+                        phrasetable_lookup(concr->phrasetable, ccat->epsilons, &n_items);
 
-                    ExprState *new_estate = new(prod->args.size()) ExprState;
-                    new_estate->expr   = u->efun(&lin->name);
-                    new_estate->prob   = estate->prob+lin->absfun->prob;
-                    new_estate->hash   = 0;
-                    new_estate->res    = ccat;
-                    new_estate->index  = 0;
-                    new_estate->n_args = prod->args.size();
-                    for (size_t i = 0; i < lin->name.size; i++) {
-                        new_estate->hash = new_estate->hash * 101 + lin->name.text[i];
+                    for (size_t i = 0; i < n_items; i++) {
+                        ref<PgfItem> pitem = items[i];
+
+                        auto lin = ref<PgfConcrLin>::untagged(pitem->rule->container);
+
+                        ExprState *new_estate = new(pitem->args.size()) ExprState;
+                        new_estate->expr   = u->efun(&lin->name);
+                        new_estate->prob   = estate->prob+lin->absfun->prob;
+                        new_estate->hash   = 0;
+                        new_estate->res    = ccat;
+                        new_estate->index  = 0;
+                        new_estate->n_args = pitem->args.size();
+                        for (size_t i = 0; i < lin->name.size; i++) {
+                            new_estate->hash = new_estate->hash * 101 + lin->name.text[i];
+                        }
+                        for (size_t i = 0; i < new_estate->n_args; i++) {
+                            ref<PgfSymbolCCat> arg = pitem->args[i];
+                            new_estate->args[i] = NULL;
+                            if (arg != 0) {
+                                CCat *&arg_ccat = epsilons[arg->lincat][arg->value][arg->lin_idx];
+                                if (arg_ccat == NULL) {
+                                    arg_ccat = new CCat;
+                                    arg_ccat->fid = arg->fid;
+                                    arg_ccat->epsilons = arg.tagged();
+                                    arg_ccat->state = NULL;
+                                    arg_ccat->lin_idx = arg->lin_idx;
+                                    arg_ccat->value = arg->value;
+                                    arg_ccat->covered = true;
+                                }
+                                new_estate->args[i] = arg_ccat;
+                            }
+                        }
+                        queue.push_back(new_estate);
+                        std::push_heap(queue.begin(), queue.end(), estate_comp);
                     }
-                    for (size_t i = 0; i < new_estate->n_args; i++) {
-                        new_estate->args[i] = prod->args[i];
+                } else {
+                    for (Production *prod : ccat->prods) {
+                        auto lin = ref<PgfConcrLin>::untagged(prod->rule->container);
+
+                        ExprState *new_estate = new(prod->args.size()) ExprState;
+                        new_estate->expr   = u->efun(&lin->name);
+                        new_estate->prob   = estate->prob+lin->absfun->prob;
+                        new_estate->hash   = 0;
+                        new_estate->res    = ccat;
+                        new_estate->index  = 0;
+                        new_estate->n_args = prod->args.size();
+                        for (size_t i = 0; i < lin->name.size; i++) {
+                            new_estate->hash = new_estate->hash * 101 + lin->name.text[i];
+                        }
+                        for (size_t i = 0; i < new_estate->n_args; i++) {
+                            new_estate->args[i] = prod->args[i];
+                        }
+                        queue.push_back(new_estate);
+                        std::push_heap(queue.begin(), queue.end(), estate_comp);
                     }
-                    queue.push_back(new_estate);
-                    std::push_heap(queue.begin(), queue.end(), estate_comp);
                 }
             } else {
                 for (ExprProb ep : ccat->exprs) {
@@ -1004,7 +1224,7 @@ PgfExpr PgfParser::process_expr(ExprState *estate, prob_t *prob)
             if (ep.hash == estate->hash)
                 return 0;
         }
-        
+
         estate->res->exprs.emplace_back(estate->expr, prob, estate->hash);
         for (ExprState *parent : estate->res->pending) {
             ExprState *app_state = new(parent->n_args) ExprState;
@@ -1085,182 +1305,6 @@ void PgfParser::symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym)
     process(item, spot, true);
 }
 
-PgfAbstractParser::CCat *PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref<PgfSymbolCCat> arg)
-{
-    CCat *&ccat = state->completed[cont][arg->value][arg->lin_idx];
-    if (ccat == NULL) {
-        ccat = new CCat;
-        ccat->fid = (++last_fid);
-        ccat->cont  = cont;
-        ccat->state = state;
-        ccat->lin_idx = arg->lin_idx;
-        ccat->value = arg->value;
-        ccat->covered = true;
-
-#ifdef DEBUG_PARSER
-        {
-            PgfPrinter printer(NULL,0,NULL);
-            printer.nprintf(64,"[%zd-%zd; ",cont->state->end.pos,state->start.pos);
-            printer.efun(&ccat->cont->lincat->name);
-            printer.nprintf(64,"(%zd); %zd; ",ccat->value,ccat->lin_idx);
-            printer.emeta(ccat->fid);
-            printer.puts("]");
-            PgfText *text = printer.get_text();
-            fprintf(stderr, "%s\n", text->text);
-            free(text);
-        }
-#endif
-
-        size_t n_items = 0;
-        vector<ref<PgfItem>> items =
-            phrasetable_lookup(concr->phrasetable, arg.tagged(), &n_items);
-
-        for (size_t i = 0; i < n_items; i++) {
-            ref<PgfItem> pitem = items[i];
-
-            Production *prod = new (pitem) Production;
-            prod->rule = pitem->rule;
-            memcpy(&prod->vars[0], &pitem->vars[0], sizeof(size_t) * prod->vars.size());
-
-            for (size_t j = 0; j < pitem->args.size(); j++) {
-                ref<PgfSymbolCCat> arg = pitem->args[j];
-
-                prod->args[j] = 0;
-
-                if (arg != 0) {
-                    Cont *&arg_cont = state->conts1[arg->lincat];
-                    if (arg_cont == NULL) {
-                        arg_cont = new Cont;
-                        arg_cont->ccat = NULL;
-                        arg_cont->lincat = arg->lincat;
-                        arg_cont->state = state;
-                    }
-                    prod->args[j] =
-                        td_epsilon(state, arg_cont, arg);
-                }
-            }
-
-#ifdef DEBUG_PARSER
-            print_prod(ccat, prod);
-#endif
-            ccat->prods.push_back(prod);
-        }
-    }
-
-    return ccat;
-}
-
-PgfAbstractParser::CCat *PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref<PgfSymbolCCat> arg,
-                                                       size_t n_items, vector<ref<PgfItem>> items)
-{
-    CCat *&ccat = state->completed[cont][arg->value][arg->lin_idx];
-    if (ccat == NULL) {
-        ccat = new CCat;
-        ccat->fid = (++last_fid);
-        ccat->cont  = cont;
-        ccat->state = state;
-        ccat->lin_idx = arg->lin_idx;
-        ccat->value = arg->value;
-        ccat->covered = true;
-
-#ifdef DEBUG_PARSER
-        {
-            PgfPrinter printer(NULL,0,NULL);
-            printer.nprintf(64,"[%zd-%zd; ",cont->state->end.pos,state->start.pos);
-            printer.efun(&ccat->cont->lincat->name);
-            printer.nprintf(64,"(%zd); %zd; ",ccat->value,ccat->lin_idx);
-            printer.emeta(ccat->fid);
-            printer.puts("]");
-            PgfText *text = printer.get_text();
-            fprintf(stderr, "%s\n", text->text);
-            free(text);
-        }
-#endif
-
-        for (size_t i = 0; i < n_items; i++) {
-            ref<PgfItem> pitem = items[i];
-
-            Production *prod = new (pitem) Production;
-            prod->rule = pitem->rule;
-            memcpy(&prod->vars[0], &pitem->vars[0], sizeof(size_t) * prod->vars.size());
-
-            for (size_t j = 0; j < pitem->args.size(); j++) {
-                ref<PgfSymbolCCat> arg = pitem->args[j];
-
-                prod->args[j] = 0;
-
-                if (arg != 0) {
-                    Cont *&arg_cont = state->conts1[arg->lincat];
-                    if (arg_cont == NULL) {
-                        arg_cont = new Cont;
-                        arg_cont->ccat = NULL;
-                        arg_cont->lincat = arg->lincat;
-                        arg_cont->state = state;
-                    }
-                    prod->args[j] =
-                        td_epsilon(state, arg_cont, arg);
-                }
-            }
-
-#ifdef DEBUG_PARSER
-            print_prod(ccat, prod);
-#endif
-            ccat->prods.push_back(prod);
-        }
-    }
-
-    return ccat;
-}
-
-void PgfAbstractParser::td_predict(State *state, Cont *cont, Production *prod, size_t lin_idx)
-{
-    switch (ref<object>::get_tag(prod->rule->container)) {
-    case PgfConcrLin::tag: {
-        auto lin = ref<PgfConcrLin>::untagged(prod->rule->container);
-
-        for (ref<PgfConcrRule> rule : lin->rules) {
-            Item *item = new (rule) Item;
-            item->cont    = cont;
-            item->dot     = 0;
-            item->pre_alt = 0;
-            item->pre_dot = 0;
-            item->syms    = rule->syms.as_vector();
-            item->rule    = rule;
-
-            if (!item->instantiate(item->rule->res, cont->ccat->value)) {
-                delete item;
-                continue;
-            }
-
-            if (!item->instantiate(item->rule->lin_idx, lin_idx)) {
-                delete item;
-                continue;
-            }
-
-            for (size_t i = 0; i < item->args.size(); i++) {
-                if (prod->args[i] != NULL) {
-                    if (!item->instantiate(item->rule->args[i], prod->args[i]->value)) {
-                        delete item;
-                        goto next;
-                    }
-                } else {
-                    /*if (!item->instantiate(item->rule->args[i], prod->args[i]->value)) {
-                        delete item;
-                        continue;
-                    }*/
-                }
-                item->args[i] = prod->args[i];
-            }
-
-            process(item, state->start, false);
-        next:;
-        }
-    }
-    default:;
-        // should not happend
-    }
-}
-
 void PgfParser::suspend(State *state,ref<PgfConcrLincat> lincat,Item *item)
 {
     Cont *&cont = state->conts1[lincat];
@@ -1277,21 +1321,35 @@ void PgfParser::suspend(State *state,ref<PgfConcrLincat> lincat,Item *item)
         std::function<void(ref<PgfSymbolCCat>,size_t,vector<ref<PgfItem>>)> f =
             [this,state,item,cont](ref<PgfSymbolCCat> symcf, size_t n_items, vector<ref<PgfItem>> items) {
 
+                PgfItem *xitem = items[0];
+
                 Item *new_item = new (item) Item;
                 PgfSymbol sym = new_item->rule->syms[new_item->dot];
                 auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
-                if (!new_item->instantiate(new_item->rule->args[sym_cat->d],symcf->value)) {
+                if (!new_item->instantiate(new_item->rule->args[sym_cat->d],xitem->rule,&xitem->vars[0],xitem->rule->res)) {
                     delete new_item;
                     return;
                 }
-                if (!new_item->instantiate(ref<PgfLParam>::from_ptr(&sym_cat->r),symcf->lin_idx)) {
+                if (!new_item->instantiate(ref<PgfLParam>::from_ptr(&sym_cat->r),xitem->rule,&xitem->vars[0],xitem->rule->lin_idx)) {
                     delete new_item;
                     return;
                 }
 
+                CCat *&arg_ccat = epsilons[symcf->lincat][symcf->value][symcf->lin_idx];
+                if (arg_ccat == NULL) {
+                    arg_ccat = new CCat;
+                    arg_ccat->fid = symcf->fid;
+                    arg_ccat->epsilons = symcf.tagged();
+                    arg_ccat->state = NULL;
+                    arg_ccat->lin_idx = symcf->lin_idx;
+                    arg_ccat->value = symcf->value;
+                    arg_ccat->covered = true;
+                }
+
+                state->completed[cont][symcf->value][symcf->lin_idx] = arg_ccat;
+
                 new_item->dot++;
-                new_item->args[sym_cat->d] =
-                    td_epsilon(state,cont,symcf,n_items,items);
+                new_item->args[sym_cat->d] = arg_ccat;
 
                 process(new_item, state->start, false);
             };
@@ -1309,7 +1367,7 @@ void PgfParser::suspend(State *state,ref<PgfConcrLincat> lincat,Item *item)
     }
 }
 
-void PgfParser::final_item(State *state, Item *item, size_t value, size_t lin_idx)
+void PgfParser::final_item(State *state, CCat *ccat, Item *item, interval_t value, interval_t lin_idx)
 {
     if (item->cont == NULL && state->end.ptr == end) {
         ExprState *estate = new(item->args.size()) ExprState;
@@ -1403,6 +1461,7 @@ ref<PgfItem> PgfParseTableMaker::clone_item(Item *item)
             symcf->lincat  = item->args[i]->cont->lincat;
             symcf->value   = item->args[i]->value;
             symcf->lin_idx = item->args[i]->lin_idx;
+            symcf->fid     = item->args[i]->fid;
         }
         pitem->args[i] = symcf;
     }
@@ -1459,23 +1518,23 @@ void PgfParseTableMaker::suspend(State *state,ref<PgfConcrLincat> lincat,Item *i
     concr->phrasetable = phrasetable;
 }
 
-void PgfParseTableMaker::final_item(State *state, Item *item, size_t value, size_t lin_idx)
+void PgfParseTableMaker::final_item(State *state, CCat *ccat, Item *item, interval_t value, interval_t lin_idx)
 {
     auto pitem = clone_item(item);
     
     PgfPhrasetable phrasetable = concr->phrasetable;
     phrasetable = phrasetable_insert(phrasetable,
-                                     item->cont->lincat, value, lin_idx,
+                                     item->cont->lincat, value, lin_idx, ccat->fid,
                                      pitem);
     concr->phrasetable = phrasetable;
 }
 
-void PgfParseTableMaker::bu_predict(PgfPhrasetable phrasetable, State *state, CCat *ccat)
+void PgfParseTableMaker::bu_predict(State *state, CCat *ccat)
 {
 }
 
 void PgfParseTableMaker::insert_rule(ref<PgfConcrRule> rule)
-{    
+{
     switch (ref<object>::get_tag(rule->container)) {
     case PgfConcrLin::tag: {
         auto lin = ref<PgfConcrLin>::untagged(rule->container);
diff --git a/src/runtime/c/pgf/parser.h b/src/runtime/c/pgf/parser.h
index 1bbb2aa49..486f50738 100644
--- a/src/runtime/c/pgf/parser.h
+++ b/src/runtime/c/pgf/parser.h
@@ -20,22 +20,22 @@ protected:
         ref<PgfConcrRule> rule;
 
         struct {
-            size_t &operator[](int i) {
+            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() {
+            size_t size() const {
                 Production *prod = containerof(Production,vars,this);
                 return prod->rule->vars.size();
             }
         } vars;
 
         struct {
-            CCat *&operator[](int i) {
+            CCat *&operator[](int i) const {
                 Production *prod = containerof(Production,args,this);
                 return ((CCat**) (prod+1))[i];
             }
-            size_t size() {
+            size_t size() const {
                 Production *prod = containerof(Production,args,this);
                 return (prod->rule->args != 0) ? prod->rule->args.size() : 0;
             }
@@ -82,10 +82,13 @@ protected:
 
     struct CCat {
         PgfMetaId fid;
-        Cont *cont;
+        union {
+            object epsilons;
+            Cont *cont;
+        };
         State *state;
-        size_t value;
-        size_t lin_idx;
+        interval_t value;
+        interval_t lin_idx;
         bool covered;
         std::vector<Production*> prods;
         std::vector<ExprState*> pending;
@@ -98,8 +101,9 @@ protected:
         PgfTextSpot start, end;
         bool needs_bind;
         std::map<ref<PgfConcrLincat>,Cont*> conts1;
-        std::map<CCat*,std::map<size_t,Cont*>> conts2;
-        std::map<Cont*,std::map<size_t,std::map<size_t,CCat*>>> completed;
+        std::map<CCat*,interval_map<Cont*>> conts2;
+        std::map<Cont*,interval_map<interval_map<CCat*>>> completed;
+        
         State *next;
     };
 
@@ -121,22 +125,22 @@ protected:
         ref<PgfConcrRule> rule;
 
         struct {
-            size_t &operator[](int i) {
+            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() {
+            size_t size() const {
                 Item *item = containerof(Item,vars,this);
                 return item->rule->vars.size();
             }
         } vars;
 
         struct {
-            CCat *&operator[](int i) {
+            CCat *&operator[](int i) const {
                 Item *item = containerof(Item,args,this);
                 return ((CCat**) (item+1))[i];
             }
-            size_t size() {
+            size_t size() const {
                 Item *item = containerof(Item,args,this);
                 return (item->rule->args != 0) ? item->rule->args.size() : 0;
             }
@@ -168,8 +172,9 @@ protected:
         Item() {
         }
 
-        bool instantiate(ref<PgfLParam> lparam,size_t value);
-        bool instantiate(ref<PgfLParam> lparam,ref<PgfLParam> value,Item *other);
+        interval_t interval(ref<PgfLParam> lparam) const;
+        bool instantiate(ref<PgfLParam> lparam1,
+                         PgfConcrRule *rule, size_t *values, ref<PgfLParam> lparam2);
     };
 
     struct ExprState {
@@ -200,7 +205,8 @@ protected:
     };
 
     State *first_state, *current_state;
-    PgfMetaId last_fid;
+    std::map<ref<PgfConcrLincat>,interval_map<interval_map<CCat*>>> epsilons;
+    PgfMetaId initial_fid, last_fid;
 
     void process(Item *item, const PgfTextSpot &spot, bool bind);
     void symbol(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym);
@@ -210,16 +216,15 @@ protected:
     virtual void symbol_token(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym)=0;
     virtual void symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym)=0;
     virtual void suspend(State *state,ref<PgfConcrLincat> lincat, Item *item)=0;
-    virtual void final_item(State *state,Item *item,size_t value,size_t lin_idx)=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, CCat *ccat)=0;
 
-    virtual void bu_predict(PgfPhrasetable phrasetable, State *state, CCat *ccat);
-    Item *bu_item(State *state, ref<PgfItem> pitem);
-    CCat *td_epsilon(State *state, Cont *cont, ref<PgfSymbolCCat> arg);
-    CCat *td_epsilon(State *state, Cont *cont, ref<PgfSymbolCCat> arg,
-                     size_t n_items, vector<ref<PgfItem>> items);
-    void td_predict(State *state, Cont *cont, Production *prod, size_t lin_idx);
+    void td_epsilon(State *state, Cont *cont, ref<PgfItem> pitem, Item *xitem, ref<PgfLParam> value, ref<PgfLParam> lin_idx);
+    void td_predict(State *state, Cont *cont, Production *prod, Item *xitem, ref<PgfLParam> value, ref<PgfLParam> lin_idx);
     void combine(State *state, Item *item, CCat *ccat);
 
+    void get_info(CCat *ccat, ref<PgfConcrRule> *rule, size_t **pvalues);
+
     static
     void print_item(Item *item, const PgfTextSpot &spot);
 
@@ -243,12 +248,16 @@ class PGF_INTERNAL_DECL PgfParser : private PgfAbstractParser, public PgfExprEnu
     virtual void symbol_token(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym);
     virtual void symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym);
     virtual void suspend(State *state,ref<PgfConcrLincat> lincat, Item *item);
-    virtual void final_item(State *state,Item *item,size_t value,size_t lin_idx);
+    virtual void final_item(State *state,CCat *ccat,Item *item,interval_t value,interval_t lin_idx);
+    virtual void bu_predict(State *state, CCat *ccat);
 
     void bu_predict(PgfPhrasetable phrasetable, State *state, 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, ref<PgfItem> pitem);
+
     static
     void print_expr_state_left(PgfPrinter *printer, PgfMarshaller *m, ExprState *estate);
     static
@@ -280,8 +289,8 @@ private:
     virtual void symbol_token(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym);
     virtual void symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym);
     virtual void suspend(State *state,ref<PgfConcrLincat> lincat,Item *item);
-    virtual void final_item(State *state,Item *item,size_t value,size_t lin_idx);
-    virtual void bu_predict(PgfPhrasetable phrasetable, State *state, CCat *ccat);
+    virtual void final_item(State *state,CCat *ccat,Item *item,interval_t value,interval_t lin_idx);
+    virtual void bu_predict(State *state, CCat *ccat);
 
     static
     ref<PgfItem> clone_item(Item *item);
@@ -289,6 +298,7 @@ private:
 public:
     PgfParseTableMaker(ref<PgfConcr> concr);
     void insert_rule(ref<PgfConcrRule> rule);
+    PgfMetaId get_last_fid() { return last_fid; };
 };
 
 #endif
diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx
index 0f2eacb2d..21245fe75 100644
--- a/src/runtime/c/pgf/pgf.cxx
+++ b/src/runtime/c/pgf/pgf.cxx
@@ -1479,6 +1479,7 @@ ref<PgfConcr> clone_concrete(ref<PgfPGF> pgf, ref<PgfConcr> concr)
         clone->lincats = concr->lincats;
         clone->phrasetable = concr->phrasetable;
         clone->printnames = concr->printnames;
+        clone->last_fid = concr->last_fid;
         memcpy(&clone->name, &concr->name, sizeof(PgfText)+concr->name.size+1);
 
         ref<PgfConcr> old_concr;
@@ -1656,6 +1657,7 @@ PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision,
         concr->lincats = 0;
         concr->phrasetable = 0;
         concr->printnames = 0;
+        concr->last_fid = 0;
         memcpy(&concr->name, name, sizeof(PgfText)+name->size+1);
 
         Namespace<PgfConcr> concrs =
diff --git a/src/runtime/c/pgf/phrasetable.cxx b/src/runtime/c/pgf/phrasetable.cxx
index 86a8cfffb..9063bf4cf 100644
--- a/src/runtime/c/pgf/phrasetable.cxx
+++ b/src/runtime/c/pgf/phrasetable.cxx
@@ -327,7 +327,7 @@ PGF_INTERNAL_DECL
 size_t get_next_padovan(size_t min);
 
 static
-int symbol_cmp(ref<PgfConcrLincat> lincat, size_t value, size_t lin_idx, PgfSymbol sym)
+int symbol_cmp(ref<PgfConcrLincat> lincat, interval_t value, interval_t lin_idx, PgfSymbol sym)
 {
     uint8_t tag = ref<PgfSymbol>::get_tag(sym);
     if (PgfSymbolCCat::tag != tag)
@@ -655,6 +655,33 @@ vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable table, PgfSymbol sym, siz
     return 0;
 }
 
+vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable phrasetable,
+                                        ref<PgfConcrLincat> lincat,
+                                        size_t *n_items)
+{
+    while (phrasetable != 0) {
+        int cmp;
+        uint8_t tag = ref<PgfSymbol>::get_tag(phrasetable->sym);
+        if (PgfSymbolACat::tag != tag) {
+            cmp = ((int) PgfSymbolACat::tag) - ((int) tag);
+        } else {
+            auto symcf = ref<PgfSymbolACat>::untagged(phrasetable->sym);
+            cmp = textcmp(&lincat->name, &symcf->name);
+        }
+        if (cmp < 0)
+            phrasetable = phrasetable->left;
+        else if (cmp > 0)
+            phrasetable = phrasetable->right;
+        else {
+            *n_items = phrasetable->n_items;
+            return phrasetable->items;
+        }
+    }
+
+    *n_items = 0;
+    return 0;
+}
+
 PGF_INTERNAL
 void phrasetable_lookup(PgfPhrasetable table,
                         PgfText *sentence,
@@ -973,7 +1000,8 @@ PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
 
 PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
                                   ref<PgfConcrLincat> lincat,
-                                  size_t value, size_t lin_idx,
+                                  interval_t value, interval_t lin_idx,
+                                  PgfMetaId fid,
                                   ref<PgfItem> item)
 {
     if (table == 0) {
@@ -981,6 +1009,7 @@ PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
         symcf->lincat = lincat;
         symcf->value   = value;
         symcf->lin_idx = lin_idx;
+        symcf->fid = fid;
         PgfPhrasetable new_table = PgfPhrasetableNode::new_node(symcf.tagged(),1);
         new_table->n_items = 1;
         new_table->items[0] = item;
@@ -990,12 +1019,12 @@ PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
     int cmp = symbol_cmp(lincat,value,lin_idx,table->sym);
     if (cmp < 0) {
         PgfPhrasetable left = phrasetable_insert(table->left,
-                                                lincat, value, lin_idx, item);
+                                                lincat, value, lin_idx, fid, item);
         table = PgfPhrasetableNode::upd_node(table,left,table->right);
         return PgfPhrasetableNode::balanceL(table);
     } else if (cmp > 0) {
         PgfPhrasetable right = phrasetable_insert(table->right,
-                                                  lincat, value, lin_idx, item);
+                                                  lincat, value, lin_idx, fid, item);
         table = PgfPhrasetableNode::upd_node(table, table->left, right);
         return PgfPhrasetableNode::balanceR(table);
     } else {
diff --git a/src/runtime/c/pgf/phrasetable.h b/src/runtime/c/pgf/phrasetable.h
index 894fda150..fc0e9c544 100644
--- a/src/runtime/c/pgf/phrasetable.h
+++ b/src/runtime/c/pgf/phrasetable.h
@@ -90,7 +90,8 @@ PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
 
 PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
                                   ref<PgfConcrLincat> lincat,
-                                  size_t value, size_t lin_idx,
+                                  interval_t value, interval_t lin_idx,
+                                  PgfMetaId fid,
                                   ref<PgfItem> item);
 
 PGF_INTERNAL_DECL
@@ -99,6 +100,11 @@ void phrasetable_iter(PgfPhrasetable phrasetable,ref<PgfConcrLincat> lincat,std:
 PGF_INTERNAL_DECL
 vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable phrasetable, PgfSymbol sym, size_t *n_items);
 
+PGF_INTERNAL_DECL
+vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable phrasetable,
+                                        ref<PgfConcrLincat> lincat,
+                                        size_t *n_items);
+
 class PGF_INTERNAL_DECL PgfPhraseScanner {
 public:
     virtual void space(PgfTextSpot *start, PgfTextSpot *end, PgfExn* err)=0;
diff --git a/src/runtime/c/pgf/printer.cxx b/src/runtime/c/pgf/printer.cxx
index 444aceefe..dc927a5e2 100644
--- a/src/runtime/c/pgf/printer.cxx
+++ b/src/runtime/c/pgf/printer.cxx
@@ -586,7 +586,10 @@ void PgfPrinter::symbol(PgfSymbol sym)
 	case PgfSymbolCCat::tag: {
         auto symcf = ref<PgfSymbolCCat>::untagged(sym);
         efun(&symcf->lincat->name);
-        nprintf(64,"(%zu,%zu)",symcf->value,symcf->lin_idx);
+        nprintf(64,"(%zu-%zu,%zu-%zu)",symcf->value.first
+                                      ,symcf->value.second
+                                      ,symcf->lin_idx.first
+                                      ,symcf->lin_idx.second);
         break;
     }
 	}
diff --git a/src/runtime/c/pgf/reader.cxx b/src/runtime/c/pgf/reader.cxx
index ee7c94e2a..16ddef87b 100644
--- a/src/runtime/c/pgf/reader.cxx
+++ b/src/runtime/c/pgf/reader.cxx
@@ -726,6 +726,7 @@ ref<PgfConcr> PgfReader::read_concrete()
 {
     concrete = read_name(&PgfConcr::name);
     concrete->phrasetable = 0;
+    concrete->last_fid = 0;
 
 	auto cflags = read_namespace<PgfFlag>(&PgfReader::read_flag);
 	concrete->cflags = cflags;
@@ -739,6 +740,7 @@ ref<PgfConcr> PgfReader::read_concrete()
 	auto lins = read_namespace<PgfConcrLin>(&PgfReader::read_lin);
 	concrete->lins = lins;
 
+    concrete->last_fid = tm.get_last_fid();
     this->table_maker = NULL;
 
 	auto printnames = read_namespace<PgfConcrPrintname>(&PgfReader::read_printname);

From 76faee5cd5605161d6b191bfe4e0640600ab4f59 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 14 Jan 2026 14:21:24 +0100
Subject: [PATCH 078/144] use the cached parameter count

---
 src/compiler/api/GF/Compile/GeneratePMCFG.hs | 16 +++----
 src/compiler/api/GF/Grammar/Lookup.hs        | 46 ++++++++++++++------
 2 files changed, 40 insertions(+), 22 deletions(-)

diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index 8bfe3ff6d..4cf1ba725 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -92,8 +92,8 @@ pmcfgForm g t ctxt ty = do
       where
         boundsOf sgr ms i =
           case Map.lookup (i+1) ms of
-            Just (Narrowing _ pty) -> case allParamValues sgr pty of
-                                        Ok ps   -> length ps
+            Just (Narrowing _ pty) -> case countParamValues sgr pty of
+                                        Ok c    -> c
                                         Bad msg -> error msg
             _                      -> error (show (ppLVar i <+> "is not a free variable"))
 
@@ -123,7 +123,7 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
                         let T _ cs = mkWildCases t'
                         return $ T (TWild p) cs
        Sort s | s == cStr -> return (Vr varStr)
-       QC p       -> case lookupParamValues gr p of
+       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
@@ -176,8 +176,8 @@ type2metaTerm gr d ms s r rs (Table p q) params
                      delta  = r'-r
                  in (ms',s',r+delta*count,T (TTyped p) [(PV pv,t)],params')
   where
-    count = case allParamValues gr p of
-              Ok ts   -> length ts
+    count = case countParamValues gr p of
+              Ok c    -> c
               Bad msg -> error msg
 type2metaTerm gr d ms c r rs ty@(QC q) params =
   let i = Map.size ms + 1
@@ -218,7 +218,7 @@ breakDown g ms c r rs v (Table p q) fn0 fn = do
       v0 = VS v v2 []
       (c1,c2) = split c
       Gl gr _ = g
-  cnt <- fmap length $ allParamValues gr p
+  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)
@@ -476,8 +476,8 @@ setMeta i st = GenM $ \_ k svs ms ->
   k () svs (Map.insert i st ms)
 
 getCnt ty = GenM $ \(Gl gr _) k svs ms r ->
-  case allParamValues gr ty of
-    Ok ts   -> k (length ts) 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 ->
diff --git a/src/compiler/api/GF/Grammar/Lookup.hs b/src/compiler/api/GF/Grammar/Lookup.hs
index 6c133e085..b86596be7 100644
--- a/src/compiler/api/GF/Grammar/Lookup.hs
+++ b/src/compiler/api/GF/Grammar/Lookup.hs
@@ -23,8 +23,8 @@ module GF.Grammar.Lookup (
            lookupResType,
            lookupOverload,
            lookupOverloadTypes,
-           lookupParamValues,
            allParamValues,
+           countParamValues,
            lookupAbsDef,
            lookupLincat,
            lookupFunType,
@@ -180,32 +180,50 @@ 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
-    Q  c -> lookupResDef cnc c >>= allParamValues cnc
+    QC c -> do (_,info) <- lookupOrigInfo gr c
+               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,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
-       vvs <- allParamValues cnc vt
+       pvs <- allParamValues gr pt
+       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
     sortByLbl = sortBy (\(l1,_,_) (l2,_,_) -> compare l1 l2)
 
+countParamValues :: ErrorMonad m => Grammar -> Type -> m Int
+countParamValues gr ptyp =
+  case ptyp of
+    _ | Just n <- isTypeInts ptyp -> return (fromIntegral n)
+    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 -> ModuleName -> Ident -> m (Maybe Int,Maybe [Equation])
 lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
   info <- lookupQIdentInfo gr (m,c)

From a99cfb53f58327e1cd678a7a754c8966e83748d7 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 14 Jan 2026 14:52:29 +0100
Subject: [PATCH 079/144] fix initialization in -O2 mode

---
 src/runtime/c/pgf/linearizer.cxx | 6 ++++--
 src/runtime/c/pgf/linearizer.h   | 1 -
 2 files changed, 4 insertions(+), 3 deletions(-)

diff --git a/src/runtime/c/pgf/linearizer.cxx b/src/runtime/c/pgf/linearizer.cxx
index 987257e21..4657272a7 100644
--- a/src/runtime/c/pgf/linearizer.cxx
+++ b/src/runtime/c/pgf/linearizer.cxx
@@ -76,11 +76,11 @@ void PgfLinearizer::TreeNode::linearize_arg(PgfLinearizationOutputIface *out, Pg
     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");
     arg->linearize(out, linearizer, r);
 }
@@ -235,6 +235,7 @@ bool PgfLinearizer::TreeLinNode::resolve(PgfLinearizer *linearizer)
 
     while (rule_index < lin->rules.size()) {
         Item *item = new (lin->rules[rule_index]) Item();
+        item->rule = lin->rules[rule_index];
 
         int i = 0;
         TreeNode *arg = args;
@@ -508,6 +509,7 @@ bool PgfLinearizer::TreeLinrefNode::resolve(PgfLinearizer *linearizer)
 
     while (rule_index < lincat->rules.size()) {
         Item *item = new (lincat->rules[lincat->n_lindefs+rule_index]) Item();
+        item->rule = lincat->rules[lincat->n_lindefs+rule_index];
 
         if (!item->instantiate(item->rule->args[0], root->value)) {
             rule_index++;
diff --git a/src/runtime/c/pgf/linearizer.h b/src/runtime/c/pgf/linearizer.h
index af54030ef..8552b61d6 100644
--- a/src/runtime/c/pgf/linearizer.h
+++ b/src/runtime/c/pgf/linearizer.h
@@ -45,7 +45,6 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
             size_t sz2 = rule->vars.size()*sizeof(size_t);
             Item *new_item = (Item *) malloc(sz+sz2);
             memset(new_item, 0, sz+sz2);
-            new_item->rule = rule;
             return new_item;
         }
 

From ce63d4627ba724cf47356f47e7ed44540b3c9e6f Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 14 Jan 2026 16:42:04 +0100
Subject: [PATCH 080/144] variables in rules are finally renamed

---
 src/compiler/api/GF/Compile/GeneratePMCFG.hs | 165 ++++++++++---------
 src/compiler/api/GF/Grammar/Printer.hs       |   2 +-
 src/runtime/c/pgf/data.cxx                   |   9 +-
 src/runtime/c/pgf/data.h                     |   9 +-
 src/runtime/c/pgf/linearizer.cxx             |  45 ++---
 src/runtime/c/pgf/linearizer.h               |   4 +-
 src/runtime/c/pgf/parser.cxx                 | 118 +++++--------
 src/runtime/c/pgf/parser.h                   |   6 +-
 src/runtime/c/pgf/pgf.cxx                    |  28 ++--
 src/runtime/c/pgf/pgf.h                      |   4 +-
 src/runtime/c/pgf/phrasetable.h              |   2 +-
 src/runtime/c/pgf/printer.cxx                |  16 +-
 src/runtime/c/pgf/printer.h                  |   2 +-
 src/runtime/c/pgf/reader.cxx                 |  36 +---
 src/runtime/c/pgf/reader.h                   |   4 +-
 src/runtime/c/pgf/writer.cxx                 |   7 +-
 src/runtime/c/pgf/writer.h                   |   2 +-
 src/runtime/haskell/PGF2/Transactions.hsc    |   6 +-
 18 files changed, 184 insertions(+), 281 deletions(-)

diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index 4cf1ba725..c2d360927 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -21,7 +21,7 @@ import Control.Applicative
 import Control.Monad (foldM,zipWithM,liftM,liftM2,forM,MonadPlus(..))
 import Control.Monad.Fix
 import Data.Maybe
-import Data.List(mapAccumL,sortBy,intersperse)
+import Data.List(mapAccumL,sortBy,sortOn,intersperse)
 import Data.Containers.ListUtils(nubOrd)
 import Prelude hiding ((<>))
 
@@ -76,22 +76,21 @@ pmcfgForm g t ctxt ty = do
   (ms,_,_,fn) <- breakDown g ms unit 0 [] v ty (return []) empty
   fmap nubOrd $ runGenM g ms [] $ do
     (r,rs,v,res_params) <- fn
-    arg_params <- mapM params2int arg_params
-    res_params <- params2int res_params
-    lin_idx    <- params2int' r rs
-    seq        <- flatten v
-    qs <- quantifiers (arg_params++[res_params,lin_idx])
+    (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)
   where
     Gl sgr _ = g
 
-    quantifiers params = GenM (\(Gl sgr _) k svs ms ->
-      k ((Set.toList . Set.fromList)
-            [(variable,boundsOf sgr ms variable) | LParam _ terms <- params, (factor,variable) <- terms])
+    quantifiers vars = GenM (\(Gl sgr _) k svs ms ->
+      k [boundsOf sgr ms variable | (variable,v) <- sortOn snd vars]
         svs ms)
       where
         boundsOf sgr ms i =
-          case Map.lookup (i+1) ms of
+          case Map.lookup i ms of
             Just (Narrowing _ pty) -> case countParamValues sgr pty of
                                         Ok c    -> c
                                         Bad msg -> error msg
@@ -299,24 +298,26 @@ force (VFV c vs) = do
 force v = compileError ("Cannot evaluate" <+> ppValue Unqualified 0 v)
 
 
-flatten (VStr s) = return [SymKS s]
-flatten (VSymCat d r rs) = do
-  lin_index <- params2int' r rs
-  return [SymCat d lin_index]
-flatten (VApp _ (m,id) [])
-  | m == cPredef && id == cBIND       = return [SymBIND]
-  | m == cPredef && id == cSOFT_BIND  = return [SymSOFT_BIND]
-  | m == cPredef && id == cSOFT_SPACE = return [SymSOFT_SPACE]
-  | m == cPredef && id == cNonExist   = return [SymNE]
-  | m == cPredef && id == cCAPIT      = return [SymCAPIT]
-  | m == cPredef && id == cALL_CAPIT  = return [SymALL_CAPIT]
-flatten v0@(VAlts def alts) = do
-  def <- flatten def
-  alts <- forM alts $ \(alt,ps) -> do
-    alt <- flatten alt
-    ps  <- to_strs ps
-    return (alt,ps)
-  return [SymKP def alts]
+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
@@ -332,12 +333,12 @@ flatten v0@(VAlts def alts) = do
     from_patt _            = fail
 
     fail = compileError ("Complex patterns are not supported in:" $$ nest 2 (ppValue Unqualified 0 v0))
-flatten VEmpty     = return []
-flatten (VC v1 v2) = do
-  s1 <- flatten v1
-  s2 <- flatten v2
-  return (s1++s2)
-flatten (VSusp i k vs) = do
+flatten subst VEmpty     = return (subst,[])
+flatten subst (VC v1 v2) = do
+  (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
@@ -345,62 +346,66 @@ flatten (VSusp i k vs) = do
                               return v
          Bound _ v      -> return v
   g <- globals
-  flatten (apply g (k v) vs)
-flatten (VFV c vs) = do
+  flatten subst (apply g (k v) vs)
+flatten subst (VFV c vs) = do
   v <- variants c (unvariants vs)
-  flatten v
-flatten v = compileError ("Cannot evaluate" <+> ppValue Unqualified 0 v  <+> "to a string")
+  flatten subst v
+flatten subst v = compileError ("Cannot evaluate" <+> ppValue Unqualified 0 v  <+> "to a string")
 
 
-params2int rs = do
-  (r,rs,_) <- compute rs
-  return (LParam r (order rs))
+params2int subst rs = do
+  (subst,r,rs,_) <- compute subst rs
+  return (subst,LParam r (order rs))
   where
-    compute []              = return (0,[],1)
-    compute ((v,ty):params) = do
-      (r, rs, cnt ) <- param2int v ty
-      (r',rs',cnt') <- compute params
-      return (r*cnt'+r',combine cnt' rs rs',cnt*cnt')
+    compute subst []              = return (subst,0,[],1)
+    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' r0 rs = do
-  (r,rs) <- compute rs
-  return (LParam (r0+r) (order rs))
+params2int' subst r0 rs = do
+  (subst,r,rs) <- compute subst rs
+  return (subst,LParam (r0+r) (order rs))
   where
-    compute []                     = return (0,[])
-    compute ((cnt',(v,ty)):params) = do
-      (r, rs, cnt) <- param2int v ty
-      (r',rs')     <- compute params
-      return (r*cnt'+r',combine cnt' rs rs')
+    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 (VR as) (RecType lbls) = compute lbls
+param2int subst (VR as) (RecType lbls) = compute subst lbls
   where
-    compute []                = return (0,[],1)
-    compute ((lbl,_,ty):lbls) = do
+    compute subst []                = return (subst,0,[],1)
+    compute subst ((lbl,_,ty):lbls) = do
       case lookup lbl as of
-        Just v   -> do (r, rs ,cnt ) <- param2int v ty
-                       (r',rs',cnt') <- compute lbls
-                       return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
+        Just v   -> do (subst, r, rs ,cnt ) <- param2int subst v ty
+                       (subst, r',rs',cnt') <- compute subst lbls
+                       return (subst,r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
         Nothing  -> compileError ("Missing value for label" <+> pp lbl $$
                                   "among" <+> hsep (punctuate (pp ',') (map fst as)))
-param2int (VApp _ q vs) ty = do
-  (r ,    ctxt,cnt ) <- getIdxCnt q
-  (r',rs',     cnt') <- compute ctxt vs
-  return (r+r',rs',cnt)
+param2int subst (VApp _ q vs) ty = do
+  (      r ,    ctxt,cnt ) <- getIdxCnt q
+  (subst,r',rs',     cnt') <- compute subst ctxt vs
+  return (subst,r+r',rs',cnt)
   where
-    compute []              []     = return (0,[],1)
-    compute ((_,_,ty):ctxt) (v:vs) = do
-      (r, rs ,cnt ) <- param2int v ty
-      (r',rs',cnt') <- compute ctxt vs
-      return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
-param2int (VInt n) ty
-  | Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1)
-param2int (VMeta i _) ty = do
+    compute subst []              []     = return (subst,0,[],1)
+    compute subst ((_,_,ty):ctxt) (v:vs) = do
+      (subst, r, rs ,cnt ) <- param2int subst v ty
+      (subst, r',rs',cnt') <- compute subst ctxt vs
+      return (subst,r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
+param2int subst (VInt n) ty
+  | Just max <- isTypeInts ty= return (subst,fromIntegral n,[],fromIntegral max+1)
+param2int subst (VMeta i _) ty = do
   st <- getMeta i
   case st of
     Narrowing c ty -> do count <- getCnt ty
-                         return (0,[(1,i-1)],count)
-    Bound _ v      -> param2int v ty
-param2int (VSusp i k vs) ty = do
+                         case Map.lookup i subst of
+                           Just v  -> return (subst,0,[(1,v)],count)
+                           Nothing -> let v      = Map.size subst
+                                          subst' = Map.insert i v subst
+                                      in return (subst',0,[(1,v)],count)
+    Bound _ v      -> param2int subst v ty
+param2int subst (VSusp i k vs) ty = do
   st <- getMeta i
   v <- case st of
          Narrowing c ty -> do v <- chooseMetaValue c ty
@@ -408,12 +413,12 @@ param2int (VSusp i k vs) ty = do
                               return v
          Bound _ v      -> return v
   g <- globals
-  param2int (apply g (k v) vs) ty
-param2int (VFV c vs) ty = do
+  param2int subst (apply g (k v) vs) ty
+param2int subst (VFV c vs) ty = do
   v <- variants c (unvariants vs)
-  param2int v ty
-param2int v ty = compileError ("the parameter:" <+> ppValue Unqualified 0 v $$
-                               "cannot be evaluated at compile time.")
+  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'
diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs
index 33442db89..0b38ffcda 100644
--- a/src/compiler/api/GF/Grammar/Printer.hs
+++ b/src/compiler/api/GF/Grammar/Printer.hs
@@ -171,7 +171,7 @@ 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 quantifiers <+>
+  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)
diff --git a/src/runtime/c/pgf/data.cxx b/src/runtime/c/pgf/data.cxx
index 0799b8a32..0b15e9f8b 100644
--- a/src/runtime/c/pgf/data.cxx
+++ b/src/runtime/c/pgf/data.cxx
@@ -64,13 +64,6 @@ void PgfLParam::release(ref<PgfLParam> param)
     PgfDB::free(param, param->n_terms*sizeof(param->terms[0]));
 }
 
-void PgfPResult::release(ref<PgfPResult> res)
-{
-    if (res->vars != 0)
-        vector<PgfVariableRange>::release(res->vars);
-    PgfDB::free(res, res->param.n_terms*sizeof(res->param.terms[0]));
-}
-
 static void symbols_release(vector<PgfSymbol> syms)
 {
 	for (PgfSymbol sym : syms) {
@@ -122,7 +115,7 @@ static void symbols_release(vector<PgfSymbol> syms)
 
 void PgfConcrRule::release(ref<PgfConcrRule> rule)
 {
-    vector<PgfVariableRange>::release(rule->vars);
+    vector<size_t>::release(rule->ranges);
 
     PgfLParam::release(rule->res);
 
diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h
index 70657ccb5..05c5c3f96 100644
--- a/src/runtime/c/pgf/data.h
+++ b/src/runtime/c/pgf/data.h
@@ -146,13 +146,6 @@ 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 PgfSequenceBackref {
@@ -222,7 +215,7 @@ struct PGF_INTERNAL_DECL PgfSymbolALLCAPIT {
 };
 
 struct PGF_INTERNAL_DECL PgfConcrRule {
-    vector<PgfVariableRange> vars;
+    vector<size_t> ranges;
     ref<PgfLParam> res;
     object container;
     vector<ref<PgfLParam>> args;
diff --git a/src/runtime/c/pgf/linearizer.cxx b/src/runtime/c/pgf/linearizer.cxx
index 4657272a7..6626676cb 100644
--- a/src/runtime/c/pgf/linearizer.cxx
+++ b/src/runtime/c/pgf/linearizer.cxx
@@ -10,31 +10,21 @@ bool PgfLinearizer::Item::instantiate(ref<PgfLParam> lparam,size_t value)
 
     for (size_t j = 0; j < lparam->n_terms; j++) {
         term t = lparam->terms[j];
-        for (size_t k = 0; k < vars.size(); k++) {
-            if (rule->vars[k].var == t.var) {
-                if (vars[k] > 0) {
-                    if (value < vars[k]-1)
-                        return false;
-                    value -= vars[k]-1;
-                }
-                break;
-            }
+        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];
-        for (size_t k = 0; k < vars.size(); k++) {
-            if (rule->vars[k].var == t.var) {
-                if (vars[k] == 0) {
-                    size_t v_val = value / t.factor;
-                    if (v_val >= rule->vars[k].range)
-                        return false;
-                    vars[k] = v_val + 1;
-                    value %= t.factor;
-                }
-                break;
-            }
+        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;
         }
     }
 
@@ -45,12 +35,7 @@ size_t PgfLinearizer::Item::eval(ref<PgfLParam> lparam)
 {
     size_t value = lparam->i0;
     for (size_t i = 0; i < lparam->n_terms; i++) {
-        for (size_t j = 0; j < rule->vars.size(); j++) {
-            if (lparam->terms[i].var == rule->vars[j].var) {
-                value += lparam->terms[i].factor * (vars[j]-1);
-                break;
-            }
-        }
+        value += lparam->terms[i].factor * (vars[lparam->terms[i].var]-1);
     }
     return value;
 }
@@ -252,7 +237,7 @@ bool PgfLinearizer::TreeLinNode::resolve(PgfLinearizer *linearizer)
             size_t max_value = 1;
             for (size_t i = 0; i < item->vars.size(); i++) {
                 if (item->vars[i] == 0)
-                    max_value *= item->rule->vars[i].range;
+                    max_value *= item->rule->ranges[i];
             }
 
             for (size_t value = 0; value < max_value; value++) {
@@ -261,7 +246,7 @@ bool PgfLinearizer::TreeLinNode::resolve(PgfLinearizer *linearizer)
                 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->vars[i].range;
+                        size_t range = new_item->rule->ranges[i];
                         new_item->vars[i] = (v % range)+1;
                         v = v / range;
                     }
@@ -519,14 +504,14 @@ bool PgfLinearizer::TreeLinrefNode::resolve(PgfLinearizer *linearizer)
         size_t max_value = 1;
         for (size_t i = 0; i < item->vars.size(); i++) {
             if (item->vars[i] == 0)
-                max_value *= item->rule->vars[i].range;
+                max_value *= item->rule->ranges[i];
         }
 
         for (size_t value = 0; value < max_value; value++) {
             size_t v = value;
             for (size_t i = 0; i < item->vars.size(); i++) {
                 if (item->vars[i] == 0) {
-                    size_t range = item->rule->vars[i].range;
+                    size_t range = item->rule->ranges[i];
                     item->vars[i] = v % range;
                     v = v / range;
                 }
diff --git a/src/runtime/c/pgf/linearizer.h b/src/runtime/c/pgf/linearizer.h
index 8552b61d6..2c6185259 100644
--- a/src/runtime/c/pgf/linearizer.h
+++ b/src/runtime/c/pgf/linearizer.h
@@ -36,13 +36,13 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
             }
             size_t size() {
                 Item *item = containerof(Item,vars,this);
-                return item->rule->vars.size();
+                return item->rule->ranges.size();
             }
         } vars;
 
         void *operator new(size_t sz, ref<PgfConcrRule> rule)
         {
-            size_t sz2 = rule->vars.size()*sizeof(size_t);
+            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;
diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index 3236a2d43..a41e4ed6a 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -332,17 +332,12 @@ interval_t PgfAbstractParser::Item::interval(ref<PgfLParam> lparam) const
     interval.second = interval.first;
     for (size_t i = 0; i < lparam->n_terms; i++) {
         size_t var = lparam->terms[i].var;
-        for (size_t j = 0; j < vars.size(); j++) {
-            if (rule->vars[j].var == var) {
-                if (vars[j] == 0) {
-                    interval.second += lparam->terms[i].factor * (rule->vars[j].range-1);
-                } else {
-                    size_t value = lparam->terms[i].factor * (vars[j]-1);
-                    interval.first  += value;
-                    interval.second += value;
-                }
-                break;
-            }
+        if (vars[var] == 0) {
+            interval.second += lparam->terms[i].factor * (rule->ranges[var]-1);
+        } else {
+            size_t value = lparam->terms[i].factor * (vars[var]-1);
+            interval.first  += value;
+            interval.second += value;
         }
     }
     return interval;
@@ -353,25 +348,15 @@ bool PgfAbstractParser::Item::instantiate(ref<PgfLParam> lparam1,
 {
     size_t i01 = lparam1->i0;
     for (size_t i = 0; i < lparam1->n_terms; i++) {
-        for (size_t k = 0; k < this->vars.size(); k++) {
-            if (this->rule->vars[k].var == lparam1->terms[i].var) {
-                if (this->vars[k] > 0) {
-                    i01 += lparam1->terms[i].factor * (this->vars[k]-1);
-                }
-                break;
-            }
+        if (this->vars[lparam1->terms[i].var] > 0) {
+            i01 += lparam1->terms[i].factor * (this->vars[lparam1->terms[i].var]-1);
         }
     }
 
     size_t i02 = lparam2->i0;
     for (size_t i = 0; i < lparam2->n_terms; i++) {
-        for (size_t k = 0; k < rule->vars.size(); k++) {
-            if (rule->vars[k].var == lparam2->terms[i].var) {
-                if (values[k] > 0) {
-                    i02 += lparam2->terms[i].factor * (values[k]-1);
-                }
-                break;
-            }
+        if (values[lparam2->terms[i].var] > 0) {
+            i02 += lparam2->terms[i].factor * (values[lparam2->terms[i].var]-1);
         }
     }
 
@@ -386,103 +371,77 @@ bool PgfAbstractParser::Item::instantiate(ref<PgfLParam> lparam1,
     size_t i1 = 0, i2 = 0;
     while (i1 < lparam1->n_terms || i2 < lparam2->n_terms) {
         size_t scale1  = 0;
-        size_t factor1 = 0;
-        size_t var1    = 0;
-        size_t k1      = 0;
+        term t1 = {0,0};
         if (i1 < lparam1->n_terms) {
-            factor1 = lparam1->terms[i1].factor;
-            var1    = lparam1->terms[i1].var;
-            for (k1 = 0; k1 < this->vars.size(); k1++) {
-                if (this->rule->vars[k1].var == var1)
-                    break;
-            }
-            if (this->vars[k1] > 0) {
+            t1 = lparam1->terms[i1];
+            if (this->vars[t1.var] > 0) {
                 i1++;
                 continue;
             }
-            scale1 = factor1 * this->rule->vars[k1].range;
+            scale1 = t1.factor * this->rule->ranges[t1.var];
         }
 
         size_t scale2  = 0;
-        size_t factor2 = 0;
-        size_t var2    = 0;
-        size_t k2      = 0;
+        term t2 = {0,0};
         if (i2 < lparam2->n_terms) {
-            factor2 = lparam2->terms[i2].factor;
-            var2    = lparam2->terms[i2].var;
-            for (k2 = 0; k2 < rule->vars.size(); k2++) {
-                if (rule->vars[k2].var == var2)
-                    break;
-            }
-            if (values[k2] > 0) {
+            t2 = lparam2->terms[i2];
+            if (values[t2.var] > 0) {
                 i2++;
                 continue;
             }
-            scale2 = factor2 * rule->vars[k2].range;
+            scale2 = t2.factor * rule->ranges[t2.var];
         }
 
         if (scale1 > scale2) {
-            size_t min = (i02 / factor1);
+            size_t min = (i02 / t1.factor);
             size_t max = min;
             while (i2 < lparam2->n_terms) {
-                factor2 = lparam2->terms[i2].factor;
-                size_t f = factor2 / factor1;
+                t2 = lparam2->terms[i2];
+                size_t f = t2.factor / t1.factor;
                 if (f == 0)
                     break;
 
-                var2 = lparam2->terms[i2].var;
-                for (k2 = 0; k2 < rule->vars.size(); k2++) {
-                    if (rule->vars[k2].var == var2) {
-                        if (values[k2] == 0) {
-                            max += f * (rule->vars[k2].range-1);
-                        }
-                        break;
-                    }
+                if (values[t2.var] == 0) {
+                    max += f * (rule->ranges[t2.var]-1);
                 }
                 i2++;
             }
-            i02 %= factor1;
+            i02 %= t1.factor;
 
-            if (min >= this->rule->vars[k1].range)
+            if (min >= this->rule->ranges[t1.var])
                 return false;
 
             if (min == max) {
-                if (this->vars[k1] == 0)
-                    this->vars[k1] = min+1;
-                else if (this->vars[k1] != min+1)
+                if (this->vars[t1.var] == 0)
+                    this->vars[t1.var] = min+1;
+                else if (this->vars[t1.var] != min+1)
                     return false;
             }
 
             i1++;
         } else {
-            size_t min = (i01 / factor2);
+            size_t min = (i01 / t2.factor);
             size_t max = min;
             while (i1 < lparam1->n_terms) {
-                factor1 = lparam1->terms[i1].factor;
-                size_t f = factor1 / factor2;
+                t1 = lparam1->terms[i1];
+                size_t f = t1.factor / t2.factor;
                 if (f == 0)
                     break;
 
-                var1 = lparam1->terms[i1].var;
-                for (k1 = 0; k1 < rule->vars.size(); k1++) {
-                    if (rule->vars[k1].var == var1) {
-                        if (values[k1] == 0) {
-                            max += f * (rule->vars[k1].range-1);
-                        }
-                        break;
-                    }
+                if (values[t1.var] == 0) {
+                    max += f * (rule->ranges[t1.var]-1);
                 }
                 i1++;
             }
-            i01 %= factor2;
+            i01 %= t2.factor;
 
-            if (min >= rule->vars[k2].range)
+            if (min >= rule->ranges[t2.var])
                 return false;
 
             if (min == max) {
-                if (values[k2] == 0) {
+                if (values[t2.var] == 0) {
                     // we don't update the production;
-                } else if (values[k2] != min+1)
+                } else if (values[t2.var] != min+1)
                     return false;
             }
 
@@ -881,6 +840,9 @@ void PgfParser::bu_predict(PgfPhrasetable phrasetable,
             bu_predict(phrasetable->left,state,min,len);
 
         if (len > 0) {
+            //if (*current.ptr != ' ' && *current.ptr != 0)
+              //  return;
+
             for (size_t i = 0; i < phrasetable->n_items; i++) {
                 std::map<ref<PgfConcrLincat>, bool> visited;
                 //if (!td_reachable(state, phrasetable->items[i], visited))
diff --git a/src/runtime/c/pgf/parser.h b/src/runtime/c/pgf/parser.h
index 486f50738..d735e57c3 100644
--- a/src/runtime/c/pgf/parser.h
+++ b/src/runtime/c/pgf/parser.h
@@ -26,7 +26,7 @@ protected:
             }
             size_t size() const {
                 Production *prod = containerof(Production,vars,this);
-                return prod->rule->vars.size();
+                return prod->rule->ranges.size();
             }
         } vars;
 
@@ -131,7 +131,7 @@ protected:
             }
             size_t size() const {
                 Item *item = containerof(Item,vars,this);
-                return item->rule->vars.size();
+                return item->rule->ranges.size();
             }
         } vars;
 
@@ -149,7 +149,7 @@ protected:
         void *operator new(size_t sz, ref<PgfConcrRule> rule)
         {
             size_t sz2 = rule->args.size()*sizeof(CCat*)
-                       + rule->vars.size()*sizeof(size_t);
+                       + rule->ranges.size()*sizeof(size_t);
             Item *new_item = (Item *) malloc(sz+sz2);
             memset(new_item+1, 0, sz2);
             return new_item;
diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx
index 21245fe75..82bc65a5e 100644
--- a/src/runtime/c/pgf/pgf.cxx
+++ b/src/runtime/c/pgf/pgf.cxx
@@ -1121,8 +1121,8 @@ PgfText *pgf_print_lindef_internal(object o, size_t i)
     PgfPrinter printer(NULL,0,&m);
 
     ref<PgfConcrRule> rule = lincat->rules[i];
-    if (rule->vars != 0) {
-        printer.lvar_ranges(rule->vars, NULL);
+    if (rule->ranges != 0) {
+        printer.lvar_ranges(rule->ranges, NULL);
         printer.puts(" ");
     }
     printer.efun(&lincat->name);
@@ -1147,8 +1147,8 @@ PgfText *pgf_print_linref_internal(object o, size_t i)
 
     ref<PgfConcrRule> rule = lincat->rules[lincat->n_lindefs+i];
 
-    if (rule->vars != 0) {
-        printer.lvar_ranges(rule->vars, NULL);
+    if (rule->ranges != 0) {
+        printer.lvar_ranges(rule->ranges, NULL);
         printer.puts(" ");
     }
 
@@ -1178,8 +1178,8 @@ PgfText *pgf_print_lin_internal(object o, size_t i)
     ref<PgfConcrRule> rule = lin->rules[i];
     ref<PgfDTyp> ty = lin->absfun->type;
 
-    if (rule->vars != 0) {
-        printer.lvar_ranges(rule->vars, NULL);
+    if (rule->ranges != 0) {
+        printer.lvar_ranges(rule->ranges, NULL);
         printer.puts(" ");
     }
 
@@ -1867,13 +1867,13 @@ public:
             if (rule_index >= rules.size())
                 throw pgf_error(builder_error_msg);
 
-            vector<PgfVariableRange> vars = 
-                (n_vars > 0) ? vector<PgfVariableRange>::alloc(n_vars) : 0;
+            vector<size_t> ranges = 
+                (n_vars > 0) ? vector<size_t>::alloc(n_vars) : 0;
             vector<ref<PgfLParam>> args =
                 (n_args > 0) ? vector<ref<PgfLParam>>::alloc(n_args) : 0;
 
             ref<PgfConcrRule> rule = inline_vector<PgfSymbol>::alloc(&PgfConcrRule::syms, n_syms);
-            rule->vars = vars;
+            rule->ranges = ranges;
             rule->res  = 0;
             rule->container = container;
             rule->args = args;
@@ -1956,7 +1956,7 @@ public:
         } PGF_API_END
     }
 
-    void add_variable(size_t var, size_t range, PgfExn *err)
+    void add_variable(size_t range, PgfExn *err)
     {
         if (err->type != PGF_EXN_NONE)
             return;
@@ -1967,14 +1967,10 @@ public:
 
             ref<PgfConcrRule> rule = rules[rule_index];
 
-            if (rule->vars == 0 || var_index >= rule->vars.size())
+            if (rule->ranges == 0 || var_index >= rule->ranges.size())
                 throw pgf_error(builder_error_msg);
 
-            ref<PgfVariableRange> var_range =
-                rule->vars.elem(var_index);
-            var_range->var   = var;
-            var_range->range = range;
-
+            rule->ranges[var_index] = range;
             var_index++;
         } PGF_API_END
     }
diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h
index 8bc2ddede..d4360dcc0 100644
--- a/src/runtime/c/pgf/pgf.h
+++ b/src/runtime/c/pgf/pgf.h
@@ -631,7 +631,7 @@ struct PgfLinBuilderIface {
     virtual void add_argument(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 set_lin_idx(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 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;
@@ -660,7 +660,7 @@ typedef struct {
     void (*add_argument)(PgfLinBuilderIface *this, 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 (*set_lin_idx)(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 (*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);
diff --git a/src/runtime/c/pgf/phrasetable.h b/src/runtime/c/pgf/phrasetable.h
index fc0e9c544..f54b61bb2 100644
--- a/src/runtime/c/pgf/phrasetable.h
+++ b/src/runtime/c/pgf/phrasetable.h
@@ -17,7 +17,7 @@ struct PGF_INTERNAL_DECL PgfItem {
         }
         size_t size() {
             PgfItem *item = containerof(PgfItem,vars,this);
-            return (item->rule->vars != 0) ? item->rule->vars.size() : 0;
+            return (item->rule->ranges != 0) ? item->rule->ranges.size() : 0;
         }
     } vars;
 
diff --git a/src/runtime/c/pgf/printer.cxx b/src/runtime/c/pgf/printer.cxx
index dc927a5e2..8b740c5ac 100644
--- a/src/runtime/c/pgf/printer.cxx
+++ b/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);
     }
@@ -611,8 +611,8 @@ void PgfPrinter::item(ref<PgfItem> item)
     case PgfConcrLincat::tag: {
         ref<PgfConcrLincat> lincat = ref<PgfConcrLincat>::untagged(item->rule->container);
 
-        if (item->rule->vars != 0) {
-            lvar_ranges(item->rule->vars, &item->vars[0]);
+        if (item->rule->ranges != 0) {
+            lvar_ranges(item->rule->ranges, &item->vars[0]);
             puts(" ");
         }
 
@@ -632,8 +632,8 @@ void PgfPrinter::item(ref<PgfItem> item)
         ref<PgfConcrLin> lin = ref<PgfConcrLin>::untagged(item->rule->container);
         ref<PgfDTyp> ty = lin->absfun->type;
 
-        if (item->rule->vars != 0) {
-            lvar_ranges(item->rule->vars, &item->vars[0]);
+        if (item->rule->ranges != 0) {
+            lvar_ranges(item->rule->ranges, &item->vars[0]);
             puts(" ");
         }
 
diff --git a/src/runtime/c/pgf/printer.h b/src/runtime/c/pgf/printer.h
index 54bcfd753..e637132b9 100644
--- a/src/runtime/c/pgf/printer.h
+++ b/src/runtime/c/pgf/printer.h
@@ -78,7 +78,7 @@ 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 symbol(PgfSymbol sym);
     void symbols(vector<PgfSymbol> syms);
     void item(ref<PgfItem> item);
diff --git a/src/runtime/c/pgf/reader.cxx b/src/runtime/c/pgf/reader.cxx
index 16ddef87b..cb1e5199a 100644
--- a/src/runtime/c/pgf/reader.cxx
+++ b/src/runtime/c/pgf/reader.cxx
@@ -497,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_info->range = read_int();
+    *var_range = read_int();
 }
 
 void PgfReader::read_parg(ref<PgfPArg> parg)
@@ -508,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()
 {
@@ -637,12 +609,12 @@ ref<PgfConcrRule> PgfReader::read_rule()
     size_t n_syms = read_len();
     ref<PgfConcrRule> rule = inline_vector<PgfSymbol>::alloc(&PgfConcrRule::syms, n_syms);
 
-    vector<PgfVariableRange> vars = read_null_vector(&PgfReader::read_variable_range);
+    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->vars = vars;
+    rule->ranges = ranges;
     rule->res  = res;
     rule->container = container;
     rule->args = args;
diff --git a/src/runtime/c/pgf/reader.h b/src/runtime/c/pgf/reader.h
index 2167e7214..49a3a6310 100644
--- a/src/runtime/c/pgf/reader.h
+++ b/src/runtime/c/pgf/reader.h
@@ -77,9 +77,8 @@ public:
     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<PgfConcrLin> read_lin();
     ref<PgfConcrPrintname> read_printname();
@@ -103,7 +102,6 @@ private:
 
     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; }
 
diff --git a/src/runtime/c/pgf/writer.cxx b/src/runtime/c/pgf/writer.cxx
index cfc05b1d6..f35ca4d75 100644
--- a/src/runtime/c/pgf/writer.cxx
+++ b/src/runtime/c/pgf/writer.cxx
@@ -290,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)
@@ -310,7 +309,7 @@ void PgfWriter::write_rule(ref<PgfConcrRule> rule)
 {
     write_len(rule->syms.size());
 
-    write_null_vector(rule->vars, &PgfWriter::write_variable_range);
+    write_null_vector(rule->ranges, &PgfWriter::write_variable_range);
     write_lparam(rule->res);
     write_null_vector(rule->args, &PgfWriter::write_lparam);
 
diff --git a/src/runtime/c/pgf/writer.h b/src/runtime/c/pgf/writer.h
index 5bb8bb881..aa7a96443 100644
--- a/src/runtime/c/pgf/writer.h
+++ b/src/runtime/c/pgf/writer.h
@@ -42,7 +42,7 @@ 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_symbol(PgfSymbol sym);
     void write_lin(ref<PgfConcrLin> lin);
diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc
index 67f9e03d4..8b1c8a8a7 100644
--- a/src/runtime/haskell/PGF2/Transactions.hsc
+++ b/src/runtime/haskell/PGF2/Transactions.hsc
@@ -250,7 +250,7 @@ data Symbol
   | SymALL_CAPIT                    -- the special ALL_CAPIT token
   deriving (Eq,Ord,Show)
 
-type Quantifiers = [(LVar,Int)]
+type Quantifiers = [Int]
 data Rule = Rule Quantifiers LParam [LParam] LParam [Symbol]
                  deriving (Eq,Ord,Show)
 
@@ -320,8 +320,8 @@ withBuildLinIface rules f = do
         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) ->
-          callLinBuilder2 fun c_builder (fromIntegral v) (fromIntegral r) c_exn
+        forM_ vars c_exn $ \r ->
+          callLinBuilder1 fun c_builder (fromIntegral r) c_exn
         forM_ seq c_exn (addSymbol c_builder vtbl c_exn)
         fun <- (#peek PgfLinBuilderIfaceVtbl, end_rule) vtbl
         callLinBuilder0 fun c_builder c_exn

From 7c6c1941423988dedf663088648ca193328baa40 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 14 Jan 2026 17:49:45 +0100
Subject: [PATCH 081/144] fix the debug mode after the last change

---
 src/runtime/c/pgf/parser.cxx | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index a41e4ed6a..56972bbf9 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -251,8 +251,8 @@ void PgfAbstractParser::complete(Item *item, const PgfTextSpot &spot, bool bind)
 #ifdef DEBUG_PARSER
             {
                 PgfPrinter printer(NULL,0,NULL);
-                if (item->rule->vars.size() > 0) {
-                    printer.lvar_ranges(item->rule->vars, &item->vars[0]);
+                if (item->rule->ranges.size() > 0) {
+                    printer.lvar_ranges(item->rule->ranges, &item->vars[0]);
                     printer.puts(" ");
                 }
                 printer.nprintf(64,"complete [%zd-%zd; ",item->cont->state->end.pos,state->start.pos);
@@ -629,7 +629,7 @@ void PgfAbstractParser::print_item(Item *item, const PgfTextSpot &spot)
     printer.nprintf(32, "[%zd-%zd; ", item->cont ? item->cont->state->end.pos : 0, spot.pos);
 
     if (item->vars.size() > 0) {
-        printer.lvar_ranges(item->rule->vars, &item->vars[0]);
+        printer.lvar_ranges(item->rule->ranges, &item->vars[0]);
         printer.puts(" ");
     }
 
@@ -703,7 +703,7 @@ void PgfAbstractParser::print_prod(CCat *ccat, Production *prod)
     PgfPrinter printer(NULL,0,NULL);
 
     if (prod->vars.size() > 0) {
-        printer.lvar_ranges(prod->rule->vars, &prod->vars[0]);
+        printer.lvar_ranges(prod->rule->ranges, &prod->vars[0]);
         printer.puts(" ");
     }
 
@@ -840,8 +840,8 @@ void PgfParser::bu_predict(PgfPhrasetable phrasetable,
             bu_predict(phrasetable->left,state,min,len);
 
         if (len > 0) {
-            //if (*current.ptr != ' ' && *current.ptr != 0)
-              //  return;
+            if (*current.ptr != ' ' && *current.ptr != 0)
+                return;
 
             for (size_t i = 0; i < phrasetable->n_items; i++) {
                 std::map<ref<PgfConcrLincat>, bool> visited;

From 80524bdec9217482b671cba0cfea8119bad5dc92 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 15 Jan 2026 09:56:39 +0100
Subject: [PATCH 082/144] add Eq instance for Info

---
 src/compiler/api/GF/Grammar/Grammar.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs
index 642b696e3..bd0d2bf19 100644
--- a/src/compiler/api/GF/Grammar/Grammar.hs
+++ b/src/compiler/api/GF/Grammar/Grammar.hs
@@ -342,7 +342,7 @@ data Info =
 
 -- indirection to module Ident
  | AnyInd Bool ModuleName                        -- ^ (/INDIR/) the 'Bool' says if canonical
-  deriving Show
+  deriving (Eq,Show)
 
 type Type    = Term
 type Cat     = QIdent

From 307a4481f344cd1e36e959d24287f4497feb367d Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 20 Jan 2026 07:40:07 +0100
Subject: [PATCH 083/144] produce identW when needed

---
 src/compiler/api/GF/Grammar/Lookup.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Grammar/Lookup.hs b/src/compiler/api/GF/Grammar/Lookup.hs
index b86596be7..968127fe5 100644
--- a/src/compiler/api/GF/Grammar/Lookup.hs
+++ b/src/compiler/api/GF/Grammar/Lookup.hs
@@ -73,7 +73,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)
 

From f780099a41a36496dc8bc9b7fdf53f2f519986d2 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 29 Jan 2026 08:48:01 +0100
Subject: [PATCH 084/144] permit string literals in flags

---
 src/compiler/api/GF/Grammar/Parser.y | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/src/compiler/api/GF/Grammar/Parser.y b/src/compiler/api/GF/Grammar/Parser.y
index 9ffc2b30a..d8a06351f 100644
--- a/src/compiler/api/GF/Grammar/Parser.y
+++ b/src/compiler/api/GF/Grammar/Parser.y
@@ -294,6 +294,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                                           } 

From eab006257e80ee59795022c09360bd555586572e Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 29 Jan 2026 11:15:04 +0100
Subject: [PATCH 085/144] escape identifiers if necessary

---
 src/compiler/api/GF/Infra/Ident.hs | 23 +++++++++++++++++++++--
 1 file changed, 21 insertions(+), 2 deletions(-)

diff --git a/src/compiler/api/GF/Infra/Ident.hs b/src/compiler/api/GF/Infra/Ident.hs
index fbad6e694..86f64b6b6 100644
--- a/src/compiler/api/GF/Infra/Ident.hs
+++ b/src/compiler/api/GF/Infra/Ident.hs
@@ -29,7 +29,7 @@ import qualified Data.ByteString.UTF8 as UTF8
 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
@@ -104,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
 

From 3b3979bf42d4320e03c294a4b92835a839b8d728 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 5 Feb 2026 10:25:04 +0100
Subject: [PATCH 086/144] use the same type checker and evaluator for abstract
 and concrete syntax

---
 src/compiler/api/GF/Command/SourceCommands.hs |   6 +-
 src/compiler/api/GF/Compile/CheckGrammar.hs   |  69 ++--
 .../{Compute/Concrete.hs => Compute.hs}       |  25 +-
 .../api/GF/Compile/Compute/Abstract.hs        | 138 --------
 src/compiler/api/GF/Compile/GenerateBC.hs     |  28 +-
 src/compiler/api/GF/Compile/GeneratePMCFG.hs  |  20 +-
 .../api/GF/Compile/GrammarToCanonical.hs      |   4 +-
 src/compiler/api/GF/Compile/Rename.hs         |   4 +-
 .../{TypeCheck/Concrete.hs => TypeCheck.hs}   | 158 ++++++---
 .../api/GF/Compile/TypeCheck/Abstract.hs      |  82 -----
 src/compiler/api/GF/Compile/TypeCheck/TC.hs   | 324 ------------------
 src/compiler/api/GF/Grammar.hs                |   2 -
 src/compiler/api/GF/Grammar/Lookup.hs         |  34 +-
 src/compiler/api/GF/Grammar/Printer.hs        |  19 -
 src/compiler/api/GF/Grammar/Unify.hs          | 115 -------
 src/compiler/api/GF/Grammar/Values.hs         |  57 ---
 src/compiler/api/GF/Interactive.hs            |   8 +-
 src/compiler/gf.cabal                         |   8 +-
 18 files changed, 209 insertions(+), 892 deletions(-)
 rename src/compiler/api/GF/Compile/{Compute/Concrete.hs => Compute.hs} (98%)
 delete mode 100644 src/compiler/api/GF/Compile/Compute/Abstract.hs
 rename src/compiler/api/GF/Compile/{TypeCheck/Concrete.hs => TypeCheck.hs} (93%)
 delete mode 100644 src/compiler/api/GF/Compile/TypeCheck/Abstract.hs
 delete mode 100644 src/compiler/api/GF/Compile/TypeCheck/TC.hs
 delete mode 100644 src/compiler/api/GF/Grammar/Unify.hs
 delete mode 100644 src/compiler/api/GF/Grammar/Values.hs

diff --git a/src/compiler/api/GF/Command/SourceCommands.hs b/src/compiler/api/GF/Command/SourceCommands.hs
index 6e856645b..024f7c889 100644
--- a/src/compiler/api/GF/Command/SourceCommands.hs
+++ b/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.Concrete(normalForm,normalFlatForm,Globals(..),stdPredef)
-import GF.Compile.TypeCheck.Concrete as TC(inferLType)
+import GF.Compile.Compute(normalForm,normalFlatForm,Globals(..),stdPredef)
+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
diff --git a/src/compiler/api/GF/Compile/CheckGrammar.hs b/src/compiler/api/GF/Compile/CheckGrammar.hs
index 34fc9fa44..b427ce019 100644
--- a/src/compiler/api/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/api/GF/Compile/CheckGrammar.hs
@@ -26,9 +26,8 @@ import Prelude hiding ((<>))
 import GF.Infra.Ident
 import GF.Infra.Option
 
-import GF.Compile.TypeCheck.Abstract
-import GF.Compile.TypeCheck.Concrete(checkLType,inferLType)
-import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef)
+import GF.Compile.TypeCheck(checkLType,inferLType,checkContext,checkDef)
+import GF.Compile.Compute(normalForm,Globals(..),noPredef,stdPredef)
 
 import GF.Grammar
 import GF.Grammar.Lexer
@@ -157,42 +156,43 @@ 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" $
-        checkContext gr cont
+      chIn loc "the category" $ do
+        cont <- checkContext ga cont
+        update sm c (AbsCat (Just (L loc cont)))
 
     AbsFun (Just (L loc typ)) ma md moper -> do
-      mkCheck loc "the type of function" $
-        checkTyp gr typ
-      typ <- compAbsTyp [] typ   -- to calculate let definitions
+      chIn loc "the type of function" $
+        checkLType ga typ typeType
+      typ <- normalForm ga typ   -- to calculate let definitions
       case md of
-        Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
-                                          checkDef gr (fst sm,c) typ eq) eqs
+        Just eqs -> mapM_ (\(L loc eq) -> chIn loc "the definition of function" $
+                                            checkDef ga (fst sm,c) typ eq) eqs
         Nothing  -> return ()
       update sm c (AbsFun (Just (L loc typ)) ma md moper)
 
     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  <- normalForm g typ
+                                      (typ,_) <- checkLType gc typ typeType
+                                      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)
@@ -201,13 +201,13 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
       mt <- case (mty,mt) of
               (Just (args,cat,cont,val),Just (L loc trm)) ->
                   chIn loc "linearization of" $ do
-                     (trm,_) <- checkLType g trm (mkFunType (zipWith (\cat (_,_,ty) -> lock cat ty) args 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)
@@ -216,14 +216,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
-                         normalForm g ty
+                         (ty,_) <- checkLType gc ty typeType
+                         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" $
@@ -231,10 +231,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 $
@@ -249,12 +249,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)
@@ -269,22 +270,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)
@@ -331,4 +316,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
diff --git a/src/compiler/api/GF/Compile/Compute/Concrete.hs b/src/compiler/api/GF/Compile/Compute.hs
similarity index 98%
rename from src/compiler/api/GF/Compile/Compute/Concrete.hs
rename to src/compiler/api/GF/Compile/Compute.hs
index 55494815f..719bc5ef5 100644
--- a/src/compiler/api/GF/Compile/Compute/Concrete.hs
+++ b/src/compiler/api/GF/Compile/Compute.hs
@@ -1,10 +1,10 @@
 {-# LANGUAGE RankNTypes, BangPatterns, GeneralizedNewtypeDeriving, TupleSections #-}
 
-module GF.Compile.Compute.Concrete
+module GF.Compile.Compute
            (Env, Scope, Value(..), Variants(..), OptionInfo(..),
             ConstValue(..), Globals(..), PredefTable, EvalM,
             mapVariantsC, unvariants,
-            runEvalM, runEvalMWithInput, stdPredef, globals,
+            runEvalM, runEvalMWithInput, stdPredef, noPredef, globals,
             PredefImpl, Predef(..), ($\),
             pdCanonicalArgs, pdArity,
             normalForm, normalFlatForm,
@@ -17,7 +17,7 @@ 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(lookupAbsDef,lookupResDef,lookupOrigInfo)
 import GF.Grammar.Grammar
 import GF.Grammar.Macros
 import GF.Grammar.Predef
@@ -58,7 +58,7 @@ pdArity n def = Predef $ \g c args ->
 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]
@@ -245,11 +245,17 @@ 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                = let v0 = VApp c q vs
+                                in case lookupAbsDef gr q of
+                                     Ok (Just arity,Just eqs)
+                                       | length vs < arity -> v0
+                                       | otherwise -> patternMatch g c v0 (map (\(ps,t) -> (env,ps,vs,t)) eqs)
+                                     Bad msg -> error msg
   | otherwise                 = case lookupResDef gr q of
                                   Ok t    -> eval g env 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 s (C t1 t2)      []  = let (!s1,!s2) = split s
 
@@ -325,7 +331,7 @@ eval g env c t@(Opts n cs)  vs  = if null cs
 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
     Just def -> let valueOf (Const res) = res
@@ -335,6 +341,9 @@ evalPredef g@(Gl gr pds) c n args =
                     valueOf NonExist    = VApp c (cPredef,cNonExist) []
                 in valueOf (runPredef def g c args)
 
+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}))
@@ -540,7 +549,7 @@ 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 (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
@@ -651,7 +660,7 @@ vtableSelect g v0 ty cs v2 vs =
             Ok res  -> res
             Bad msg -> error msg
 
-        Gl gr _ = g
+        Gl gr _ _ = g
     value2index (VInt n) (VApp _ c [VInt max])
       | Q c == cnPredef cInts         = Const (fromIntegral n,fromIntegral max+1)
     value2index (VFV c vs)        vty = CFV c (fmap (\v -> value2index v vty) vs)
diff --git a/src/compiler/api/GF/Compile/Compute/Abstract.hs b/src/compiler/api/GF/Compile/Compute/Abstract.hs
deleted file mode 100644
index 5ba2eeb21..000000000
--- a/src/compiler/api/GF/Compile/Compute/Abstract.hs
+++ /dev/null
@@ -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])
diff --git a/src/compiler/api/GF/Compile/GenerateBC.hs b/src/compiler/api/GF/Compile/GenerateBC.hs
index 338c2bf7d..e380ac409 100644
--- a/src/compiler/api/GF/Compile/GenerateBC.hs
+++ b/src/compiler/api/GF/Compile/GenerateBC.hs
@@ -101,11 +101,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 =
-  case lookupAbsDef gr m id of
+compileFun gr eval st vs (Q q@(m,id))  h0 bs args =
+  case lookupAbsDef gr q of
     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 +164,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 =
-  case lookupAbsDef gr m id of
+compileArg gr st vs (Q q@(m,id)) h0 bs =
+  case lookupAbsDef gr q of
     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 +201,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
-                   Q c@(m,id) -> case lookupAbsDef gr m id of
-                                   Ok (_,Just _) -> Nothing
-                                   _             -> 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
+  in case f of
+       QC q@(m,id) ->
+            let Ok ty = lookupFunType gr q
                 (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 +226,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
diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index c2d360927..a6b0f481f 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -13,7 +13,7 @@ import GF.Grammar.Macros
 import GF.Grammar.Predef
 import GF.Grammar.Printer hiding (ppValue)
 import GF.Text.Pretty hiding (empty)
-import GF.Compile.Compute.Concrete hiding ( getMeta, setMeta, globals, variants )
+import GF.Compile.Compute hiding ( getMeta, setMeta, globals, variants )
 import qualified GF.Text.Pretty as PP
 import qualified Data.Map as Map
 import qualified Data.Set as Set
@@ -30,7 +30,7 @@ generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check S
 generatePMCFG opts cwd gr cmo@(cm,cmi)
   | mstatus cmi == MSComplete && isModCnc cmi =
                 do let gr' = prependModule gr cmo
-                       g   = Gl gr' (stdPredef g)
+                       g   = Gl gr' (stdPredef g) False
                    js <- Map.traverseWithKey (addPMCFG cwd g cmi) (jments cmi)
                    return (cm,cmi{jments = js})
   | otherwise = return cmo
@@ -55,7 +55,7 @@ addPMCFG cwd g cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) = do
                                    return (Just (L loc prn))
   return (CncCat mty mdef mref mprn (Just (defs,refs)))
   where
-    Gl sgr _ = g
+    Gl sgr _ _ = g
 addPMCFG cwd g cmi id (CncFun (Just lty@(cats,cat,ctxt,ty)) mlin@(Just (L loc term)) mprn Nothing) = do
   rules <- checkInModule cwd cmi loc ("Happened in the rule generation for" <+> id) $
              pmcfgForm g term ctxt ty
@@ -66,7 +66,7 @@ addPMCFG cwd g cmi id (CncFun (Just lty@(cats,cat,ctxt,ty)) mlin@(Just (L loc te
                                    return (Just (L loc prn))
   return (CncFun (Just lty) mlin mprn (Just rules))
   where
-    Gl sgr _ = g
+    Gl sgr _ _ = g
 
 addPMCFG cwd g cmi id info = return info
 
@@ -83,9 +83,9 @@ pmcfgForm g t ctxt ty = do
     qs <- quantifiers (Map.toList subst)
     return (Rule qs res_params arg_params lin_idx seq)
   where
-    Gl sgr _ = g
+    Gl sgr _ _ = g
 
-    quantifiers vars = GenM (\(Gl sgr _) k svs ms ->
+    quantifiers vars = GenM (\(Gl sgr _ _) k svs ms ->
       k [boundsOf sgr ms variable | (variable,v) <- sortOn snd vars]
         svs ms)
       where
@@ -216,7 +216,7 @@ breakDown g ms c r rs v (Table p q) fn0 fn = do
       v2 = VMeta i []
       v0 = VS v v2 []
       (c1,c2) = split c
-      Gl gr _ = g
+      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
@@ -480,12 +480,12 @@ getMeta i = GenM $ \_ k svs ms r ->
 setMeta i st = GenM $ \_ k svs ms ->
   k () svs (Map.insert i st ms)
 
-getCnt ty = GenM $ \(Gl gr _) k svs ms r ->
+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 ->
+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
@@ -495,7 +495,7 @@ getIdxCnt q = GenM $ \(Gl gr _) k svs ms r ->
     Bad msg -> checkError (pp msg)
 
 chooseMetaValue :: Choice -> Type -> GenM Value
-chooseMetaValue s ptyp = GenM $ \g@(Gl gr _) k svs ms r ->
+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
diff --git a/src/compiler/api/GF/Compile/GrammarToCanonical.hs b/src/compiler/api/GF/Compile/GrammarToCanonical.hs
index ced7d309a..b00060a9d 100644
--- a/src/compiler/api/GF/Compile/GrammarToCanonical.hs
+++ b/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.Concrete
+import GF.Compile.Compute
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Data.Maybe(mapMaybe,fromMaybe)
@@ -81,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,
diff --git a/src/compiler/api/GF/Compile/Rename.hs b/src/compiler/api/GF/Compile/Rename.hs
index b6233b8f7..99e3570ec 100644
--- a/src/compiler/api/GF/Compile/Rename.hs
+++ b/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,6 +105,7 @@ renameIdentTerm' env@(act,imps) t0 =
 
 info2status :: Maybe ModuleName -> Ident -> Info -> Term
 info2status mq c i = case i of
+  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
diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck.hs
similarity index 93%
rename from src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
rename to src/compiler/api/GF/Compile/TypeCheck.hs
index 3594927ae..f325f8c03 100644
--- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck.hs
@@ -1,5 +1,10 @@
 {-# LANGUAGE RankNTypes, CPP, TupleSections, LambdaCase #-}
-module GF.Compile.TypeCheck.Concrete ( checkLType, checkLType', inferLType, inferLType' ) where
+module GF.Compile.TypeCheck
+                 ( checkLType, checkLType'
+                 , inferLType, inferLType'
+                 , checkContext
+                 , checkDef
+                 ) where
 
 -- The code here is based on the paper:
 -- Simon Peyton Jones, Dimitrios Vytiniotis, Stephanie Weirich.
@@ -11,7 +16,7 @@ import GF.Grammar hiding (Env, VGen, VApp, VRecType, ppValue)
 import GF.Grammar.Lookup
 import GF.Grammar.Predef
 import GF.Grammar.Lockfield
-import GF.Compile.Compute.Concrete
+import GF.Compile.Compute
 import GF.Infra.CheckM
 import GF.Data.ErrM ( Err(Ok, Bad) )
 import Control.Applicative(Applicative(..),(<|>))
@@ -59,6 +64,42 @@ inferLType' t = do
   t <- zonkTerm [] t
   return (t,vty)
 
+checkContext :: Globals -> Context -> Check Context
+checkContext g ctxt = do
+  res <- runEvalM g $ check [] unit ctxt
+  case res of
+    [tty] -> return tty
+    _     -> checkError (pp "Encountered variants while type checking")
+  where
+    check scope c []               = return []
+    check scope c ((bt,x,ty):ctxt) = do
+      let (c1,c23) = split c
+          (c2,c3)  = split c23
+      (ty,_) <- tcRho scope c1 ty (Just vtypeType)
+      g <- globals
+      ctxt <- check ((x,eval g (scopeEnv scope) c2 ty []):scope) c3 ctxt
+      return ((bt,x,ty):ctxt)
+
+checkDef :: Globals -> QIdent -> Type -> Equation -> Check Equation
+checkDef g q ty (ps,t) = do
+  let (c1,c23) = split unit
+      (c2,c3)  = split c23
+  res <- runEvalM g $ do
+            (scope,ty) <- go [] c1 (eval g [] c2 ty []) ps
+            (t,_) <- tcRho scope c3 t (Just ty)
+            return (ps,t)
+  case res of
+    [eq] -> return eq
+    _    -> checkError (pp "Encountered variants while type checking")
+  where
+    go scope c ty []     = return (scope,ty)
+    go scope c ty (p:ps) = do (_,_,arg_ty,res_ty) <- unifyFun scope ty
+                              let (c1,c2) = split c
+                              (scope,arg_ty) <- tcPatt scope c1 p (Just arg_ty)
+                              go scope c2 res_ty ps
+
+  -- tcPatt scope c PW        Nothing    = do
+
 inferSigma :: Scope -> Choice -> Term -> EvalM (Term,Sigma)
 inferSigma scope s t = do                                      -- GEN1
   (t,ty) <- tcRho scope s t Nothing
@@ -195,15 +236,15 @@ tcRho scope c (Typed body ann_ty) mb_ty = do                   -- ANNOT
   let v_ann_ty = eval g (scopeEnv scope) c2 ann_ty []
   (body,_) <- tcRho scope c3 body (Just v_ann_ty)
   instSigma scope c4 (Typed body ann_ty) v_ann_ty mb_ty
-tcRho scope c (FV ts) mb_ty = do
+tcRho scope c (FV ts) mb_ty = concreteOnly "Variants" $ do
   (ts,ty) <- tcUnifying scope c ts mb_ty
   return (FV ts, ty)
 tcRho scope s t@(Sort _) mb_ty = do
   instSigma scope s t vtypeType mb_ty
-tcRho scope c t@(RecType rs) Nothing   = do
+tcRho scope c t@(RecType rs) Nothing   = concreteOnly "Record types" $ do
   (rs,mb_ty) <- tcRecTypeFields scope c rs Nothing
   return (RecType rs,fromMaybe vtypePType mb_ty)
-tcRho scope c t@(RecType rs) (Just ty) = do
+tcRho scope c t@(RecType rs) (Just ty) = concreteOnly "Record types" $ do
   (scope,f,ty') <- skolemise scope ty
   case ty' of
     VSort s
@@ -217,7 +258,7 @@ tcRho scope c t@(RecType rs) (Just ty) = do
                                "cannot be of type" <+> ppTerm Unqualified 0 ty)
   (rs,mb_ty) <- tcRecTypeFields scope c rs (Just ty')
   return (f (RecType rs),ty)
-tcRho scope s t@(Table p res) mb_ty = do
+tcRho scope s t@(Table p res) mb_ty = concreteOnly "Tables" $ do
   let (s1,s23) = split s
       (s2,s3)  = split s23
   (p,  p_ty)   <- tcRho scope s1 p   (Just vtypePType)
@@ -240,7 +281,7 @@ tcRho scope c (S t p) mb_ty = do
   (t,t_ty) <- tcRho scope c1 t (Just t_ty)
   (p,_) <- tcRho scope c2 p (Just p_ty)
   return (S t p, res_ty)
-tcRho scope c (T tt ps) Nothing = do                           -- ABS1/AABS1 for tables
+tcRho scope c (T tt ps) Nothing = concreteOnly "Tables" $ do   -- ABS1/AABS1 for tables
   let (c1,c2) = split c
   mb_p_ty <- case tt of
                TRaw      -> return Nothing
@@ -251,7 +292,7 @@ tcRho scope c (T tt ps) Nothing = do                           -- ABS1/AABS1 for
   (ps,p_ty,res_ty) <- tcCases scope c2 ps mb_p_ty Nothing
   p_ty_t <- value2termM True [] p_ty
   return (T (TTyped p_ty_t) ps, VTable p_ty res_ty)
-tcRho scope c (T tt ps) (Just ty) = do                         -- ABS2/AABS2 for tables
+tcRho scope c (T tt ps) (Just ty) = concreteOnly "Tables" $ do -- ABS2/AABS2 for tables
   let (c12,c34) = split c
       (c3,c4)   = split c34
   (scope,f,ty') <- skolemise scope ty
@@ -266,7 +307,7 @@ tcRho scope c (T tt ps) (Just ty) = do                         -- ABS2/AABS2 for
   (ps,p_ty,res_ty) <- tcCases scope c3 ps (Just p_ty) (Just res_ty)
   p_ty_t <- value2termM True (scopeVars scope) p_ty
   return (f (T (TTyped p_ty_t) ps), VTable p_ty res_ty)
-tcRho scope c (V p_ty ts) Nothing = do
+tcRho scope c (V p_ty ts) Nothing = concreteOnly "Tables" $ do
   let (c1,c2,c3,c4) = split4 c
   (p_ty, _) <- tcRho scope c1 p_ty (Just vtypeType)
   i <- newResiduation scope
@@ -279,7 +320,7 @@ tcRho scope c (V p_ty ts) Nothing = do
   ts <- mapCM go c2 ts
   g <- globals
   return (V p_ty ts, VTable (eval g (scopeEnv scope) c3 p_ty []) res_ty)
-tcRho scope c (V p_ty0 ts) (Just ty) = do
+tcRho scope c (V p_ty0 ts) (Just ty) = concreteOnly "Tables" $ do
   let (c1,c2,c3,c4) = split4 c
   (scope,f,ty') <- skolemise scope ty
   (p_ty, res_ty) <- unifyTbl scope ty'
@@ -289,13 +330,13 @@ tcRho scope c (V p_ty0 ts) (Just ty) = do
   unify scope p_ty p_vty0
   ts <- mapCM (\c t -> fmap fst $ tcRho scope c t (Just res_ty)) c3 ts
   return (V p_ty0 ts, VTable p_ty res_ty)
-tcRho scope c (R rs) Nothing = do
+tcRho scope c (R rs) Nothing = concreteOnly "Records" $ do
   lttys <- inferRecFields scope c [] rs
   rs <- mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
   return (R        rs,
           VRecType [(l,True,ty) | (l,t,ty) <- lttys] False
          )
-tcRho scope c (R rs) (Just ty) = do
+tcRho scope c (R rs) (Just ty) = concreteOnly "Records" $ do
   (scope,f,ty') <- skolemise scope ty
   case ty' of
     (VRecType ltys _)->do lttys <- checkRecFields scope c rs [] ltys
@@ -315,12 +356,12 @@ tcRho scope c (P t l) mb_ty = do
                             return (VMeta i [])
   (t,t_ty) <- tcRho scope c t (Just (VRecType [(l,True,l_ty)] True))
   return (P t l,l_ty)
-tcRho scope c (C t1 t2) mb_ty = do
+tcRho scope c (C t1 t2) mb_ty = concreteOnly "String operations" $ do
   let (c1,c2,c3,c4) = split4 c
   (t1,t1_ty) <- tcRho scope c1 t1 (Just vtypeStr)
   (t2,t2_ty) <- tcRho scope c2 t2 (Just vtypeStr)
   instSigma scope c3 (C t1 t2) vtypeStr mb_ty
-tcRho scope c (Glue t1 t2) mb_ty = do
+tcRho scope c (Glue t1 t2) mb_ty = concreteOnly "String operations" $ do
   let (c1,c2,c3,c4) = split4 c
   (t1,t1_ty) <- tcRho scope c1 t1 (Just vtypeStr)
   (t2,t2_ty) <- tcRho scope c2 t2 (Just vtypeStr)
@@ -417,7 +458,7 @@ tcRho scope c (ELin cat t) mb_ty = do  -- this could be done earlier, i.e. in th
   tcRho scope c (ExtR t (R [(lockLabel cat,(Just (RecType []),R []))])) mb_ty
 tcRho scope c (ELincat cat t) mb_ty = do  -- this could be done earlier, i.e. in the parser
   tcRho scope c (ExtR t (RecType [(lockLabel cat,[],RecType [])])) mb_ty
-tcRho scope c (Alts t ss) mb_ty = do
+tcRho scope c (Alts t ss) mb_ty = concreteOnly "String operations" $ do
   let (c1,c2,c3,c4) = split4 c
   (t,_) <- tcRho scope c1 t (Just vtypeStr)
   ss    <- mapCM (\c (t1,t2) -> do
@@ -427,17 +468,17 @@ tcRho scope c (Alts t ss) mb_ty = do
                           return (t1,t2))
                  c2 ss
   instSigma scope c3 (Alts t ss) vtypeStr mb_ty
-tcRho scope c (Strs ss) mb_ty = do
+tcRho scope c (Strs ss) mb_ty = concreteOnly "String operations" $ do
   let (c1,c2) = split c
   ss <- mapCM (\c t -> do (t,_) <- tcRho scope c t (Just vtypeStr)
                           return t)
               c1 ss
   instSigma scope c2 (Strs ss) vtypeStrs mb_ty
-tcRho scope c (EPattType ty) mb_ty = do
+tcRho scope c (EPattType ty) mb_ty = concreteOnly "Pattern types" $ do
   let (c1,c2) = split c
   (ty, _) <- tcRho scope c1 ty (Just vtypeType)
   instSigma scope c2 (EPattType ty) vtypeType mb_ty
-tcRho scope c t@(EPatt _ _ p) mb_ty = do
+tcRho scope c t@(EPatt _ _ p) mb_ty = concreteOnly "Patterns" $ do
   (scope,f,mb_ty) <- case mb_ty of
                        Nothing -> return (scope,id,Nothing)
                        Just ty -> do (scope,f,ty) <- skolemise scope ty
@@ -447,7 +488,7 @@ tcRho scope c t@(EPatt _ _ p) mb_ty = do
   (_,ty) <- tcPatt scope c p mb_ty
   (min,max,p) <- measurePatt p
   return (f (EPatt min max p), VPattType ty)
-tcRho scope c (Markup tag attrs children) mb_ty = do
+tcRho scope c (Markup tag attrs children) mb_ty = concreteOnly "Markups" $ do
   let (c1,c2,c3,c4) = split4 c
   attrs <- mapCM (\c (id,t) -> do
                        (t,_) <- tcRho scope c t Nothing
@@ -456,7 +497,7 @@ tcRho scope c (Markup tag attrs children) mb_ty = do
   res <- mapCM (\c (L loc child) -> fmap (L loc . fst) (tcRho scope c child Nothing)) c2 children
   instSigma scope c3 (Markup tag attrs res) vtypeMarkup mb_ty
 tcRho scope c (Reset ctl mb_ct t qid) mb_ty
-  | ctl == cConcat || ctl == cConcat' = do
+  | ctl == cConcat || ctl == cConcat' = concreteOnly "Control operators" $ do
       let (c1,c23) = split c
           (c2,c3 ) = split c23
       (t,_) <- tcRho scope c1 t Nothing
@@ -465,7 +506,7 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
                                return (Just ct)
                  Nothing -> return Nothing
       instSigma scope c2 (Reset ctl mb_ct t qid) vtypeMarkup mb_ty
-  | ctl == cOne = do
+  | ctl == cOne = concreteOnly "Control operators" $ do
       let (c1,c2) = split c
       (t,ty)     <- tcRho scope c1 t mb_ty
       (mb_ct,ty) <- case mb_ct of
@@ -473,7 +514,7 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
                                     return (Just ct,ty)
                       Nothing -> return (Nothing,ty)
       return (Reset ctl mb_ct t qid,ty)
-  | ctl == cSelect = do
+  | ctl == cSelect = concreteOnly "Control operators" $ do
       let (c1,c2) = split c
       ty <- case mb_ty of
               Just ty -> return ty
@@ -488,7 +529,7 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
                  Nothing -> evalError (pp "[select: .. | ..] requires an integer argument")
       (t,_) <- tcRho scope c1 t (Just rec_ty)
       return (Reset ctl mb_ct t qid,ty)
-  | ctl == cFilter = do
+  | ctl == cFilter = concreteOnly "Control operators" $ do
       ty <- case mb_ty of
               Just ty -> return ty
               Nothing -> do i <- newResiduation scope
@@ -501,7 +542,7 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
         Nothing -> return ()
       (t,_) <- tcRho scope c t (Just rec_ty)
       return (Reset ctl mb_ct t qid,ty)
-  | ctl == cDefault = do
+  | ctl == cDefault = concreteOnly "Control operators" $ do
       let (c1,c2) = split c
       (t,ty)     <- tcRho scope c1 t mb_ty
       (mb_ct,ty) <- case mb_ct of
@@ -509,7 +550,7 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
                                     return (Just ct,ty)
                       Nothing -> evalError (pp "[list: .. | ..] requires an argument")
       return (Reset ctl mb_ct t qid,ty)
-  | ctl == cList = do
+  | ctl == cList = concreteOnly "Control operators" $ do
       do let (c1,c2) = split c
          mb_ct  <- case mb_ct of
                      Just ct -> do (ct,ty) <- tcRho scope c1 ct Nothing
@@ -519,7 +560,7 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
          case ty of
            VApp c qid [] -> return (Reset ctl mb_ct t (Just qid), ty)
            _             -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty)
-  | ctl == cLen = do
+  | ctl == cLen = concreteOnly "Control operators" $ do
       do let (c1,c2) = split c
          (t,_) <- tcRho scope c1 t Nothing
          case mb_ct of
@@ -530,7 +571,7 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
                          (ct,_) <- tcRho scope c2 ct (Just (VProd Explicit identW vtypeInt res_ty))
                          return (Reset ctl (Just ct) t Nothing, res_ty)
            Nothing -> instSigma scope c2 (Reset ctl Nothing t Nothing) vtypeInt mb_ty
-  | ctl == cConst = do
+  | ctl == cConst = concreteOnly "Control operators" $ do
       let (c1,c2) = split c
       (t,_)      <- tcRho scope c1 t Nothing
       (mb_ct,ty) <- case mb_ct of
@@ -538,8 +579,8 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
                                     return (Just ct,ty)
                       Nothing -> evalError (pp "[list: .. | ..] requires an argument")
       return (Reset ctl mb_ct t qid,ty)
-  | otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
-tcRho scope s (Opts n cs) mb_ty = do
+  | otherwise = concreteOnly "Control operators" $ evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
+tcRho scope s (Opts n cs) mb_ty = concreteOnly "Options" $ do
   let (s1,s2,s3) = split3 s
   (n,_) <- tcRho scope s1 n Nothing
   (ls,_)  <- tcUnifyingMaybe scope s2 (fst <$> cs) Nothing
@@ -547,6 +588,12 @@ tcRho scope s (Opts n cs) mb_ty = do
   return (Opts n (zip ls ts), ty)
 tcRho scope s t _ = unimplemented ("tcRho "++show t)
 
+concreteOnly msg f = do
+  (Gl _ _ isAbstract) <- globals
+  if isAbstract
+    then evalError (pp (msg ++ " are not supported in the abstract syntax"))
+    else f
+
 evalCodomain :: Ident -> Value -> Value -> EvalM Value
 evalCodomain x v (VClosure env c ty) = do
   g <- globals
@@ -594,8 +641,8 @@ tcCases scope c ((p,t):cs) mb_p_ty     mb_res_ty     = do
   return ((p,t):cs,p_ty,res_ty)
 
 tcApp scope c t0 (App fun arg) args mb_ty = tcApp scope c t0 fun (arg:args) mb_ty     -- APP
-tcApp scope c t0 t@(Q id)      args mb_ty = resolveOverloads scope c t0 id args mb_ty -- VAR (global)
-tcApp scope c t0 t@(QC id)     args mb_ty = resolveOverloads scope c t0 id args mb_ty -- VAR (global)
+tcApp scope c t0 t@(Q q)       args mb_ty = resolveOverloads scope c t0 q args mb_ty -- VAR (global)
+tcApp scope c t0 t@(QC q)      args mb_ty = resolveOverloads scope c t0 q args mb_ty -- VAR (global)
 tcApp scope c t0 t             args mb_ty = do
   let (c1,c23) = split c
   let (c2,c3)  = split c23
@@ -626,22 +673,29 @@ reapply1 scope c fun fun_ty (arg:args) = do -- Explicit arg (fallthrough) case
 
 resolveOverloads :: Scope -> Choice -> Term -> QIdent -> [Term] -> Maybe Rho -> EvalM (Term,Rho)
 resolveOverloads scope c t0 q args mb_ty = do
-  g@(Gl gr _) <- globals
-  case lookupOverloadTypes gr q of
-    Bad msg  -> evalError (pp msg)
-    Ok [(t,ty)] -> do let (c1,c23) = split c
-                          (c2,c3)  = split c23
-                      (t,ty) <- reapply1 scope c1 t (eval g [] c2 ty []) args
-                      instSigma scope c3 t ty mb_ty
-    Ok ttys0    -> do let (c1,c23) = split c
-                          (c2,c3)  = split c23
-                      sz <- checkpoint
-                      arg_tys <- mapCM (checkArg g) c1 args
-                      let v_ttys = mapC (\c (t,ty) -> (t,eval g [] c ty [])) c2 ttys0
-                      try sz
-                          (\(fun,fun_ty) -> reapply2 scope c3 fun fun_ty arg_tys mb_ty)
-                          (\ttys -> fmap (\(ts,ty) -> (mkFV ts,ty)) (snd (minimum g ttys0 arg_tys ttys)))
-                          v_ttys
+  g@(Gl gr _ isAbstract) <- globals
+  if isAbstract
+    then case lookupAbsType gr q of
+           Bad msg  -> evalError (pp msg)
+           Ok ty    -> do let (c1,c23) = split c
+                              (c2,c3)  = split c23
+                          (t,ty) <- reapply1 scope c1 t0 (eval g [] c2 ty []) args
+                          instSigma scope c3 t ty mb_ty
+    else case lookupOverloadTypes gr q of
+           Bad msg  -> evalError (pp msg)
+           Ok [(t,ty)] -> do let (c1,c23) = split c
+                                 (c2,c3)  = split c23
+                             (t,ty) <- reapply1 scope c1 t (eval g [] c2 ty []) args
+                             instSigma scope c3 t ty mb_ty
+           Ok ttys0    -> do let (c1,c23) = split c
+                                 (c2,c3)  = split c23
+                             sz <- checkpoint
+                             arg_tys <- mapCM (checkArg g) c1 args
+                             let v_ttys = mapC (\c (t,ty) -> (t,eval g [] c ty [])) c2 ttys0
+                             try sz
+                                 (\(fun,fun_ty) -> reapply2 scope c3 fun fun_ty arg_tys mb_ty)
+                                 (\ttys -> fmap (\(ts,ty) -> (mkFV ts,ty)) (snd (minimum g ttys0 arg_tys ttys)))
+                                 v_ttys
   where
     checkArg g c (ImplArg arg) = do
       let (c1,c2) = split c
@@ -722,8 +776,8 @@ tcPatt scope c (PV x)    Nothing    = do
 tcPatt scope c (PV x)    (Just ty) =
   return ((x,ty):scope,ty)
 tcPatt scope c (PP q ps) mb_ty = do
-  g@(Gl gr _) <- globals
-  ty <- case lookupResType gr q of
+  g@(Gl gr _ isAbstract) <- globals
+  ty <- case (if isAbstract then lookupFunType else lookupResType) gr q of
           Ok ty   -> return ty
           Bad msg -> evalError (pp msg)
   let go scope c ty []     = return (scope,ty)
@@ -839,7 +893,7 @@ tcPatt scope c (PAlt p1 p2) mb_ty = do
   (_,ty) <- tcPatt scope c2 p2 (Just ty)
   return (scope,ty)
 tcPatt scope c (PM q) mb_ty = do
-  g@(Gl gr _) <- globals
+  g@(Gl gr _ _) <- globals
   ty <- case lookupResType gr q of
           Ok ty   -> return ty
           Bad msg -> evalError (pp msg)
@@ -1344,8 +1398,8 @@ unify scope (VStr s1) (VStr s2)
   | s1 == s2                   = return ()
 unify scope VEmpty VEmpty      = return ()
 unify scope v1 v2 =
-  evalError ("Cannot unify:" <+> ppValue Qualified 0 v1 $$
-             "        with:" <+> ppValue Qualified 0 v2)
+  evalError ("Cannot unify:" <+> ppValue Unqualified 0 v1 $$
+             "        with:" <+> ppValue Unqualified 0 v2)
 
 
 -- | Invariant: tv1 is a flexible type variable
diff --git a/src/compiler/api/GF/Compile/TypeCheck/Abstract.hs b/src/compiler/api/GF/Compile/TypeCheck/Abstract.hs
deleted file mode 100644
index c76660259..000000000
--- a/src/compiler/api/GF/Compile/TypeCheck/Abstract.hs
+++ /dev/null
@@ -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!
diff --git a/src/compiler/api/GF/Compile/TypeCheck/TC.hs b/src/compiler/api/GF/Compile/TypeCheck/TC.hs
deleted file mode 100644
index fb9049aaa..000000000
--- a/src/compiler/api/GF/Compile/TypeCheck/TC.hs
+++ /dev/null
@@ -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)
diff --git a/src/compiler/api/GF/Grammar.hs b/src/compiler/api/GF/Grammar.hs
index 9c55dfffc..044e00033 100644
--- a/src/compiler/api/GF/Grammar.hs
+++ b/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
diff --git a/src/compiler/api/GF/Grammar/Lookup.hs b/src/compiler/api/GF/Grammar/Lookup.hs
index 968127fe5..e67a374a3 100644
--- a/src/compiler/api/GF/Grammar/Lookup.hs
+++ b/src/compiler/api/GF/Grammar/Lookup.hs
@@ -26,6 +26,7 @@ module GF.Grammar.Lookup (
            allParamValues,
            countParamValues,
            lookupAbsDef,
+           lookupAbsType,
            lookupLincat,
            lookupFunType,
            lookupCatContext,
@@ -225,12 +226,12 @@ countParamValues gr ptyp =
     -- to normalize records and record types
     sortByLbl = sortBy (\(l1,_,_) (l2,_,_) -> compare l1 l2)
 
-lookupAbsDef :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m (Maybe Int,Maybe [Equation])
-lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
-  info <- lookupQIdentInfo gr (m,c)
+lookupAbsDef :: ErrorMonad m => Grammar -> QIdent -> m (Maybe Int,Maybe [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)
-    AnyInd _ n     -> lookupAbsDef gr n c
+    AnyInd _ n     -> lookupAbsDef gr (n,c)
     _              -> return (Nothing,Nothing)
 
 lookupLincat :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Type
@@ -243,12 +244,29 @@ 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
-lookupFunType gr m c = do
-  info <- lookupQIdentInfo gr (m,c)
+lookupAbsType :: ErrorMonad m => Grammar -> QIdent -> m Type
+lookupAbsType gr q@(m,c)
+  | m == cPredefAbs =
+      if elem c [cInt,cFloat,cString]
+        then return typeType
+        else no_type
+  | otherwise = do
+      info <- lookupQIdentInfo gr q
+      case info of
+        AbsCat (Just (L _ co))      -> return (mkProd co typeType [])
+        AbsFun (Just (L _ t)) _ _ _ -> return 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
-    AnyInd _ n                  -> lookupFunType gr n c
+    AnyInd _ n                  -> lookupFunType gr (n,c)
     _                           -> raise (render ("cannot find type of" <+> c))
 
 -- | this is needed at compile time
diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs
index 0b38ffcda..4f14c6bb4 100644
--- a/src/compiler/api/GF/Grammar/Printer.hs
+++ b/src/compiler/api/GF/Grammar/Printer.hs
@@ -16,9 +16,7 @@ module GF.Grammar.Printer
            , ppParams
            , ppTerm
            , ppPatt
-           , ppValue
            , ppBind
-           , ppConstrs
            , ppQIdent
            , ppMeta
            , ppLVar
@@ -29,7 +27,6 @@ import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 import PGF2(Literal(..),pgfFilePath)
 import GF.Infra.Ident
 import GF.Infra.Option
-import GF.Grammar.Values
 import GF.Grammar.Predef
 import GF.Grammar.Grammar
 
@@ -305,22 +302,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
diff --git a/src/compiler/api/GF/Grammar/Unify.hs b/src/compiler/api/GF/Grammar/Unify.hs
deleted file mode 100644
index 4446cfb32..000000000
--- a/src/compiler/api/GF/Grammar/Unify.hs
+++ /dev/null
@@ -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
diff --git a/src/compiler/api/GF/Grammar/Values.hs b/src/compiler/api/GF/Grammar/Values.hs
deleted file mode 100644
index c8fcb3945..000000000
--- a/src/compiler/api/GF/Grammar/Values.hs
+++ /dev/null
@@ -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
diff --git a/src/compiler/api/GF/Interactive.hs b/src/compiler/api/GF/Interactive.hs
index e6f04309d..18071b16a 100644
--- a/src/compiler/api/GF/Interactive.hs
+++ b/src/compiler/api/GF/Interactive.hs
@@ -13,8 +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.Compute.Concrete(stdPredef,normalForm,Globals(..))
+import GF.Compile.TypeCheck(inferLType)
+import GF.Compile.Compute(stdPredef,normalForm,Globals(..))
 import GF.Compile.GeneratePMCFG(pmcfgForm,type2fields)
 import GF.Data.Operations (Err(..))
 import GF.Data.Utilities(whenM,repeatM)
@@ -315,7 +315,7 @@ 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)
+      let g = Gl sgr (stdPredef g) False
       (t,ty) <- case mb_t of
                   Just t  -> do t <- renameSourceTerm sgr mo (Typed t ty)
                                 
@@ -344,7 +344,7 @@ transactionCommand (CreateLincat opts c mb_t) pgf mb_txnid = do
     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
diff --git a/src/compiler/gf.cabal b/src/compiler/gf.cabal
index 802f58b58..14ba590f3 100644
--- a/src/compiler/gf.cabal
+++ b/src/compiler/gf.cabal
@@ -104,7 +104,7 @@ library
     GF.Command.TreeOperations
     GF.Compile.CFGtoPGF
     GF.Compile.CheckGrammar
-    GF.Compile.Compute.Concrete
+    GF.Compile.Compute
     GF.Compile.ExampleBased
     GF.Compile.Export
     GF.Compile.GenerateBC
@@ -122,9 +122,7 @@ library
     GF.Compile.SubExOpt
     GF.Compile.Tags
     GF.Compile.ToAPI
-    GF.Compile.TypeCheck.Abstract
-    GF.Compile.TypeCheck.Concrete
-    GF.Compile.TypeCheck.TC
+    GF.Compile.TypeCheck
     GF.Compile.Update
     GF.Data.BacktrackM
     GF.Data.Graph
@@ -147,8 +145,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

From 19774ebcd3442719ee6eecc2cee50399ecc6b976 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 5 Feb 2026 14:57:08 +0100
Subject: [PATCH 087/144] remove dead code

---
 src/compiler/api/GF/Grammar/Analyse.hs | 16 +++++-
 src/compiler/api/GF/Grammar/Macros.hs  | 77 --------------------------
 src/compiler/api/GF/Grammar/Predef.hs  | 14 -----
 3 files changed, 14 insertions(+), 93 deletions(-)

diff --git a/src/compiler/api/GF/Grammar/Analyse.hs b/src/compiler/api/GF/Grammar/Analyse.hs
index 4277f9aeb..9a4107fac 100644
--- a/src/compiler/api/GF/Grammar/Analyse.hs
+++ b/src/compiler/api/GF/Grammar/Analyse.hs
@@ -89,7 +89,7 @@ sizeTerm t = case t of
   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
   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 + 
-    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
diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs
index 952ac069b..d6dc80300 100644
--- a/src/compiler/api/GF/Grammar/Macros.hs
+++ b/src/compiler/api/GF/Grammar/Macros.hs
@@ -312,83 +312,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
diff --git a/src/compiler/api/GF/Grammar/Predef.hs b/src/compiler/api/GF/Grammar/Predef.hs
index fd80cc5b6..90062c27a 100644
--- a/src/compiler/api/GF/Grammar/Predef.hs
+++ b/src/compiler/api/GF/Grammar/Predef.hs
@@ -77,17 +77,3 @@ 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"

From b547e398571db358bff8f90a25da46e4b2a0e7cc Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sun, 8 Feb 2026 09:24:14 +0100
Subject: [PATCH 088/144] fix partial evaluations and frozen applications

---
 src/compiler/api/GF/Compile/Compute.hs       | 167 ++++++++++---------
 src/compiler/api/GF/Compile/GeneratePMCFG.hs |  10 +-
 src/compiler/api/GF/Compile/TypeCheck.hs     |  68 +++++---
 src/compiler/api/GF/Grammar/Lookup.hs        |  13 +-
 4 files changed, 145 insertions(+), 113 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute.hs b/src/compiler/api/GF/Compile/Compute.hs
index 719bc5ef5..b5324f68e 100644
--- a/src/compiler/api/GF/Compile/Compute.hs
+++ b/src/compiler/api/GF/Compile/Compute.hs
@@ -5,12 +5,11 @@ module GF.Compile.Compute
             ConstValue(..), Globals(..), PredefTable, EvalM,
             mapVariantsC, unvariants,
             runEvalM, runEvalMWithInput, stdPredef, noPredef, globals,
-            PredefImpl, Predef(..), ($\),
-            pdCanonicalArgs, pdArity,
+            PredefImpl, Predef, 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
@@ -37,23 +36,10 @@ 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 $\
-
-($\) :: (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
+pdArity :: Int -> PredefImpl -> Predef
+pdArity n def = Predef n def
 
 type Env  = [(Ident,Value)]
 type Scope = [(Ident,Value)]
@@ -61,7 +47,9 @@ type PredefTable = Map.Map Ident Predef
 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]
@@ -245,18 +233,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                = let v0 = VApp c q vs
-                                in case lookupAbsDef gr q of
-                                     Ok (Just arity,Just eqs)
-                                       | length vs < arity -> v0
-                                       | otherwise -> patternMatch g c v0 (map (\(ps,t) -> (env,ps,vs,t)) eqs)
-                                     Bad msg -> error msg
+  | 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 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
@@ -274,12 +257,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
-                                        | q == (cPredef,cNonExist)     = VApp c q []
+                                      glue (VApp q [])   v
+                                        | q == (cPredef,cNonExist)     = VApp q []
                                       glue v             VEmpty        = v
                                       glue v             (VC v1 v2)    = VC (glue v v1) v2
-                                      glue v             (VApp c q [])
-                                        | q == (cPredef,cNonExist)     = VApp c q []
+                                      glue v             (VApp 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
@@ -333,45 +316,60 @@ 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 =
   case Map.lookup n pds of
-    Nothing  -> VApp c (cPredef,n) args
-    Just def -> let valueOf (Const res) = res
-                    valueOf (CFV i vs)  = VFV i (fmap valueOf vs)
-                    valueOf (CSusp i k) = VSusp i (valueOf . k) []
-                    valueOf RunTime     = VApp c (cPredef,n) args
-                    valueOf NonExist    = VApp c (cPredef,cNonExist) []
-                in valueOf (runPredef def g c args)
+    Nothing             -> VApp (cPredef,n) args
+    Just (Predef k def) -> case splitAt' k args of
+                             Nothing -> VPAP c (cPredef,n) args
+                             Just (usedArgs, remArgs) ->
+                                apply g (valueOf (def g c usedArgs)) remArgs
+  where
+    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}))
-  ,(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)))
-  ,(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)))
-  ,(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)))
-  ,(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)))
-  ,(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)))
-  ,(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)))
-  ,(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)))
-  ,(cError,  pdArity 1 $\ \g c [v]     -> fmap (VError . pp) (value2string g v))
+  [(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))
+  ,(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)))
+  ,(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)))
+  ,(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)))
+  ,(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)))
+  ,(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)))
+  ,(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)))
+  ,(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))
   ]
   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,Just 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)
+    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 (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)
@@ -384,7 +382,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
@@ -512,8 +512,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 False = VApp poison (cPredef,cPFalse) []
+toPBool True  = VApp (cPredef,cPTrue)  []
+toPBool False = VApp (cPredef,cPFalse) []
 
 occur s1 []          = False
 occur s1 s2@(_:tail) = check s1 s2
@@ -558,11 +558,12 @@ patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
 
     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)
+        (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)
@@ -638,7 +639,7 @@ vtableSelect g v0 ty cs v2 vs =
                               (compute lbls)
             Nothing -> error (show ("Missing value for label" <+> pp lbl $$
                                     "among" <+> hsep (punctuate (pp ',') (map fst as))))
-    value2index (VApp c q args) vty =
+    value2index (VApp q args) vty =
       let (r ,ctxt,cnt ) = getIdxCnt q
       in fmap (\(r', cnt') -> (r+r',cnt)) (compute ctxt args)
       where
@@ -661,7 +662,7 @@ vtableSelect g v0 ty cs v2 vs =
             Bad msg -> error msg
 
         Gl gr _ _ = g
-    value2index (VInt n) (VApp _ c [VInt max])
+    value2index (VInt n) (VApp c [VInt max])
       | Q c == cnPredef cInts         = Const (fromIntegral n,fromIntegral max+1)
     value2index (VFV c vs)        vty = CFV c (fmap (\v -> value2index v vty) vs)
     value2index v vty = RunTime
@@ -823,8 +824,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) =
-  foldM (\t v -> fmap (App t) (value2termM flat xs v)) (if fst q == cPredef then Q q else QC q) vs
+value2termM flat xs (VApp q vs) =
+  foldM (\t v -> fmap (App t) (value2termM flat xs v)) (QC q) vs
+value2termM flat xs (VPAP _ q vs) =
+  foldM (\t v -> fmap (App t) (value2termM flat xs v)) (Q q) vs
+value2termM flat xs (VConst q vs) =
+  foldM (\t v -> fmap (App t) (value2termM flat xs v)) (Q q) vs
 value2termM flat xs (VMeta i vs) = do
   mv <- getMeta i
   case mv of
@@ -1068,8 +1073,21 @@ 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 (VMeta i vs) = prec d 4 (hsep ((if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs))
+ppValue q d (VApp f 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 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 "|]"
@@ -1137,24 +1155,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)
@@ -1195,7 +1213,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))
@@ -1215,9 +1233,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))
 
diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index a6b0f481f..796ebe301 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -255,9 +255,9 @@ force (VSymCat d r rs) = do
     force_ (factor, (v, ty)) = do
       v <- force v
       return (factor, (v, ty))
-force (VApp c q vs) = do
+force (VApp q vs) = do
   vs <- mapM force vs
-  return (VApp c q vs)
+  return (VApp q vs)
 force (VAlts def alts) = do
   def  <- force def
   alts <- mapM force_ alts
@@ -302,7 +302,7 @@ 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) [])
+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])
@@ -383,7 +383,7 @@ param2int subst (VR as) (RecType lbls) = compute subst lbls
                        return (subst,r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
         Nothing  -> compileError ("Missing value for label" <+> pp lbl $$
                                   "among" <+> hsep (punctuate (pp ',') (map fst as)))
-param2int subst (VApp _ q vs) ty = do
+param2int subst (VApp q vs) ty = do
   (      r ,    ctxt,cnt ) <- getIdxCnt q
   (subst,r',rs',     cnt') <- compute subst ctxt vs
   return (subst,r+r',rs',cnt)
@@ -509,7 +509,7 @@ chooseMetaValue s ptyp = GenM $ \g@(Gl gr _ _) k svs ms r ->
     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 poison (mod,id) args) (Map.insert s idx svs) ms' r
+      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,[])
diff --git a/src/compiler/api/GF/Compile/TypeCheck.hs b/src/compiler/api/GF/Compile/TypeCheck.hs
index f325f8c03..9c8a32fe8 100644
--- a/src/compiler/api/GF/Compile/TypeCheck.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck.hs
@@ -108,13 +108,13 @@ inferSigma scope s t = do                                      -- GEN1
   let forall_tvs = res_tvs \\ env_tvs
   quantify scope t forall_tvs ty
 
-vtypeInt   = VApp poison (cPredef,cInt) []
-vtypeFloat = VApp poison (cPredef,cFloat) []
+vtypeInt   = VApp (cPredef,cInt) []
+vtypeFloat = VApp (cPredef,cFloat) []
 vtypeStr   = VSort cStr
 vtypeStrs  = VSort cStrs
 vtypeType  = VSort cType
 vtypePType = VSort cPType
-vtypeMarkup= VApp poison (cPredef,cMarkup) []
+vtypeMarkup= VApp (cPredef,cMarkup) []
 
 tcRho :: Scope -> Choice -> Term -> Maybe Rho -> EvalM (Term, Rho)
 tcRho scope s t@(EInt i)   mb_ty = instSigma scope s t (VInts i True) mb_ty -- INT
@@ -140,7 +140,9 @@ tcRho scope c (Abs bt var body) Nothing = do                   -- ABS1
          in return (Abs bt var body, (VProd bt v arg_ty body_ty))
     else return (Abs bt var body, (VProd bt identW arg_ty body_ty))
   where
-    check m n st (VApp c f vs)     = foldM (check m n) st vs
+    check m n st (VApp   f vs)     = foldM (check m n) st vs
+    check m n st (VPAP c f vs)     = foldM (check m n) st vs
+    check m n st (VConst f vs)     = foldM (check m n) st vs
     check m n st (VMeta i vs)      = do
       state <- getMeta i
       case state of
@@ -535,7 +537,7 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
               Nothing -> do i <- newResiduation scope
                             return (VMeta i [])
       let rec_ty = VRecType [ (ident2label cp1, True, ty)
-                            , (ident2label cp2, True, VApp poison (cPredef,cBool) [])
+                            , (ident2label cp2, True, VApp (cPredef,cBool) [])
                             ] False
       case mb_ct of
         Just ct -> evalError (pp "[filter | ..] cannot take an argument")
@@ -558,8 +560,8 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
                      Nothing -> evalError (pp "[list: .. | ..] requires an argument")
          (t,ty) <- tcRho scope c2 t mb_ty
          case ty of
-           VApp c qid [] -> return (Reset ctl mb_ct t (Just qid), ty)
-           _             -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty)
+           VApp qid [] -> return (Reset ctl mb_ct t (Just qid), ty)
+           _           -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty)
   | ctl == cLen = concreteOnly "Control operators" $ do
       do let (c1,c2) = split c
          (t,_) <- tcRho scope c1 t Nothing
@@ -676,11 +678,11 @@ resolveOverloads scope c t0 q args mb_ty = do
   g@(Gl gr _ isAbstract) <- globals
   if isAbstract
     then case lookupAbsType gr q of
-           Bad msg  -> evalError (pp msg)
-           Ok ty    -> do let (c1,c23) = split c
-                              (c2,c3)  = split c23
-                          (t,ty) <- reapply1 scope c1 t0 (eval g [] c2 ty []) args
-                          instSigma scope c3 t ty mb_ty
+           Bad msg   -> evalError (pp msg)
+           Ok (t,ty) -> do let (c1,c23) = split c
+                               (c2,c3)  = split c23
+                           (t,ty) <- reapply1 scope c1 t (eval g [] c2 ty []) args
+                           instSigma scope c3 t ty mb_ty
     else case lookupOverloadTypes gr q of
            Bad msg  -> evalError (pp msg)
            Ok [(t,ty)] -> do let (c1,c23) = split c
@@ -1034,9 +1036,9 @@ instSigma scope s t ty1 (Just ty2) = do                       -- INST2
 
 -- | Invariant: the second argument is in weak-prenex form
 subsCheckRho :: Scope -> Term -> Sigma -> Rho -> EvalM (Term,Sigma,Rho)
-subsCheckRho scope t ty1@(VApp _ p1 []) ty2                   -- for backwards compatibility
+subsCheckRho scope t ty1@(VApp p1 []) ty2                   -- for backwards compatibility
   | p1 == (cPredef,cErrorType) = return (t,ty1,ty2)
-subsCheckRho scope t ty1 ty2@(VApp _ p2 [])                   -- for backwards compatibility
+subsCheckRho scope t ty1 ty2@(VApp p2 [])                   -- for backwards compatibility
   | p2 == (cPredef,cErrorType) = return (t,ty1,ty2)
 subsCheckRho scope t ty1@(VMeta i vs1) ty2@(VMeta j vs2)
   | i  == j   = do sequence_ (zipWith (unify scope) vs1 vs2)
@@ -1113,9 +1115,9 @@ subsCheckRho scope t (VTable p1 r1) rho2 = do                 -- Rule TABLE
   subsCheckTbl scope t p1 r1 p2 r2
 subsCheckRho scope t ty1@(VSort s1) ty2@(VSort s2)            -- Rule PTYPE
   | s1 == cPType && s2 == cType = return (t,ty1,ty2)
-subsCheckRho scope t ty1@(VApp _ p _) ty2@(VInts _ _)         -- This is not correct but nextPrec in the RGL relies on it.
-  | p == (cPredef,cInt) = return (t,ty1,ty2)                  -- Should be only a temporary hack.
-subsCheckRho scope t ty1@(VInts _ _) ty2@(VApp _ p _)         -- Rule INT1
+subsCheckRho scope t ty1@(VApp p _) ty2@(VInts _ _)         -- This is not correct but nextPrec in the RGL relies on it.
+  | p == (cPredef,cInt) = return (t,ty1,ty2)                -- Should be only a temporary hack.
+subsCheckRho scope t ty1@(VInts _ _) ty2@(VApp p _)         -- Rule INT1
   | p == (cPredef,cInt) = return (t,ty1,ty2)
 subsCheckRho scope t ty1@(VInts n1 ext1) ty2@(VInts n2 ext2)  -- Rule INT2
   | n1 <= n2  = return (t,ty1,ty2)
@@ -1277,9 +1279,9 @@ subtype scope (Just (VProd Explicit x a1 r1)) (VProd Explicit y a2 r2)
        a <- supertype scope (Just a1) a2
        r <- subtype scope (Just r1) r2
        return (VProd Explicit identW a r)
-subtype scope (Just (VApp _ p1 [])) ty2                      -- for backwards compatibility
+subtype scope (Just (VApp p1 [])) ty2                      -- for backwards compatibility
   | p1 == (cPredef,cErrorType) = return ty2
-subtype scope (Just ty1) (VApp _ p2 [])                      -- for backwards compatibility
+subtype scope (Just ty1) (VApp p2 [])                      -- for backwards compatibility
   | p2 == (cPredef,cErrorType) = return ty1
 subtype scope Nothing    ty = return ty
 subtype scope (Just ctr) ty = do
@@ -1311,9 +1313,9 @@ supertype scope (Just (VProd Explicit x a1 r1)) (VProd Explicit y a2 r2)
        a <- subtype scope (Just a1) a2
        r <- supertype scope (Just r1) r2
        return (VProd Explicit identW a r)
-supertype scope (Just (VApp _ p1 [])) ty2                      -- for backwards compatibility
+supertype scope (Just (VApp p1 [])) ty2                      -- for backwards compatibility
   | p1 == (cPredef,cErrorType) = return ty2
-supertype scope (Just ty1) (VApp _ p2 [])                      -- for backwards compatibility
+supertype scope (Just ty1) (VApp p2 [])                      -- for backwards compatibility
   | p2 == (cPredef,cErrorType) = return ty1
 supertype scope Nothing    ty = return ty
 supertype scope (Just ctr) ty = do
@@ -1353,7 +1355,11 @@ unifyTbl scope tau = do
   unify scope tau (VTable arg res)
   return (arg,res)
 
-unify scope (VApp c1 f1 vs1) (VApp c2 f2 vs2)
+unify scope (VApp f1 vs1)    (VApp f2 vs2)
+  | f1 == f2  = sequence_ (zipWith (unify scope) vs1 vs2)
+unify scope (VPAP c1 f1 vs1) (VPAP c2 f2 vs2)
+  | f1 == f2  = sequence_ (zipWith (unify scope) vs1 vs2)
+unify scope (VConst f1 vs1) (VConst f2 vs2)
   | f1 == f2  = sequence_ (zipWith (unify scope) vs1 vs2)
 unify scope (VMeta i vs1) (VMeta j vs2)
   | i  == j   = sequence_ (zipWith (unify scope) vs1 vs2)
@@ -1417,7 +1423,9 @@ occursCheck scope' i0 scope v =
       n = length scope
   in check m n v
   where
-    check m n (VApp c f vs) = mapM_ (check m n) vs
+    check m n (VApp   f vs) = mapM_ (check m n) vs
+    check m n (VPAP c f vs) = mapM_ (check m n) vs
+    check m n (VConst f vs) = mapM_ (check m n) vs
     check m n (VMeta i vs)
       | i0 == i  = do ty1 <- value2termM False (scopeVars scope) (VMeta i vs)
                       ty2 <- value2termM False (scopeVars scope) v
@@ -1526,9 +1534,15 @@ quantify scope t tvs ty = do
   where
     bind scope (i, meta_id, name) = setMeta meta_id (Bound scope (VGen i []))
 
-    check m n xs (VApp c f vs)     = do
+    check m n xs (VApp f vs)     = do
       (xs,vs) <- mapAccumM (check m n) xs vs
-      return (xs,VApp c f vs)
+      return (xs,VApp f vs)
+    check m n xs (VPAP c f vs)     = do
+      (xs,vs) <- mapAccumM (check m n) xs vs
+      return (xs,VPAP c f vs)
+    check m n xs (VConst f vs)     = do
+      (xs,vs) <- mapAccumM (check m n) xs vs
+      return (xs,VConst f vs)
     check m n xs (VMeta i vs)      = do
       s <- getMeta i
       case s of
@@ -1678,7 +1692,9 @@ getMetaVars sc_tys = foldM (\acc (scope,ty) -> go acc ty) [] sc_tys
                                   case res of
                                     Bound _ v -> go acc v
                                     _         -> foldM go (m:acc) args
-    go acc (VApp c f args)   = foldM go acc args
+    go acc (VApp f args)     = foldM go acc args
+    go acc (VPAP c f args)   = foldM go acc args
+    go acc (VConst f args)   = foldM go acc args
     go acc (VFV c vs)        = foldM go acc (unvariants vs)
     go acc (VInts _ _)       = return acc
     go acc (VPattType v)     = go acc v
diff --git a/src/compiler/api/GF/Grammar/Lookup.hs b/src/compiler/api/GF/Grammar/Lookup.hs
index e67a374a3..cd4c0c75e 100644
--- a/src/compiler/api/GF/Grammar/Lookup.hs
+++ b/src/compiler/api/GF/Grammar/Lookup.hs
@@ -244,19 +244,20 @@ lookupLincat gr m c = do
     _                             -> raise (render (c <+> "has no linearization type in" <+> m))
 
 -- | this is needed at compile time
-lookupAbsType :: ErrorMonad m => Grammar -> QIdent -> m Type
+lookupAbsType :: ErrorMonad m => Grammar -> QIdent -> m (Term,Type)
 lookupAbsType gr q@(m,c)
   | m == cPredefAbs =
       if elem c [cInt,cFloat,cString]
-        then return typeType
+        then return (QC q,typeType)
         else no_type
   | otherwise = do
       info <- lookupQIdentInfo gr q
       case info of
-        AbsCat (Just (L _ co))      -> return (mkProd co typeType [])
-        AbsFun (Just (L _ t)) _ _ _ -> return t
-        AnyInd _ n                  -> lookupAbsType gr (n,c)
-        _                           -> no_type
+        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))
 

From 880d3aa76cc74e8ec96b0d4b7367d44f67849513 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sun, 8 Feb 2026 09:41:41 +0100
Subject: [PATCH 089/144] deprecate PW in favour of PV identW

---
 src/compiler/api/GF/Compile/Compute.hs        |  6 ++--
 .../api/GF/Compile/ConcreteToHaskell.hs       |  5 ++--
 src/compiler/api/GF/Compile/GenerateBC.hs     |  5 ++--
 src/compiler/api/GF/Compile/GeneratePMCFG.hs  |  2 +-
 src/compiler/api/GF/Compile/GrammarToPGF.hs   |  1 -
 src/compiler/api/GF/Compile/TypeCheck.hs      | 28 ++++++++++---------
 src/compiler/api/GF/Grammar/Binary.hs         |  2 --
 src/compiler/api/GF/Grammar/Grammar.hs        |  3 +-
 src/compiler/api/GF/Grammar/JSON.hs           |  2 --
 src/compiler/api/GF/Grammar/Parser.y          |  2 +-
 src/compiler/api/GF/Grammar/Printer.hs        |  3 --
 11 files changed, 28 insertions(+), 31 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute.hs b/src/compiler/api/GF/Compile/Compute.hs
index b5324f68e..1063b7903 100644
--- a/src/compiler/api/GF/Compile/Compute.hs
+++ b/src/compiler/api/GF/Compile/Compute.hs
@@ -361,6 +361,7 @@ evalAbsDef g@(Gl gr pds _) c q args =
       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) -> VConst q args
     Bad msg -> error msg
 
 apply g (VMeta i vs0)                   vs  = VMeta i   (vs0++vs)
@@ -550,9 +551,10 @@ patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
                                                  Bad msg -> error msg
                                                where
                                                  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
 
diff --git a/src/compiler/api/GF/Compile/ConcreteToHaskell.hs b/src/compiler/api/GF/Compile/ConcreteToHaskell.hs
index 1a7cb52e5..4c25aacdb 100644
--- a/src/compiler/api/GF/Compile/ConcreteToHaskell.hs
+++ b/src/compiler/api/GF/Compile/ConcreteToHaskell.hs
@@ -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 PW            = WildP
+    convertPatt (PV v)
+      | 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
diff --git a/src/compiler/api/GF/Compile/GenerateBC.hs b/src/compiler/api/GF/Compile/GenerateBC.hs
index e380ac409..0ee39128d 100644
--- a/src/compiler/api/GF/Compile/GenerateBC.hs
+++ b/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, PW       : ps, t):eqs) vrs = whilePV eqs ((      vs,ps,t) : vrs)
+    whilePV ((vs, PV x     : ps, t):eqs) 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
diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index 796ebe301..63641249e 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -169,7 +169,7 @@ type2metaTerm gr d ms s r rs (RecType lbls) params =
   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) [(PW,t)],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
diff --git a/src/compiler/api/GF/Compile/GrammarToPGF.hs b/src/compiler/api/GF/Compile/GrammarToPGF.hs
index e5ab011ac..225affcbf 100644
--- a/src/compiler/api/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/api/GF/Compile/GrammarToPGF.hs
@@ -153,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))
diff --git a/src/compiler/api/GF/Compile/TypeCheck.hs b/src/compiler/api/GF/Compile/TypeCheck.hs
index 9c8a32fe8..af32f34cc 100644
--- a/src/compiler/api/GF/Compile/TypeCheck.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck.hs
@@ -98,7 +98,6 @@ checkDef g q ty (ps,t) = do
                               (scope,arg_ty) <- tcPatt scope c1 p (Just arg_ty)
                               go scope c2 res_ty ps
 
-  -- tcPatt scope c PW        Nothing    = do
 
 inferSigma :: Scope -> Choice -> Term -> EvalM (Term,Sigma)
 inferSigma scope s t = do                                      -- GEN1
@@ -766,17 +765,16 @@ reapply2 scope c fun fun_ty ((arg,arg_v,arg_ty):args) mb_ty = do -- Explicit arg
   res_ty <- evalCodomain x arg_v res_ty
   reapply2 scope c (App fun arg) res_ty args mb_ty
 
-tcPatt scope c PW        Nothing    = do
-  i <- newResiduation scope
-  return (scope,VMeta i [])
-tcPatt scope c PW        (Just ty0) =
-  return (scope,ty0)
 tcPatt scope c (PV x)    Nothing    = do
   i <- newResiduation scope
-  let ty = VMeta i []
-  return ((x,ty):scope,ty)
+  if x == identW
+    then return (scope,VMeta i [])
+    else let ty = VMeta i []
+         in return ((x,ty):scope,ty)
 tcPatt scope c (PV x)    (Just ty) =
-  return ((x,ty):scope,ty)
+  if x == identW
+    then return (scope,ty)
+    else return ((x,ty):scope,ty)
 tcPatt scope c (PP q ps) mb_ty = do
   g@(Gl gr _ isAbstract) <- globals
   ty <- case (if isAbstract then lookupFunType else lookupResType) gr q of
@@ -923,7 +921,8 @@ measurePatt p =
                      return (min,max,PT t p')
     PAs x p    -> do (min,max,p) <- measurePatt p
                      case p of
-                       PW -> return (0,Nothing,PV x)
+                       PV y | y == identW
+                          -> return (0,Nothing,PV x)
                        _  -> return (min,max,PAs x p)
     PImplArg p -> do (min,max,p') <- measurePatt p
                      return (min,max,PImplArg p')
@@ -941,13 +940,16 @@ measurePatt p =
                -> do (min1,max1,p1) <- measurePatt p1
                      (min2,max2,p2) <- measurePatt p2
                      case (p1,p2) of
-                       (PW,        PW        ) -> return (0,Nothing,PW)
+                       (PV x,      PV y      )
+                         | x == identW && y == identW
+                                               -> return (0,Nothing,PV identW)
                        (PString s1,PString s2) -> return (min1+min2,liftM2 (+) max1 max2,PString (s1++s2))
                        _                       -> return (min1+min2,liftM2 (+) max1 max2,PSeq min1 max1 p1 min2 max2 p2)
     PRep _ _ p -> do (minp,maxp,p) <- measurePatt p
                      case p of
-                       PW    -> return (0,Nothing,PW)
-                       PChar -> return (0,Nothing,PW)
+                       PV x | x == identW
+                             -> return (0,Nothing,PV x)
+                       PChar -> return (0,Nothing,PV identW)
                        _     -> return (0,Nothing,PRep minp maxp p)
     PChar      -> return (1,Just 1,p)
     PChars _   -> return (1,Just 1,p)
diff --git a/src/compiler/api/GF/Grammar/Binary.hs b/src/compiler/api/GF/Grammar/Binary.hs
index 128b652f1..017e4e5f9 100644
--- a/src/compiler/api/GF/Grammar/Binary.hs
+++ b/src/compiler/api/GF/Grammar/Binary.hs
@@ -224,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
@@ -246,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)
diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs
index bd0d2bf19..e3188c2ff 100644
--- a/src/compiler/api/GF/Grammar/Grammar.hs
+++ b/src/compiler/api/GF/Grammar/Grammar.hs
@@ -410,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@
- | PW                     -- ^ wild card pattern: @_@
+ | PV Ident               -- ^ variable pattern: @x@ or wild card @_@
  | 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
diff --git a/src/compiler/api/GF/Grammar/JSON.hs b/src/compiler/api/GF/Grammar/JSON.hs
index 65a48e213..e437ec081 100644
--- a/src/compiler/api/GF/Grammar/JSON.hs
+++ b/src/compiler/api/GF/Grammar/JSON.hs
@@ -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
diff --git a/src/compiler/api/GF/Grammar/Parser.y b/src/compiler/api/GF/Grammar/Parser.y
index d8a06351f..cbd248782 100644
--- a/src/compiler/api/GF/Grammar/Parser.y
+++ b/src/compiler/api/GF/Grammar/Parser.y
@@ -536,7 +536,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 }
diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs
index 4f14c6bb4..cdd99fdbb 100644
--- a/src/compiler/api/GF/Grammar/Printer.hs
+++ b/src/compiler/api/GF/Grammar/Printer.hs
@@ -293,7 +293,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
@@ -369,8 +368,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)

From f5fe93450d0f24751a26208b6b9157cc91c91153 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 11 Feb 2026 16:21:47 +0100
Subject: [PATCH 090/144] bugfix after the elimination of PW

---
 src/compiler/api/GF/Compile/Rename.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Compile/Rename.hs b/src/compiler/api/GF/Compile/Rename.hs
index 99e3570ec..e871ea1e6 100644
--- a/src/compiler/api/GF/Compile/Rename.hs
+++ b/src/compiler/api/GF/Compile/Rename.hs
@@ -305,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])

From d03f7239e675ea91f488e585ca7989ce96355987 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 12 Feb 2026 21:41:44 +0100
Subject: [PATCH 091/144] fix compiling PTilde patterns

---
 src/compiler/api/GF/Compile/GenerateBC.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/compiler/api/GF/Compile/GenerateBC.hs b/src/compiler/api/GF/Compile/GenerateBC.hs
index 0ee39128d..833dffdb5 100644
--- a/src/compiler/api/GF/Compile/GenerateBC.hs
+++ b/src/compiler/api/GF/Compile/GenerateBC.hs
@@ -13,7 +13,7 @@ import Data.Maybe(fromMaybe)
 generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [[Instr]]
 generateByteCode gr arity eqs =
   let (bs,instrs) = compileEquations gr arity (arity+1) is 
-                                     (map (\(L _ (ps,t)) -> ([],ps,t)) eqs) 
+                                     (map (\(L _ (ps,t)) -> ([],ps,t)) eqs)
                                      Nothing
                                      [b]
       b = if arity == 0 || null eqs
@@ -53,7 +53,7 @@ compileEquations gr arity st (i:is) eqs       fl bs = whilePP eqs Map.empty
     whilePV ((vs, PV x     : ps, t):eqs) 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, PTilde _ : ps, t):eqs) vrs = whilePV ((vs,ps,t) : eqs) 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
     whilePV eqs                          vrs = let fl1 = Just (st,length bs1)

From 5a2e80e68764493b04d92fa6b42797aed11b286a Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 12 Feb 2026 21:42:02 +0100
Subject: [PATCH 092/144] type checking patterns with dependent types

---
 src/compiler/api/GF/Compile/CheckGrammar.hs |   9 +-
 src/compiler/api/GF/Compile/TypeCheck.hs    | 186 +++++++++++++-------
 2 files changed, 123 insertions(+), 72 deletions(-)

diff --git a/src/compiler/api/GF/Compile/CheckGrammar.hs b/src/compiler/api/GF/Compile/CheckGrammar.hs
index b427ce019..10332a6c2 100644
--- a/src/compiler/api/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/api/GF/Compile/CheckGrammar.hs
@@ -164,10 +164,11 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
       chIn loc "the type of function" $
         checkLType ga typ typeType
       typ <- normalForm ga typ   -- to calculate let definitions
-      case md of
-        Just eqs -> mapM_ (\(L loc eq) -> chIn loc "the definition of function" $
-                                            checkDef ga (fst sm,c) typ eq) eqs
-        Nothing  -> return ()
+      md <- case md of
+              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
+                             return (Just eqs)
+              Nothing  -> return Nothing
       update sm c (AbsFun (Just (L loc typ)) ma md moper)
 
     CncCat mty mdef mref mpr mpmcfg -> do
diff --git a/src/compiler/api/GF/Compile/TypeCheck.hs b/src/compiler/api/GF/Compile/TypeCheck.hs
index af32f34cc..65181b155 100644
--- a/src/compiler/api/GF/Compile/TypeCheck.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck.hs
@@ -12,7 +12,7 @@ module GF.Compile.TypeCheck
 -- 14 September 2011
 
 import Prelude hiding ((<>))
-import GF.Grammar hiding (Env, VGen, VApp, VRecType, ppValue)
+import GF.Grammar
 import GF.Grammar.Lookup
 import GF.Grammar.Predef
 import GF.Grammar.Lockfield
@@ -85,19 +85,15 @@ checkDef g q ty (ps,t) = do
   let (c1,c23) = split unit
       (c2,c3)  = split c23
   res <- runEvalM g $ do
-            (scope,ty) <- go [] c1 (eval g [] c2 ty []) ps
+            (scope,ps,_,ty) <- tcPattApp [] c1 (eval g [] c2 ty []) ps
             (t,_) <- tcRho scope c3 t (Just ty)
+            let xs = scopeVars scope
+            ps <- mapM (zonkPatt xs) ps
+            t  <- zonkTerm xs t
             return (ps,t)
   case res of
     [eq] -> return eq
     _    -> checkError (pp "Encountered variants while type checking")
-  where
-    go scope c ty []     = return (scope,ty)
-    go scope c ty (p:ps) = do (_,_,arg_ty,res_ty) <- unifyFun scope ty
-                              let (c1,c2) = split c
-                              (scope,arg_ty) <- tcPatt scope c1 p (Just arg_ty)
-                              go scope c2 res_ty ps
-
 
 inferSigma :: Scope -> Choice -> Term -> EvalM (Term,Sigma)
 inferSigma scope s t = do                                      -- GEN1
@@ -486,7 +482,7 @@ tcRho scope c t@(EPatt _ _ p) mb_ty = concreteOnly "Patterns" $ do
                                      case ty of
                                        VPattType ty -> return (scope,f,Just ty)
                                        _            -> evalError (ppTerm Unqualified 0 t <+> "must be of pattern type but" <+> ppTerm Unqualified 0 t <+> "is expected")
-  (_,ty) <- tcPatt scope c p mb_ty
+  (_,p,_,ty) <- tcPatt scope c p mb_ty
   (min,max,p) <- measurePatt p
   return (f (EPatt min max p), VPattType ty)
 tcRho scope c (Markup tag attrs children) mb_ty = concreteOnly "Markups" $ do
@@ -635,7 +631,7 @@ tcUnifyingMaybe scope c ts mb_ty = do
 tcCases scope c []         (Just p_ty) (Just res_ty) = return ([],p_ty,res_ty)
 tcCases scope c ((p,t):cs) mb_p_ty     mb_res_ty     = do
   let (c1,c2,c3,c4) = split4 c
-  (scope',p_ty) <- tcPatt scope c1 p mb_p_ty
+  (scope',p,_,p_ty) <- tcPatt scope c1 p mb_p_ty
   (t,res_ty)  <- tcRho scope' c2 t mb_res_ty
   (cs,p_ty,res_ty) <- tcCases scope c3 cs (Just p_ty) (Just res_ty)
   (_,_,p) <- measurePatt p
@@ -657,8 +653,8 @@ reapply1 scope c fun fun_ty ((ImplArg arg):args) = do -- Implicit arg case
   let (c1,c2,c3,c4) = split4 c
   (bt, x, arg_ty, res_ty) <- unifyFun scope fun_ty
   unless (bt == Implicit) $
-     evalError (ppTerm Unqualified 0 (App fun (ImplArg arg)) <+>
-                "is an implicit argument application, but no implicit argument is expected")
+     evalError (ppTerm Unqualified 0 (ImplArg arg) <+>
+                "is an unexpected implicit argument")
   (arg,_) <- tcRho scope c1 arg (Just arg_ty)
   g <- globals
   res_ty <- evalCodomain x (eval g (scopeEnv scope) c2 arg []) res_ty
@@ -765,134 +761,141 @@ reapply2 scope c fun fun_ty ((arg,arg_v,arg_ty):args) mb_ty = do -- Explicit arg
   res_ty <- evalCodomain x arg_v res_ty
   reapply2 scope c (App fun arg) res_ty args mb_ty
 
-tcPatt scope c (PV x)    Nothing    = do
+tcPatt scope c p@(PV x)    Nothing    = do
   i <- newResiduation scope
   if x == identW
-    then return (scope,VMeta i [])
-    else let ty = VMeta i []
-         in return ((x,ty):scope,ty)
-tcPatt scope c (PV x)    (Just ty) =
+    then return (scope,p,Nothing,VMeta i [])
+    else let v  = VGen (length scope) []
+             ty = VMeta i []
+         in return ((x,ty):scope,p,Just v,ty)
+tcPatt scope c p@(PV x)    (Just ty) =
   if x == identW
-    then return (scope,ty)
-    else return ((x,ty):scope,ty)
+    then return (scope,p,Nothing,ty)
+    else let v = VGen (length scope) []
+         in return ((x,ty):scope,p,Just v,ty)
 tcPatt scope c (PP q ps) mb_ty = do
   g@(Gl gr _ isAbstract) <- globals
   ty <- case (if isAbstract then lookupFunType else lookupResType) gr q of
           Ok ty   -> return ty
           Bad msg -> evalError (pp msg)
-  let go scope c ty []     = return (scope,ty)
-      go scope c ty (p:ps) = do (_,_,arg_ty,res_ty) <- unifyFun scope ty
-                                let (c1,c2) = split c
-                                (scope,arg_ty) <- tcPatt scope c1 p (Just arg_ty)
-                                go scope c2 res_ty ps
   let (c1,c2) = split c
-  (scope,res_ty) <- go scope c1 (eval g [] c2 ty []) ps
+  (scope,ps,mb_vs,res_ty) <- tcPattApp scope c1 (eval g [] c2 ty []) ps
   case mb_ty of
     Just ty -> unify scope ty res_ty
     Nothing -> return ()
-  return (scope,res_ty)
+  return (scope,PP q ps,fmap (VApp q) mb_vs,res_ty)
 tcPatt scope c p@(PInt i) mb_ty =
   case mb_ty of
     Just ty0@(VInts n ext)
-       | i <= n    -> return (scope,ty0)
-       | ext       -> return (scope,VInts i ext)
+       | i <= n    -> return (scope,p,Just (VInt i),ty0)
+       | ext       -> return (scope,p,Just (VInt i),VInts i ext)
        | otherwise -> evalError ("Ints" <+> i <+> "is not a subtype of" <+> ppValue Unqualified 0 ty0)
     Just ty0@(VMeta k vs) -> do
        mv <- getMeta k
        case mv of
          Bound scope1 v -> do
            g  <- globals
-           (scope,ty) <- tcPatt scope c p (Just (apply g v vs))
+           (scope,p,mb_v,ty) <- tcPatt scope c p (Just (apply g v vs))
            setMeta k (Bound scope1 ty)
-           return (scope,ty0)
+           return (scope,p,mb_v,ty0)
          Residuation scope1 -> do
            setMeta k (Bound scope1 (VInts i True))
-           return (scope,ty0)
-    Nothing -> return (scope,VInts i True)
+           return (scope,p,Just (VInt i),ty0)
+    Nothing -> return (scope,p,Just (VInt i),VInts i True)
     _ -> evalError (pp "An integer must have an Int or Ints n type")
-tcPatt scope c (PString s) mb_ty = do
+tcPatt scope c p@(PString s) mb_ty = do
   case mb_ty of
     Just ty -> unify scope ty vtypeStr
     Nothing -> return ()
-  return (scope,vtypeStr)
+  return (scope,p,Just (VStr s),vtypeStr)
 tcPatt scope c PChar mb_ty = do
   case mb_ty of
     Just ty -> unify scope ty vtypeStr
     Nothing -> return ()
-  return (scope,vtypeStr)
-tcPatt scope c (PChars cs) mb_ty = do
+  return (scope,PChar,Nothing,vtypeStr)
+tcPatt scope c p@(PChars cs) mb_ty = do
   case mb_ty of
     Just ty -> unify scope ty vtypeStr
     Nothing -> return ()
-  return (scope,vtypeStr)
-tcPatt scope c (PSeq _ _ p1 _ _ p2) mb_ty = do
+  return (scope,p,Nothing,vtypeStr)
+tcPatt scope c (PSeq min1 max1 p1 min2 max2 p2) mb_ty = do
   case mb_ty of
     Just ty -> unify scope ty vtypeStr
     Nothing -> return ()
   let (c1,c2) = split c
-  (scope,_) <- tcPatt scope c1 p1 (Just vtypeStr)
-  (scope,_) <- tcPatt scope c2 p2 (Just vtypeStr)
-  return (scope,vtypeStr)
-tcPatt scope c (PRep _ _ p) mb_ty = do
+  (scope,p1,v1,_) <- tcPatt scope c1 p1 (Just vtypeStr)
+  (scope,p2,v2,_) <- tcPatt scope c2 p2 (Just vtypeStr)
+  return (scope,PSeq min1 max1 p1 min2 max2 p2,liftM2 VGlue v1 v2,vtypeStr)
+tcPatt scope c (PRep min max p') mb_ty = do
   case mb_ty of
     Just ty -> unify scope ty vtypeStr
     Nothing -> return ()
-  tcPatt scope c p (Just vtypeStr)
+  (scope,p',_,ty) <- tcPatt scope c p' (Just vtypeStr)
+  return (scope,PRep min max p',Nothing,ty)
 tcPatt scope c (PAs x p) mb_ty = do
   ty <- case mb_ty of
           Just ty -> return ty
           Nothing -> do i <- newResiduation scope
                         return (VMeta i [])
-  tcPatt ((x,ty):scope) c p (Just ty)
+  let v = VGen (length scope) []
+  (scope,p',mb_v,ty) <- tcPatt ((x,ty):scope) c p (Just ty)
+  return (scope,PAs x p',mb_v `mplus` Just v,ty)
+tcPatt scope c p@(PTilde t) (Just ty) = do
+  i <- newResiduation scope
+  return (scope, p, Just (VMeta i []), ty)
 tcPatt scope c p@(PR rs) mb_ty =
   case mb_ty of
-    Just (VRecType ltys ext) -> check scope c rs ltys ext
+    Just (VRecType ltys ext) -> do
+       (scope,lps,mb_lvs,ty) <- check scope c rs ltys ext
+       return (scope, PR lps, fmap VR mb_lvs, ty)
     Just ty0@(VMeta i vs) -> do
        mv <- getMeta i
        case mv of
          Bound scope1 v ->
               do g <- globals
-                 (scope,ty) <- tcPatt scope c p (Just (apply g v vs))
+                 (scope,p,v,ty) <- tcPatt scope c p (Just (apply g v vs))
                  setMeta i (Bound scope1 ty)
-                 return (scope,ty0)
+                 return (scope,p,v,ty0)
          Residuation scope1 ->
-              do (scope,ltys) <- infer scope c rs
+              do (scope,lps,mb_lvs,ltys) <- infer scope c rs
                  setMeta i (Bound scope1 (VRecType ltys True))
-                 return (scope,ty0)
-    Nothing ->do (scope,ltys) <- infer scope c rs
-                 return (scope,VRecType ltys True)
+                 return (scope,PR lps,fmap VR mb_lvs,ty0)
+    Nothing ->do (scope,lps,mb_lvs,ltys) <- infer scope c rs
+                 return (scope,PR lps,fmap VR mb_lvs,VRecType ltys True)
     _ -> evalError (pp "An record must have an record type")
   where
-    check scope c []         ltys ext = return (scope,VRecType ltys ext)
+    check scope c []         ltys ext = return (scope,[],Just [],VRecType ltys ext)
     check scope c ((l,p):rs) ltys ext =
       case lookup3 l ltys of
         Just ty -> do let (c1,c2) = split c
-                      (scope,ty) <- tcPatt scope c1 p (Just ty)
-                      check scope c2 rs (update3 l True ty ltys) ext
+                      (scope,p,mb_v,ty) <- tcPatt scope c1 p (Just ty)
+                      (scope,lps,mb_lvs,ty) <- check scope c2 rs (update3 l True ty ltys) ext
+                      return (scope,(l,p):lps,liftM2 (\v lvs -> (l,v):lvs) mb_v mb_lvs,ty)
         Nothing
           | ext -> do let (c1,c2) = split c
-                      (scope,ty) <- tcPatt scope c1 p Nothing
-                      check scope c2 rs (ltys++[(l,True,ty)]) ext
+                      (scope,p,mb_v,ty) <- tcPatt scope c1 p Nothing
+                      (scope,lps,mb_lvs,ty) <- check scope c2 rs (ltys++[(l,True,ty)]) ext
+                      return (scope,(l,p):lps,liftM2 (\v lvs -> (l,v):lvs) mb_v mb_lvs,ty)
           | otherwise
                 -> do ty <- value2termM False (scopeVars scope) (VRecType ltys ext)
                       evalError (pp "Label" <+> pp l <+> " is not defined in the type of the pattern:" $$
                                  nest 4 (ppTerm Unqualified 0 ty))
 
-    infer scope c []         = return (scope,[])
+    infer scope c []         = return (scope,[],Just [],[])
     infer scope c ((l,p):rs) = do
       let (c1,c2) = split c
-      (scope,ty) <- tcPatt scope c1 p Nothing
-      (scope,ltys) <- infer scope c2 rs
-      return (scope,(l,True,ty):ltys)
+      (scope,p,mb_v,ty) <- tcPatt scope c1 p Nothing
+      (scope,lps,mb_lvs,ltys) <- infer scope c2 rs
+      return (scope,(l,p):lps,liftM2 (\v lvs -> (l,v):lvs) mb_v mb_lvs,(l,True,ty):ltys)
 tcPatt scope c (PNeg p) mb_ty = do
-  (_,ty) <- tcPatt scope c p mb_ty
-  return (scope, ty)
+  (_,p,_,ty) <- tcPatt scope c p mb_ty
+  return (scope, PNeg p, Nothing, ty)
 tcPatt scope c (PAlt p1 p2) mb_ty = do
   let (c1,c2) = split c
-  (_,ty) <- tcPatt scope c1 p1 mb_ty
-  (_,ty) <- tcPatt scope c2 p2 (Just ty)
-  return (scope,ty)
-tcPatt scope c (PM q) mb_ty = do
+  (_,p1,v1,ty) <- tcPatt scope c1 p1 mb_ty
+  (_,p2,v2,ty) <- tcPatt scope c2 p2 (Just ty)
+  return (scope,PAlt p1 p2,Nothing,ty)
+tcPatt scope c p@(PM q) mb_ty = do
   g@(Gl gr _ _) <- globals
   ty <- case lookupResType gr q of
           Ok ty   -> return ty
@@ -903,10 +906,53 @@ tcPatt scope c (PM q) mb_ty = do
                case mb_ty of
                  Just ty0 -> unify scope ty0 vty
                  Nothing  -> return ()
-               return (scope,vty)
+               return (scope,p,Nothing,vty)
     ty   -> evalError ("Pattern type expected but " <+> pp ty <+> " found.")
 tcPatt scope c p ty = unimplemented ("tcPatt "++show p)
 
+
+tcPattApp scope c ty                            []        = return (scope,[],Just [],ty)
+tcPattApp scope c (VProd Implicit x arg_ty res_ty) (p:ps) = do
+  let (c1,c2) = split c
+  (scope,p,ps,mb_v,arg_ty) <-
+     case p of
+       PImplArg p -> do (scope,p,mb_v,arg_ty) <- tcPatt scope c1 p (Just arg_ty)
+                        return (scope,p,ps,mb_v,arg_ty)
+       _          -> do i <- newResiduation scope
+                        return (scope,PTilde (Meta i),p:ps,Just (VMeta i []),arg_ty)
+  case res_ty of
+    VClosure env c t
+             -> do v <- case mb_v of
+                          Just v -> return v
+                          Nothing -> evalError (pp "Pattern" <+> ppPatt Unqualified 0 p <+> pp "cannot be used width a dependent function")
+                   g <- globals
+                   (scope,ps,mb_vs,res_ty) <- tcPattApp scope c2 (eval g ((x,v):env) c t []) ps
+                   return (scope,PImplArg p:ps,liftM2 (:) mb_v mb_vs,res_ty)
+    res_ty   -> do (scope,ps,mb_vs,res_ty) <- tcPattApp scope c2 res_ty ps
+                   return (scope,PImplArg p:ps,liftM2 (:) mb_v mb_vs,res_ty)
+tcPattApp scope c (VProd Explicit x arg_ty res_ty) (p:ps) = do
+  case p of
+    PImplArg _ ->
+      evalError (ppPatt Unqualified 0 p <+>
+                 "is an unexpected implicit argument")
+    _          -> return ()
+  let (c1,c2) = split c
+  (scope,p,mb_v,arg_ty) <- tcPatt scope c1 p (Just arg_ty)
+  case res_ty of
+    VClosure env c t
+             -> do v <- case mb_v of
+                          Just v -> return v
+                          Nothing -> evalError (pp "Pattern" <+> ppPatt Unqualified 0 p <+> pp "cannot be used width a dependent function")
+                   g <- globals
+                   (scope,ps,mb_vs,res_ty) <- tcPattApp scope c2 (eval g ((x,v):env) c t []) ps
+                   return (scope,p:ps,liftM2 (:) mb_v mb_vs,res_ty)
+    res_ty   -> do (scope,ps,mb_vs,res_ty) <- tcPattApp scope c2 res_ty ps
+                   return (scope,p:ps,liftM2 (:) mb_v mb_vs,res_ty)
+tcPattApp scope c ty ps =
+  evalError ("Cannot check patterns" <+> hsep (map (ppPatt Unqualified 10) ps) $$
+             "against type" <+> ppValue Unqualified 0 ty)
+
+
 measurePatt p =
   case p of
     PM q       -> do g <- globals
@@ -1721,6 +1767,10 @@ zonkTerm xs (Meta i) = do
     _         -> return (Meta i)
 zonkTerm xs t = composOp (zonkTerm xs) t
 
+zonkPatt :: [Ident] -> Patt -> EvalM Patt
+zonkPatt xs (PTilde t) = fmap PTilde (zonkTerm xs t)
+zonkPatt xs p          = composPattOp (zonkPatt xs) p
+
 zonkValue :: Value -> EvalM Value
 zonkValue (VProd bt x ty1 ty2) = do
   ty1 <- zonkValue ty1

From 14b4e82067bc933c9eb91fbf04009d6d432dc124 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 12 Feb 2026 22:21:06 +0100
Subject: [PATCH 093/144] added renaming of PImplArg

---
 src/compiler/api/GF/Compile/Rename.hs | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/src/compiler/api/GF/Compile/Rename.hs b/src/compiler/api/GF/Compile/Rename.hs
index e871ea1e6..e9933a05e 100644
--- a/src/compiler/api/GF/Compile/Rename.hs
+++ b/src/compiler/api/GF/Compile/Rename.hs
@@ -340,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

From 3f35d779f1ec1f7cc301a450f8d9ed8fce24e408 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 13 Feb 2026 12:23:14 +0100
Subject: [PATCH 094/144] the type checker may change the arity of an equation,
 so we handle it differently

---
 src/compiler/api/GF/Compile/CheckGrammar.hs   | 19 +++++++++-----
 src/compiler/api/GF/Compile/Compute.hs        |  4 +--
 src/compiler/api/GF/Compile/GenerateBC.hs     |  6 ++---
 src/compiler/api/GF/Compile/GrammarToPGF.hs   | 19 +++++++-------
 src/compiler/api/GF/Compile/Rename.hs         |  4 +--
 src/compiler/api/GF/Compile/Tags.hs           |  4 +--
 src/compiler/api/GF/Compile/Update.hs         | 19 ++++++--------
 src/compiler/api/GF/Grammar/Analyse.hs        |  6 ++---
 src/compiler/api/GF/Grammar/Binary.hs         |  4 +--
 src/compiler/api/GF/Grammar/Grammar.hs        |  4 +--
 src/compiler/api/GF/Grammar/JSON.hs           |  6 ++---
 src/compiler/api/GF/Grammar/Lookup.hs         | 26 +++++++++----------
 src/compiler/api/GF/Grammar/Macros.hs         |  2 +-
 src/compiler/api/GF/Grammar/Parser.y          | 22 +++++++---------
 src/compiler/api/GF/Grammar/Printer.hs        |  7 +++--
 .../api/GF/Server/SimpleEditor/Convert.hs     |  4 +--
 16 files changed, 77 insertions(+), 79 deletions(-)

diff --git a/src/compiler/api/GF/Compile/CheckGrammar.hs b/src/compiler/api/GF/Compile/CheckGrammar.hs
index 10332a6c2..bb1f7b707 100644
--- a/src/compiler/api/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/api/GF/Compile/CheckGrammar.hs
@@ -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")
@@ -160,16 +160,23 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
         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
       chIn loc "the type of function" $
         checkLType ga typ typeType
       typ <- normalForm ga typ   -- to calculate let definitions
       md <- case md of
-              Just eqs -> do eqs <- mapM (\(L loc eq) -> chIn loc "the definition of function" $
+              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
-                             return (Just 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)) ma md moper)
+      update sm c (AbsFun (Just (L loc typ)) md)
 
     CncCat mty mdef mref mpr mpmcfg -> do
       mty  <- case mty of
diff --git a/src/compiler/api/GF/Compile/Compute.hs b/src/compiler/api/GF/Compile/Compute.hs
index 1063b7903..88d025c53 100644
--- a/src/compiler/api/GF/Compile/Compute.hs
+++ b/src/compiler/api/GF/Compile/Compute.hs
@@ -357,11 +357,11 @@ stdPredef g = Map.fromList
 evalAbsDef :: Globals -> Choice -> QIdent -> [Value] -> Value
 evalAbsDef g@(Gl gr pds _) c q args =
   case lookupAbsDef gr q of
-    Ok (Just arity,Just eqs) ->
+    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) -> VConst q args
+    Ok Nothing -> VConst q args
     Bad msg -> error msg
 
 apply g (VMeta i vs0)                   vs  = VMeta i   (vs0++vs)
diff --git a/src/compiler/api/GF/Compile/GenerateBC.hs b/src/compiler/api/GF/Compile/GenerateBC.hs
index 833dffdb5..db84037b9 100644
--- a/src/compiler/api/GF/Compile/GenerateBC.hs
+++ b/src/compiler/api/GF/Compile/GenerateBC.hs
@@ -53,7 +53,7 @@ compileEquations gr arity st (i:is) eqs       fl bs = whilePP eqs Map.empty
     whilePV ((vs, PV x     : ps, t):eqs) 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 ((vs,ps,t) : eqs) 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
     whilePV eqs                          vrs = let fl1 = Just (st,length bs1)
@@ -104,7 +104,7 @@ compileFun gr eval st vs (App e1 e2) h0 bs args =
   in (h2,bs2,is1++is2)
 compileFun gr eval st vs (Q q@(m,id))  h0 bs args =
   case lookupAbsDef gr q of
-    Ok (_,Just _)
+    Ok (Just _)
        -> (h0,bs,eval st (GLOBAL (showIdent id)) args)
     _  -> let Ok ty = lookupFunType gr q
               (ctxt,_,_) = typeForm ty
@@ -167,7 +167,7 @@ compileFun gr eval st vs e _ _ _ = error (show e)
 
 compileArg gr st vs (Q q@(m,id)) h0 bs =
   case lookupAbsDef gr q of
-    Ok (_,Just _) -> (h0,bs,GLOBAL (showIdent id),[])
+    Ok (Just _)   -> (h0,bs,GLOBAL (showIdent id),[])
     _             -> let Ok ty = lookupFunType gr q
                          (ctxt,_,_) = typeForm ty
                          c_arity    = length ctxt
diff --git a/src/compiler/api/GF/Compile/GrammarToPGF.hs b/src/compiler/api/GF/Compile/GrammarToPGF.hs
index 225affcbf..0eb3ee2e3 100644
--- a/src/compiler/api/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/api/GF/Compile/GrammarToPGF.hs
@@ -82,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,
-                               let arity = mkArity ma mdef ty,
-                               let bcode = mkDef gr arity mdef,
+                               ((m,f),AbsFun (Just (L _ ty)) mdef) <- adefs,
+                               let arity = mkArity mdef ty,
+                               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
@@ -167,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 arity Nothing    = []
+mkDef gr (Just (arity,eqs)) = generateByteCode gr arity eqs
+mkDef gr Nothing    = []
 
-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
-                               in length ctxt
+mkArity (Just (a,_)) ty = a   -- known arity, i.e. defined function
+mkArity Nothing      ty = let (ctxt, _, _) = GM.typeForm ty  -- constructor
+                          in length ctxt
 {-
 genCncCats gr am cm cdefs = mkCncCats 0 cdefs
   where
diff --git a/src/compiler/api/GF/Compile/Rename.hs b/src/compiler/api/GF/Compile/Rename.hs
index e9933a05e..a4e908e06 100644
--- a/src/compiler/api/GF/Compile/Rename.hs
+++ b/src/compiler/api/GF/Compile/Rename.hs
@@ -106,7 +106,7 @@ renameIdentTerm' env@(act,imps) t0 =
 info2status :: Maybe ModuleName -> Ident -> Info -> Term
 info2status mq c i = case i of
   AbsCat _ -> maybe Con (curry QC) mq c
-  AbsFun _ _ Nothing _ -> 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
diff --git a/src/compiler/api/GF/Compile/Tags.hs b/src/compiler/api/GF/Compile/Tags.hs
index 8b2e2c312..db3323a8e 100644
--- a/src/compiler/api/GF/Compile/Tags.hs
+++ b/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 ++
-                                                  maybe (list (loc "def"))   mb_eqs  
+    getLocations (AbsFun mb_type mb_eqs)        = maybe (ltype "fun")        mb_type ++
+                                                  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 ++
diff --git a/src/compiler/api/GF/Compile/Update.hs b/src/compiler/api/GF/Compile/Update.hs
index 9355c3bf2..b29fde5f9 100644
--- a/src/compiler/api/GF/Compile/Update.hs
+++ b/src/compiler/api/GF/Compile/Update.hs
@@ -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) ->
-    liftM4 AbsFun (unifyMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifyMaybe moper1 moper2) -- adding defs
+  (AbsFun mt1 md1, AbsFun mt2 md2) ->
+    liftM2 AbsFun (unifyMaybeL mt1 mt2) (unifAbsDefs md1 md2) -- adding defs
 
   (ResParam mt1 mv1, ResParam mt2 mv2) ->
     liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
@@ -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)
-unifAbsArrity = unifyMaybe
-
-unifAbsDefs :: Maybe [L Equation] -> Maybe [L Equation] -> Err (Maybe [L Equation])
-unifAbsDefs (Just xs) (Just ys) = return (Just (xs ++ ys))
-unifAbsDefs Nothing   Nothing   = return Nothing
-unifAbsDefs _         _         = fail ""
+unifAbsDefs :: Maybe (Int,[L Equation]) -> Maybe (Int,[L Equation]) -> Err (Maybe (Int,[L Equation]))
+unifAbsDefs (Just (_,xs)) (Just (_,ys)) = return (Just (0,xs ++ ys))
+unifAbsDefs Nothing       Nothing       = return Nothing
+unifAbsDefs _             _             = fail ""
diff --git a/src/compiler/api/GF/Grammar/Analyse.hs b/src/compiler/api/GF/Grammar/Analyse.hs
index 9a4107fac..29a054748 100644
--- a/src/compiler/api/GF/Grammar/Analyse.hs
+++ b/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
@@ -116,8 +116,8 @@ sizePatt p = case p of
 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 + 
-    sum [sum (map sizePatt ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es]
+  AbsFun mt me -> 1 + msize mt + 
+    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
diff --git a/src/compiler/api/GF/Grammar/Binary.hs b/src/compiler/api/GF/Grammar/Binary.hs
index 017e4e5f9..83e17ff29 100644
--- a/src/compiler/api/GF/Grammar/Binary.hs
+++ b/src/compiler/api/GF/Grammar/Binary.hs
@@ -105,7 +105,7 @@ instance Binary Rule where
 
 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)
@@ -116,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)
diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs
index e3188c2ff..29eae938f 100644
--- a/src/compiler/api/GF/Grammar/Grammar.hs
+++ b/src/compiler/api/GF/Grammar/Grammar.hs
@@ -323,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
- | AbsFun   (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) (Maybe Bool) -- ^ (/ABS/) type, arrity and definition of a function
+   AbsCat   (Maybe (L Context))                         -- ^ (/ABS/) context of a category
+ | 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
diff --git a/src/compiler/api/GF/Grammar/JSON.hs b/src/compiler/api/GF/Grammar/JSON.hs
index e437ec081..fe6b657d3 100644
--- a/src/compiler/api/GF/Grammar/JSON.hs
+++ b/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 (\eqs -> ("equations",showJSON (map (\(L _ eq) -> equation2json eq) eqs))) mb_eqs
+     , fmap (\(a,_)   -> ("arity",showJSON a)) mb_eqs
+     , fmap (\(_,eqs) -> ("equations",showJSON (map (\(L _ eq) -> equation2json eq) eqs))) mb_eqs
      ]
 info2json (ResParam mb_params _) =
   makeObj [("params", case mb_params of
diff --git a/src/compiler/api/GF/Grammar/Lookup.hs b/src/compiler/api/GF/Grammar/Lookup.hs
index cd4c0c75e..a95471b56 100644
--- a/src/compiler/api/GF/Grammar/Lookup.hs
+++ b/src/compiler/api/GF/Grammar/Lookup.hs
@@ -226,13 +226,13 @@ countParamValues gr ptyp =
     -- to normalize records and record types
     sortByLbl = sortBy (\(l1,_,_) (l2,_,_) -> compare l1 l2)
 
-lookupAbsDef :: ErrorMonad m => Grammar -> QIdent -> m (Maybe Int,Maybe [Equation])
+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)
-    AnyInd _ n     -> lookupAbsDef gr (n,c)
-    _              -> return (Nothing,Nothing)
+    AbsFun a d -> return (fmap (\(a,eqs) -> (a,map unLoc eqs)) d)
+    AnyInd _ n -> lookupAbsDef gr (n,c)
+    _          -> return Nothing
 
 lookupLincat :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Type
 lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
@@ -253,11 +253,11 @@ lookupAbsType gr q@(m,c)
   | 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
+        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))
 
@@ -266,9 +266,9 @@ 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
-    AnyInd _ n                  -> lookupFunType gr (n,c)
-    _                           -> raise (render ("cannot find type of" <+> c))
+    AbsFun (Just (L _ t)) _ -> return t
+    AnyInd _ n              -> lookupFunType gr (n,c)
+    _                       -> raise (render ("cannot find type of" <+> c))
 
 -- | this is needed at compile time
 lookupCatContext :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Context
@@ -292,7 +292,7 @@ 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]
diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs
index d6dc80300..d8e2baa87 100644
--- a/src/compiler/api/GF/Grammar/Macros.hs
+++ b/src/compiler/api/GF/Grammar/Macros.hs
@@ -480,7 +480,7 @@ allDependencies ism b =
       ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
       CncCat pty _ _ _ _ -> [pty]
       CncFun _   pt _ _ -> [pt]  ---- (Maybe (Ident,(Context,Type))
-      AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual
+      AbsFun pty ptr -> [pty] --- ptr is def, which can be mutual
       AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co]
       _              -> []
 
diff --git a/src/compiler/api/GF/Grammar/Parser.y b/src/compiler/api/GF/Grammar/Parser.y
index cbd248782..373d19ccd 100644
--- a/src/compiler/api/GF/Grammar/Parser.y
+++ b/src/compiler/api/GF/Grammar/Parser.y
@@ -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 LhsName ListPatt '=' Exp    Posn { [($2,AbsFun Nothing (Just (length $3)) (Just [mkL $1 $6 ($3,$5)]) Nothing)] }
+  : Posn LhsNames '=' Exp            Posn { [(f, AbsFun Nothing (Just (0,[mkL $1 $5 ([],$4)]))) | f <- $2] }
+  | 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] }
-  | Posn ListIdent ':' Exp Posn        { -- (snd (valCat $4), AbsCat Nothing) :
-                                         [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing Nothing (Just True)) | fun <- $2] }                                         
+                                         [(fun, AbsFun Nothing Nothing) | fun <- $4] }
+  | Posn ListIdent ':' Exp Posn        { [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing) | fun <- $2] }
 
 ParamDef :: { [(Ident,Info)] }
 ParamDef
@@ -797,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))
-    consfund = (consId, AbsFun (Just (L loc constyp)) Nothing Nothing (Just True))
+    nilfund  = (baseId, AbsFun (Just (L loc niltyp))  Nothing)
+    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'
@@ -854,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
@@ -880,9 +879,6 @@ checkInfoType mt jment@(id,info) =
     ifResource MTInterface    locs = return jment
     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
diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs
index cdd99fdbb..5d15c3720 100644
--- a/src/compiler/api/GF/Grammar/Printer.hs
+++ b/src/compiler/api/GF/Grammar/Printer.hs
@@ -93,17 +93,16 @@ ppJudgement q (id, AbsCat pcont ) =
   (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 eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
+     Just (_,[])  -> empty
+     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 <+>
diff --git a/src/compiler/api/GF/Server/SimpleEditor/Convert.hs b/src/compiler/api/GF/Server/SimpleEditor/Convert.hs
index 04b8f8876..48e40edd7 100644
--- a/src/compiler/api/GF/Server/SimpleEditor/Convert.hs
+++ b/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

From ba29bca7307e29353ed0fe539534cd40ddebedfe Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 13 Feb 2026 13:21:07 +0100
Subject: [PATCH 095/144] store the updated/checked type for all abstract
 functions

---
 src/compiler/api/GF/Compile/CheckGrammar.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/compiler/api/GF/Compile/CheckGrammar.hs b/src/compiler/api/GF/Compile/CheckGrammar.hs
index bb1f7b707..719f541eb 100644
--- a/src/compiler/api/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/api/GF/Compile/CheckGrammar.hs
@@ -161,8 +161,8 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
         update sm c (AbsCat (Just (L loc cont)))
 
     AbsFun (Just (L loc typ)) md -> do
-      chIn loc "the type of function" $
-        checkLType ga typ typeType
+      (typ,_) <- chIn loc "the type of function" $
+                   checkLType ga typ typeType
       typ <- normalForm ga typ   -- to calculate let definitions
       md <- case md of
               Just (_,eqs) -> do eqs <- mapM (\(L loc eq) -> chIn loc "the definition of function" $

From a86485f87349309bdc959cb85718f86fd461a70c Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 13 Feb 2026 15:24:10 +0100
Subject: [PATCH 096/144] fix pretty printing for dependent categories

---
 src/compiler/api/GF/Grammar/Printer.hs | 14 +++++---------
 1 file changed, 5 insertions(+), 9 deletions(-)

diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs
index 5d15c3720..88754abd0 100644
--- a/src/compiler/api/GF/Grammar/Printer.hs
+++ b/src/compiler/api/GF/Grammar/Printer.hs
@@ -88,7 +88,7 @@ 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)
@@ -307,13 +307,9 @@ str s = doubleQuotes (pp (foldr showLitChar "" s))
       | c > '\DEL'  = showChar c
       | otherwise   = GHC.Show.showLitChar c
 
-ppDecl q (_,id,typ)
-  | id == identW = ppTerm q 3 typ
-  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
-
-ppDDecl q (_,id,typ)
-  | id == identW = ppTerm q 6 typ
-  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
+ppDecl q (bt,id,typ)
+  | id == identW = ppTerm q 5 typ
+  | otherwise    = parens (ppBind (bt,id) <+> ':' <+> ppTerm q 0 typ)
 
 ppQIdent :: TermPrintQual -> QIdent -> Doc
 ppQIdent q (m,id) =
@@ -341,7 +337,7 @@ 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

From 51896135c4c9968b315a2ef635ba6a1d8d27a000 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 13 Feb 2026 15:41:05 +0100
Subject: [PATCH 097/144] zonk the term in checkContext

---
 src/compiler/api/GF/Compile/TypeCheck.hs | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/compiler/api/GF/Compile/TypeCheck.hs b/src/compiler/api/GF/Compile/TypeCheck.hs
index 65181b155..9f5e7ad1c 100644
--- a/src/compiler/api/GF/Compile/TypeCheck.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck.hs
@@ -76,6 +76,7 @@ checkContext g ctxt = do
       let (c1,c23) = split c
           (c2,c3)  = split c23
       (ty,_) <- tcRho scope c1 ty (Just vtypeType)
+      ty <- zonkTerm (scopeVars scope) ty
       g <- globals
       ctxt <- check ((x,eval g (scopeEnv scope) c2 ty []):scope) c3 ctxt
       return ((bt,x,ty):ctxt)

From c8f34ff9e295af943419d2fb7983a3e036e5fd8c Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 13 Feb 2026 15:57:30 +0100
Subject: [PATCH 098/144] value2termM now restores implicit arguments

---
 src/compiler/api/GF/Compile/Compute.hs | 20 ++++++++++++++++----
 1 file changed, 16 insertions(+), 4 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute.hs b/src/compiler/api/GF/Compile/Compute.hs
index 88d025c53..6d689ea72 100644
--- a/src/compiler/api/GF/Compile/Compute.hs
+++ b/src/compiler/api/GF/Compile/Compute.hs
@@ -16,7 +16,7 @@ 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(lookupAbsDef,lookupResDef,lookupOrigInfo)
+import GF.Grammar.Lookup
 import GF.Grammar.Grammar
 import GF.Grammar.Macros
 import GF.Grammar.Predef
@@ -827,11 +827,11 @@ setMeta i ms = EvalM (\g k (State input choices metas opts) r msgs ->
 
 value2termM :: Bool -> [Ident] -> Value -> EvalM Term
 value2termM flat xs (VApp q vs) =
-  foldM (\t v -> fmap (App t) (value2termM flat xs v)) (QC q) vs
+  vapp2termM flat xs q (QC q) vs
 value2termM flat xs (VPAP _ q vs) =
-  foldM (\t v -> fmap (App t) (value2termM flat xs v)) (Q q) vs
+  vapp2termM flat xs q (Q q) vs
 value2termM flat xs (VConst q vs) =
-  foldM (\t v -> fmap (App t) (value2termM flat xs v)) (Q q) vs
+  vapp2termM flat xs q (Q q) vs
 value2termM flat xs (VMeta i vs) = do
   mv <- getMeta i
   case mv of
@@ -1061,6 +1061,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

From c2aa109cd9dfb1fbe0e0b39f1ea6faa8137c66f2 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sat, 14 Feb 2026 18:34:07 +0100
Subject: [PATCH 099/144] a bit better but not perfect dependency checker

---
 src/compiler/api/GF/Grammar/Macros.hs | 21 ++++++++++++---------
 1 file changed, 12 insertions(+), 9 deletions(-)

diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs
index d8e2baa87..c03adfe7e 100644
--- a/src/compiler/api/GF/Grammar/Macros.hs
+++ b/src/compiler/api/GF/Grammar/Macros.hs
@@ -30,6 +30,7 @@ import qualified Data.Traversable as T(mapM)
 import qualified Data.Map as Map
 import Control.Monad (liftM, liftM2, liftM3, forM)
 import Data.List (nub)
+import Data.Maybe (fromMaybe)
 import Data.Monoid
 import Data.Graph
 import GF.Text.Pretty(render,(<+>),($$),hsep,fsep,vcat,nest)
@@ -457,7 +458,7 @@ changeTableType co i = case i of
 
 allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,Info,[Ident])]
 allDependencies ism b =
-  [(f, i, 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]
@@ -467,6 +468,8 @@ allDependencies ism b =
       _ -> collectOp opersIn 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
@@ -474,14 +477,14 @@ allDependencies ism b =
     opty (Just (L _ ty)) = opersIn ty
     opty _ = []
 
-    pts i = case i of
-      ResOper pty pt -> [pty,pt]
-      ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
-      ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
-      CncCat pty _ _ _ _ -> [pty]
-      CncFun _   pt _ _ -> [pt]  ---- (Maybe (Ident,(Context,Type))
-      AbsFun pty ptr -> [pty] --- ptr is def, which can be mutual
-      AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co]
+    deps i = case i of
+      ResOper pty pt -> opty pty ++ opty pt
+      ResOverload _ tyts -> concat [opersIn ty ++ opersIn tr | (L _ ty,L _ tr) <- tyts]
+      ResParam (Just (L loc ps)) _ -> concat [opersIn  t | (_,cont) <- ps, (_,_,t) <- cont]
+      CncCat pty _ _ _ _ -> opty pty
+      CncFun _   pt _ _ -> opty pt
+      AbsFun pty peqs -> opty pty ++ [c | L _ (ps,t) <- maybe [] snd peqs, c <- concatMap opersInPatt ps]
+      AbsCat (Just (L loc co)) -> concat [opersIn ty | (_,_,ty) <- co]
       _              -> []
 
 topoSortJments :: ErrorMonad m => SourceModule -> m [(Ident,Info)]

From 33f1670fe9a004c9565515cac8553c857b1a060e Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sat, 14 Feb 2026 19:24:12 +0100
Subject: [PATCH 100/144] avoid potential clashes when allocating expressions

---
 src/runtime/c/pgf/expr.cxx | 21 ++++++++++++++-------
 1 file changed, 14 insertions(+), 7 deletions(-)

diff --git a/src/runtime/c/pgf/expr.cxx b/src/runtime/c/pgf/expr.cxx
index 2827b3bf6..4ea5851d8 100644
--- a/src/runtime/c/pgf/expr.cxx
+++ b/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->arg = m->match_expr(this, arg);
+    eapp->fun = fun;
+	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->type = m->match_type(this, ty);
+    etyped->expr = expr;
+    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();
 }
 

From c9145d854b31b48e4f699321148ce07564f46372 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 19 Feb 2026 15:40:01 +0100
Subject: [PATCH 101/144] started working on a termination checker

---
 .../api/GF/Compile/TerminationCheck.hs        | 71 +++++++++++++++++++
 src/compiler/gf.cabal                         |  1 +
 2 files changed, 72 insertions(+)
 create mode 100644 src/compiler/api/GF/Compile/TerminationCheck.hs

diff --git a/src/compiler/api/GF/Compile/TerminationCheck.hs b/src/compiler/api/GF/Compile/TerminationCheck.hs
new file mode 100644
index 000000000..07de1991a
--- /dev/null
+++ b/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
diff --git a/src/compiler/gf.cabal b/src/compiler/gf.cabal
index 14ba590f3..db3e9c6ae 100644
--- a/src/compiler/gf.cabal
+++ b/src/compiler/gf.cabal
@@ -123,6 +123,7 @@ library
     GF.Compile.Tags
     GF.Compile.ToAPI
     GF.Compile.TypeCheck
+    GF.Compile.TerminationCheck
     GF.Compile.Update
     GF.Data.BacktrackM
     GF.Data.Graph

From a4ac066326f532ba95447ed8b29678cf064affea Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 20 Feb 2026 13:54:32 +0100
Subject: [PATCH 102/144] VConst -> VApp

---
 src/compiler/api/GF/Compile/Compute.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/compiler/api/GF/Compile/Compute.hs b/src/compiler/api/GF/Compile/Compute.hs
index 6d689ea72..9689b24a4 100644
--- a/src/compiler/api/GF/Compile/Compute.hs
+++ b/src/compiler/api/GF/Compile/Compute.hs
@@ -2,7 +2,7 @@
 
 module GF.Compile.Compute
            (Env, Scope, Value(..), Variants(..), OptionInfo(..),
-            ConstValue(..), Globals(..), PredefTable, EvalM,
+            ConstValue(..), Globals(..), PredefTable, EvalM(..),
             mapVariantsC, unvariants,
             runEvalM, runEvalMWithInput, stdPredef, noPredef, globals,
             PredefImpl, Predef, pdArity,
@@ -361,7 +361,7 @@ evalAbsDef g@(Gl gr pds _) c q args =
       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 -> VConst q args
+    Ok Nothing -> VApp q args
     Bad msg -> error msg
 
 apply g (VMeta i vs0)                   vs  = VMeta i   (vs0++vs)

From f52cf67d04f610ac85fb2291d49fd12c916da959 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 3 Apr 2026 17:25:01 +0200
Subject: [PATCH 103/144] propagate error

---
 src/compiler/api/GF/Compile/Compute.hs | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/src/compiler/api/GF/Compile/Compute.hs b/src/compiler/api/GF/Compile/Compute.hs
index 9689b24a4..42afe322e 100644
--- a/src/compiler/api/GF/Compile/Compute.hs
+++ b/src/compiler/api/GF/Compile/Compute.hs
@@ -190,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
@@ -223,6 +224,7 @@ eval g env s (S t1 t2)      vs  = let (!s1,!s2) = split s
                                       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

From 6eb01219f98012089afe1d699be139d0e379b5ba Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sat, 4 Apr 2026 00:34:19 +0200
Subject: [PATCH 104/144] more cases where errors must be propagated

---
 src/compiler/api/GF/Compile/Compute.hs | 7 +++++++
 1 file changed, 7 insertions(+)

diff --git a/src/compiler/api/GF/Compile/Compute.hs b/src/compiler/api/GF/Compile/Compute.hs
index 42afe322e..2c625eeb1 100644
--- a/src/compiler/api/GF/Compile/Compute.hs
+++ b/src/compiler/api/GF/Compile/Compute.hs
@@ -203,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 [])
@@ -252,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 [])
@@ -275,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)
@@ -377,6 +383,7 @@ 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

From 491a979c196279143054a6fc3ac838bf573e6787 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 14 Apr 2026 11:30:08 +0200
Subject: [PATCH 105/144] propagate and handle errors

---
 src/compiler/api/GF/Compile/GeneratePMCFG.hs | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index 63641249e..4c1cd86da 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -210,6 +210,7 @@ breakDown g ms s r rs v (RecType lbls) fn0 fn = traverse ms r rs lbls fn0 fn
         project (VFV c fvs)   = VFV c (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 []
 breakDown g ms c r rs v (Table p q) fn0 fn = do
   let i  = Map.size ms + 1
@@ -227,6 +228,7 @@ breakDown g ms c r rs v (Table p q) fn0 fn = do
     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
@@ -295,6 +297,7 @@ 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)
 
 
@@ -350,6 +353,7 @@ flatten subst (VSusp i k vs) = do
 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")
 
 

From 82db897847c7ee566adf72c352fd3d6652c911fc Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sun, 19 Apr 2026 13:28:47 +0200
Subject: [PATCH 106/144] updates in the type checker

---
 src/compiler/api/GF/Compile/CheckGrammar.hs |  3 +
 src/compiler/api/GF/Compile/TypeCheck.hs    | 64 +++++++++++++++------
 src/compiler/api/GF/Grammar/Macros.hs       |  6 +-
 3 files changed, 54 insertions(+), 19 deletions(-)

diff --git a/src/compiler/api/GF/Compile/CheckGrammar.hs b/src/compiler/api/GF/Compile/CheckGrammar.hs
index 719f541eb..4bd0e6617 100644
--- a/src/compiler/api/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/api/GF/Compile/CheckGrammar.hs
@@ -164,6 +164,9 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
       (typ,_) <- chIn loc "the type of function" $
                    checkLType ga typ typeType
       typ <- normalForm ga typ   -- to calculate let definitions
+      sm <- update sm c (AbsFun (Just (L loc typ)) md)
+      let gr' = prependModule sgr sm
+          ga' = Gl gr' noPredef True
       md <- case md of
               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
diff --git a/src/compiler/api/GF/Compile/TypeCheck.hs b/src/compiler/api/GF/Compile/TypeCheck.hs
index 9f5e7ad1c..f4d31bac0 100644
--- a/src/compiler/api/GF/Compile/TypeCheck.hs
+++ b/src/compiler/api/GF/Compile/TypeCheck.hs
@@ -87,10 +87,9 @@ checkDef g q ty (ps,t) = do
       (c2,c3)  = split c23
   res <- runEvalM g $ do
             (scope,ps,_,ty) <- tcPattApp [] c1 (eval g [] c2 ty []) ps
+            (scope,ps) <- mapAccumM zonkPatt scope ps
             (t,_) <- tcRho scope c3 t (Just ty)
-            let xs = scopeVars scope
-            ps <- mapM (zonkPatt xs) ps
-            t  <- zonkTerm xs t
+            t  <- zonkTerm (scopeVars scope) t
             return (ps,t)
   case res of
     [eq] -> return eq
@@ -766,14 +765,18 @@ tcPatt scope c p@(PV x)    Nothing    = do
   i <- newResiduation scope
   if x == identW
     then return (scope,p,Nothing,VMeta i [])
-    else let v  = VGen (length scope) []
-             ty = VMeta i []
-         in return ((x,ty):scope,p,Just v,ty)
+    else do let v      = VGen (length scope) []
+                ty     = VMeta i []
+                scope' = (x,ty):scope
+            expandPattScope scope'
+            return (scope',p,Just v,ty)
 tcPatt scope c p@(PV x)    (Just ty) =
   if x == identW
     then return (scope,p,Nothing,ty)
-    else let v = VGen (length scope) []
-         in return ((x,ty):scope,p,Just v,ty)
+    else do let v      = VGen (length scope) []
+                scope' = (x,ty):scope
+            expandPattScope scope'
+            return (scope',p,Just v,ty)
 tcPatt scope c (PP q ps) mb_ty = do
   g@(Gl gr _ isAbstract) <- globals
   ty <- case (if isAbstract then lookupFunType else lookupResType) gr q of
@@ -953,6 +956,11 @@ tcPattApp scope c ty ps =
   evalError ("Cannot check patterns" <+> hsep (map (ppPatt Unqualified 10) ps) $$
              "against type" <+> ppValue Unqualified 0 ty)
 
+expandPattScope scope = EvalM (\g k state r msgs ->
+  k () state{metaVars=fmap expand (metaVars state)} r msgs)
+  where
+    expand (Bound scope v) = Bound scope v
+    expand (Residuation _) = Residuation scope
 
 measurePatt p =
   case p of
@@ -1679,13 +1687,6 @@ quantify scope t tvs ty = do
     check m n xs v@(VInts _ _) = return (xs,v)
     check m n xs v = unimplemented ("check "++show (ppValue Unqualified 5 v))
 
-    mapAccumM :: Monad m => (a -> b -> m (a,c)) -> a -> [b] -> m (a,[c])
-    mapAccumM f s []     = return (s,[])
-    mapAccumM f s (x:xs) = do
-      (s,y)  <- f s x
-      (s,ys) <- mapAccumM f s xs
-      return (s,y:ys)
-
 allBinders :: [Ident]    -- a,b,..z, a1, b1,... z1, a2, b2,...
 allBinders = [ identS [x]          | x <- ['a'..'z'] ] ++
              [ identS (x : show i) | i <- [1 :: Integer ..], x <- ['a'..'z']]
@@ -1710,6 +1711,13 @@ update3 l o v (r@(l',_,_):rs)
   | l == l'   = (l,o,v) : rs
   | otherwise = r : update3 l o v rs
 
+mapAccumM :: Monad m => (a -> b -> m (a,c)) -> a -> [b] -> m (a,[c])
+mapAccumM f s []     = return (s,[])
+mapAccumM f s (x:xs) = do
+  (s,y)  <- f s x
+  (s,ys) <- mapAccumM f s xs
+  return (s,y:ys)
+
 newVar :: Scope -> Ident
 newVar scope = head [x | i <- [1..],
                          let x = identS ('v':show i),
@@ -1768,9 +1776,29 @@ zonkTerm xs (Meta i) = do
     _         -> return (Meta i)
 zonkTerm xs t = composOp (zonkTerm xs) t
 
-zonkPatt :: [Ident] -> Patt -> EvalM Patt
-zonkPatt xs (PTilde t) = fmap PTilde (zonkTerm xs t)
-zonkPatt xs p          = composPattOp (zonkPatt xs) p
+zonkPatt :: Scope -> Patt -> EvalM (Scope,Patt)
+zonkPatt scope (PP q ps) = do
+  (scope,ps) <- mapAccumM zonkPatt scope ps
+  return (scope, PP q ps)
+zonkPatt scope (PImplArg p) = do
+  (scope,p) <- zonkPatt scope p
+  return (scope, PImplArg p)
+zonkPatt scope (PTilde t) =
+  case t of
+    Meta i -> do st <- getMeta i
+                 case st of
+                   Bound _ v  -> do t <- (zonkTerm xs =<< value2termM False xs v)
+                                    return (scope, PTilde t)
+                   Residuation _
+                              -> do let v = mkFreshVar xs (identS "v")
+                                        scope' = (v,undefined):scope
+                                    setMeta i (Bound scope' (VGen (length scope) []))
+                                    return (scope', PV v)
+    t      -> do t <- zonkTerm xs t
+                 return (scope, PTilde t)
+  where
+    xs = scopeVars scope
+zonkPatt scope p          = return (scope,p)
 
 zonkValue :: Value -> EvalM Value
 zonkValue (VProd bt x ty1 ty2) = do
diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs
index c03adfe7e..21c3e1cc0 100644
--- a/src/compiler/api/GF/Grammar/Macros.hs
+++ b/src/compiler/api/GF/Grammar/Macros.hs
@@ -467,6 +467,10 @@ allDependencies ism b =
       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)
@@ -483,7 +487,7 @@ allDependencies ism b =
       ResParam (Just (L loc ps)) _ -> concat [opersIn  t | (_,cont) <- ps, (_,_,t) <- cont]
       CncCat pty _ _ _ _ -> opty pty
       CncFun _   pt _ _ -> opty pt
-      AbsFun pty peqs -> opty pty ++ [c | L _ (ps,t) <- maybe [] snd peqs, c <- concatMap opersInPatt ps]
+      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]
       _              -> []
 

From 96492e698aa20528733dcc88f9ca1937e06b65ee Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 6 May 2026 14:10:50 +0200
Subject: [PATCH 107/144] don't use map show in type2fields

---
 src/compiler/api/GF/Compile/GeneratePMCFG.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index 4c1cd86da..eec1bf995 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -102,7 +102,7 @@ pmcfgForm g t ctxt ty = do
        in apply (d+1) ms' s' ctxt (App t t2) (params:args)
 
 type2fields :: SourceGrammar -> Type -> [String]
-type2fields gr = map show . type2fields PP.empty
+type2fields gr = type2fields PP.empty
   where
     type2fields d (Sort s) | s == cStr = [show d]
     type2fields d (RecType lbls) =

From a66a620990f601c3013a9cab5b3063ece063ddc7 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 6 May 2026 14:29:28 +0200
Subject: [PATCH 108/144] implement pre

---
 src/runtime/c/pgf/linearizer.cxx | 16 +++++++++-------
 src/runtime/c/pgf/linearizer.h   |  3 ++-
 2 files changed, 11 insertions(+), 8 deletions(-)

diff --git a/src/runtime/c/pgf/linearizer.cxx b/src/runtime/c/pgf/linearizer.cxx
index 6626676cb..c6e2f487c 100644
--- a/src/runtime/c/pgf/linearizer.cxx
+++ b/src/runtime/c/pgf/linearizer.cxx
@@ -87,10 +87,10 @@ void PgfLinearizer::TreeNode::linearize_var(PgfLinearizationOutputIface *out, Pg
     out->symbol_token(linearizer->printer.get_text());
 }
 
-void PgfLinearizer::TreeNode::linearize_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item)
+void PgfLinearizer::TreeNode::linearize_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item, vector<PgfSymbol> syms)
 {
-    for (size_t i = 0; i < item->rule->syms.size(); i++) {
-        PgfSymbol sym = item->rule->syms[i];
+    for (size_t i = 0; i < syms.size(); i++) {
+        PgfSymbol sym = syms[i];
 
         switch (ref<PgfSymbol>::get_tag(sym)) {
         case PgfSymbolCat::tag: {
@@ -170,6 +170,7 @@ void PgfLinearizer::TreeNode::linearize_item(PgfLinearizationOutputIface *out, P
             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;
@@ -298,7 +299,8 @@ void PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, Pgf
         linearizer->pre_stack->bracket_stack = bracket;
     }
 
-    linearize_item(out, linearizer, items[lindex]);
+    linearize_item(out, linearizer,
+                   items[lindex],items[lindex]->rule->syms.as_vector());
 
     if (linearizer->pre_stack == NULL)
         out->end_phrase(cat, fid, field, &lin->name);
@@ -537,7 +539,7 @@ void PgfLinearizer::TreeLinrefNode::linearize(PgfLinearizationOutputIface *out,
 {
     ref<PgfConcrLincat> lincat = args->get_lincat(linearizer);
     if (lincat != 0) {
-        linearize_item(out, linearizer, item);
+        linearize_item(out, linearizer, item, item->rule->syms.as_vector());
     } else {
         args->linearize(out, linearizer, lindex);
     }
@@ -690,14 +692,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)
diff --git a/src/runtime/c/pgf/linearizer.h b/src/runtime/c/pgf/linearizer.h
index 2c6185259..f9f49c8e2 100644
--- a/src/runtime/c/pgf/linearizer.h
+++ b/src/runtime/c/pgf/linearizer.h
@@ -85,7 +85,7 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
         virtual void check_category(PgfLinearizer *linearizer, PgfText *cat)=0;
         virtual void 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_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item);
+        virtual void linearize_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item, vector<PgfSymbol> syms);
         virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)=0;
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer)=0;
         virtual ~TreeNode() { free(hoas_vars); };
@@ -173,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;

From 83403860338fcf3c602f00fd330415f57ab14713 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 6 May 2026 18:41:50 +0200
Subject: [PATCH 109/144] build the parse table when compiling from sources

---
 src/runtime/c/pgf/compute.cxx             | 142 ++++++++++++++++++++++
 src/runtime/c/pgf/compute.h               |  69 +++++++++++
 src/runtime/c/pgf/pgf.cxx                 |  52 +++++++-
 src/runtime/c/pgf/pgf.h                   |  12 +-
 src/runtime/haskell/PGF2.hsc              |   7 +-
 src/runtime/haskell/PGF2/FFI.hsc          |  15 ++-
 src/runtime/haskell/PGF2/Transactions.hsc | 112 +++++++++--------
 7 files changed, 344 insertions(+), 65 deletions(-)
 create mode 100644 src/runtime/c/pgf/compute.cxx
 create mode 100644 src/runtime/c/pgf/compute.h

diff --git a/src/runtime/c/pgf/compute.cxx b/src/runtime/c/pgf/compute.cxx
new file mode 100644
index 000000000..4e03ead11
--- /dev/null
+++ b/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;
+}
diff --git a/src/runtime/c/pgf/compute.h b/src/runtime/c/pgf/compute.h
new file mode 100644
index 000000000..51171fc61
--- /dev/null
+++ b/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
diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx
index 82bc65a5e..8c473327c 100644
--- a/src/runtime/c/pgf/pgf.cxx
+++ b/src/runtime/c/pgf/pgf.cxx
@@ -705,6 +705,14 @@ prob_t pgf_function_prob(PgfDB *db, PgfRevision revision,
     return INFINITY;
 }
 
+PGF_API
+PgfExpr pgf_compute(PgfDB *db, PgfRevision revision, PgfExpr expr,
+                    PgfMarshaller *m, PgfUnmarshaller *u,
+                    PgfExn *err)
+{
+    return 0;
+}
+
 PGF_API
 PgfText *pgf_concrete_name(PgfDB *db, PgfConcrRevision revision,
                            PgfExn *err)
@@ -1638,6 +1646,7 @@ void pgf_drop_category(PgfDB *db, PgfRevision revision,
 PGF_API
 PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision,
                                      PgfText *name,
+                                     void **p_tm,
                                      PgfExn *err)
 {
     PGF_API_BEGIN {
@@ -1669,6 +1678,8 @@ PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision,
 
         object rev = db->register_concr_revision(revision, index);
 
+        *p_tm = new PgfParseTableMaker(concr);
+
         db->ref_count++;
         return rev;
     } PGF_API_END
@@ -1678,6 +1689,7 @@ PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision,
 PGF_API
 PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision,
                                     PgfText *name,
+                                    void **p_tm,
                                     PgfExn *err)
 {
     PGF_API_BEGIN {
@@ -1693,6 +1705,8 @@ PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision,
 
         concr = clone_concrete(pgf, concr);
 
+        *p_tm = new PgfParseTableMaker(concr);
+
         object rev = db->register_concr_revision(revision, index);
         db->ref_count++;
         return rev;
@@ -1700,6 +1714,22 @@ PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision,
     return 0;
 }
 
+PGF_API
+void pgf_free_parse_table(PgfDB *db,
+                          PgfRevision revision, PgfConcrRevision cnc_revision,
+                          void *table_maker_)
+{
+    PgfParseTableMaker* table_maker = (PgfParseTableMaker*) table_maker_;
+
+    DB_scope scope(db, WRITER_SCOPE);
+
+    ref<PgfPGF> pgf = db->revision2pgf(revision);
+    ref<PgfConcr> concr = db->revision2concr(cnc_revision);
+
+    concr->last_fid = table_maker->get_last_fid();
+    delete table_maker;
+}
+
 PGF_API
 void pgf_drop_concrete(PgfDB *db, PgfRevision revision,
                        PgfText *name,
@@ -1742,13 +1772,13 @@ class PGF_INTERNAL PgfLinBuilder : public PgfLinBuilderIface
 
     size_t pre_sym_index;
 
-    PgfParseTableMaker tm;
+    PgfParseTableMaker *table_maker;
 
     const char *builder_error_msg =
         "Detected incorrect use of the linearization builder";
 
 public:
-    PgfLinBuilder(ref<PgfConcr> concr) : tm(concr)
+    PgfLinBuilder(ref<PgfConcr> concr, PgfParseTableMaker *table_maker)
     {
 		this->concr = concr;
 
@@ -1763,6 +1793,7 @@ public:
         this->rule_index = 0;
         this->syms = 0;
         this->pre_sym_index = (size_t) -1;
+        this->table_maker = table_maker;
     }
 
     ref<PgfConcrLincat> build(ref<PgfAbsCat> abscat,
@@ -1809,6 +1840,10 @@ public:
             return 0;
         }
 
+        for (size_t i = lincat->n_lindefs; i < rules.size(); i++) {
+            table_maker->insert_rule(rules[i]);
+        }
+
         return lincat;
     }
 
@@ -1855,6 +1890,10 @@ public:
             return 0;
         }
 
+        for (size_t i = 0; i < rules.size(); i++) {
+            table_maker->insert_rule(rules[i]);
+        }
+
         return lin;
     }
 
@@ -2269,6 +2308,7 @@ public:
 PGF_API
 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)
@@ -2286,7 +2326,7 @@ void pgf_create_lincat(PgfDB *db,
         }
 
         ref<PgfConcrLincat> lincat =
-            PgfLinBuilder(concr).build(abscat, n_fields, fields, n_lindefs, n_linrefs, build, err);
+            PgfLinBuilder(concr,(PgfParseTableMaker *)table_maker).build(abscat, n_fields, fields, n_lindefs, n_linrefs, build, err);
         if (lincat != 0) {
             Namespace<PgfConcrLincat> lincats =
                 namespace_insert(concr->lincats, lincat);
@@ -2334,6 +2374,7 @@ void pgf_drop_lincat(PgfDB *db,
 PGF_API
 void pgf_create_lin(PgfDB *db,
                     PgfRevision revision, PgfConcrRevision cnc_revision,
+                    void *table_maker,
                     PgfText *name, size_t n_rules,
                     PgfBuildLinIface *build,
                     PgfExn *err)
@@ -2354,7 +2395,7 @@ void pgf_create_lin(PgfDB *db,
         }
 
         ref<PgfConcrLin> lin =
-            PgfLinBuilder(concr).build(absfun, n_rules, build, err);
+            PgfLinBuilder(concr,(PgfParseTableMaker *)table_maker).build(absfun, n_rules, build, err);
         if (lin != 0) {
             Namespace<PgfConcrLin> lins =
                 namespace_insert(concr->lins, lin);
@@ -2369,6 +2410,7 @@ void pgf_create_lin(PgfDB *db,
 PGF_API
 void pgf_alter_lin(PgfDB *db,
                    PgfRevision revision, PgfConcrRevision cnc_revision,
+                   void *table_maker,
                    PgfText *name, size_t n_rules,
                    PgfBuildLinIface *build,
                    PgfExn *err)
@@ -2386,7 +2428,7 @@ void pgf_alter_lin(PgfDB *db,
         }
 
         ref<PgfConcrLin> lin =
-            PgfLinBuilder(concr).build(absfun, n_rules, build, err);
+            PgfLinBuilder(concr,(PgfParseTableMaker *)table_maker).build(absfun, n_rules, build, err);
         if (lin != 0) {
             ref<PgfConcrLin> old_lin;
             Namespace<PgfConcrLin> lins =
diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h
index d4360dcc0..8a590591c 100644
--- a/src/runtime/c/pgf/pgf.h
+++ b/src/runtime/c/pgf/pgf.h
@@ -612,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,
@@ -696,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);
@@ -708,6 +714,7 @@ void pgf_drop_lincat(PgfDB *db,
 PGF_API_DECL
 void pgf_create_lin(PgfDB *db,
                     PgfRevision revision, PgfConcrRevision cnc_revision,
+                    void *table_maker,
                     PgfText *name, size_t n_rules,
                     PgfBuildLinIface *build,
                     PgfExn *err);
@@ -715,6 +722,7 @@ void pgf_create_lin(PgfDB *db,
 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);
diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc
index e81030fcf..05226ab3d 100644
--- a/src/runtime/haskell/PGF2.hsc
+++ b/src/runtime/haskell/PGF2.hsc
@@ -595,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 =
diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc
index 1ad73a18f..6b3e90447 100644
--- a/src/runtime/haskell/PGF2/FFI.hsc
+++ b/src/runtime/haskell/PGF2/FFI.hsc
@@ -50,6 +50,7 @@ data PgfMorphoCallback
 data PgfCohortsCallback
 data PgfExprEnum
 data PgfAlignmentPhrase
+data PgfParseTableMaker
 
 type Wrapper a = a -> IO (FunPtr a)
 type Dynamic a = FunPtr a -> a
@@ -205,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)
@@ -225,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 ()
 
@@ -249,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 ()
 
diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc
index 8b1c8a8a7..513a67388 100644
--- a/src/runtime/haskell/PGF2/Transactions.hsc
+++ b/src/runtime/haskell/PGF2/Transactions.hsc
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-}
 module PGF2.Transactions
           ( -- transactions
             TxnID
@@ -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
-    res <- g c_db c_abstr c_revision c_exn
+  fmap f (Transaction g) = Transaction $ \c_db c_abstr ctxt c_exn -> do
+    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
-    res <- f c_db c_abstr c_revision c_exn
+  (Transaction f) >>= g = Transaction $ \c_db c_abstr ctxt c_exn -> do
+    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,68 +167,72 @@ 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 ->
-  withText name $ \c_name -> do
-  bracketPtr (pgf_create_concrete c_db c_revision c_name c_exn)
-             (pgf_free_concr_revision_ c_db) $ \c_concr_revision ->
-    f c_db c_abstr c_concr_revision c_exn
+createConcrete name (Transaction f) = Transaction $ \c_db c_abstr _ c_exn ->
+  withText name $ \c_name ->
+  bracketCnc c_exn
+             (pgf_create_concrete c_db c_abstr c_name)
+             (\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)
-             (pgf_free_concr_revision_ c_db) $ \c_concr_revision ->
-    f c_db c_abstr c_concr_revision c_exn
+  bracketCnc c_exn
+             (pgf_clone_concrete c_db c_abstr c_name)
+             (\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
-    if a == nullPtr
+    c <- before p_tm c_exn
+    if c == nullPtr
       then return undefined
-      else do r <- restore (thing a) `onException` after a
-              _ <- after a
+      else do tm <- peek p_tm
+              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
@@ -258,13 +266,13 @@ data PArg = PArg [(LIndex,LIndex)] {-# UNPACK #-} !LParam
             deriving (Eq,Show)
 
 createLincat :: Cat -> [String] -> [Rule] -> [Rule] -> Transaction Concr ()
-createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr c_revision c_exn ->
+createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr (c_revision,tm) 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) $ \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
@@ -276,21 +284,21 @@ createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr c_revisio
         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 -> [Rule] -> Transaction Concr ()
-createLin name rules = 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 rules $ \c_build ->
-    pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length rules)) 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 -> [Rule] -> Transaction Concr ()
-alterLin name rules = 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 rules $ \c_build ->
-    pgf_alter_lin c_db c_abstr c_revision c_name (fromIntegral (length rules)) c_build c_exn
+    pgf_alter_lin c_db c_abstr c_revision tm c_name (fromIntegral (length rules)) c_build c_exn
 
 withBuildLinIface rules f = do
   (allocaBytes (#size PgfBuildLinIface) $ \c_build ->
@@ -394,12 +402,12 @@ withBuildLinIface rules 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
@@ -422,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

From c37e7b5a7aaf432115e05a3b2714b6cb85227fcf Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Mon, 11 May 2026 15:41:02 +0200
Subject: [PATCH 110/144] use overlapping intervals to detect unifiable terms

---
 src/runtime/c/pgf/intervalmap.h | 123 +++++++++++++++++++++++++++++---
 src/runtime/c/pgf/parser.cxx    | 120 ++++++++++++++++---------------
 src/runtime/c/pgf/parser.h      |  12 ++--
 3 files changed, 182 insertions(+), 73 deletions(-)

diff --git a/src/runtime/c/pgf/intervalmap.h b/src/runtime/c/pgf/intervalmap.h
index aff038ed5..e78b139f6 100644
--- a/src/runtime/c/pgf/intervalmap.h
+++ b/src/runtime/c/pgf/intervalmap.h
@@ -41,13 +41,13 @@ class PGF_INTERNAL_DECL interval_map {
         }
 
         int cmp;
-        if (node->start < start)
+        if (start < node->start)
             cmp = -1;
-        else if (node->start > start)
+        else if (start > node->start)
             cmp = 1;
-        else if (node->end < end)
+        else if (end < node->end)
             cmp = -1;
-        else if (node->end > end)
+        else if (end > node->end)
             cmp = 1;
         else
             cmp = 0;
@@ -74,13 +74,13 @@ class PGF_INTERNAL_DECL interval_map {
         }
 
         int cmp;
-        if (node->start < start)
+        if (start < node->start)
             cmp = -1;
-        else if (node->start > start)
+        else if (start > node->start)
             cmp = 1;
-        else if (node->end < end)
+        else if (end < node->end)
             cmp = -1;
-        else if (node->end > end)
+        else if (end > node->end)
             cmp = 1;
         else
             cmp = 0;
@@ -383,6 +383,113 @@ public:
     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
diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index 56972bbf9..a68a7ae4b 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -43,8 +43,12 @@ PgfAbstractParser::CCat::~CCat()
 
 PgfAbstractParser::Cont::~Cont()
 {
-    for (Item *item : suspended) {
-        delete item;
+    for (auto it1 : suspended) {
+        for (auto it2 : it1.second) {
+            for (Item *item : it2.second) {
+                delete item;
+            }
+        }
     }
 }
 
@@ -62,10 +66,8 @@ PgfAbstractParser::~PgfAbstractParser()
         for (auto it : state->conts1) {
             delete it.second;
         }
-        for (auto it1 : state->conts2) {
-            for (auto it2 : it1.second) {
-                delete it2.second;
-            }
+        for (auto it : state->conts2) {
+            delete it.second;
         }
 
         State *next = state->next;
@@ -123,12 +125,23 @@ void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, P
             }
 
             if (lincat != 0) {
-                suspend(state,lincat,item);
+                Cont *&cont = state->conts1[lincat];
+                if (cont == NULL) {
+                    cont = new Cont;
+                    cont->ccat = NULL;
+                    cont->lincat = lincat;
+                    cont->state = state;
+                }
+
+                interval_t value_i = item->interval(item->rule->args[symcat->d]);
+                interval_t lin_idx_i = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
+                auto &suspended = cont->suspended[value_i][lin_idx_i];
+                suspended.push_back(item);
+
+                suspend(cont,item,suspended.size());
             }
         } else {
-            interval_t lin_idx = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
-
-            Cont *&cont = state->conts2[ccat][lin_idx];
+            Cont *&cont = state->conts2[ccat];
             if (cont == NULL) {
                 cont = new Cont;
                 cont->ccat = ccat;
@@ -139,9 +152,12 @@ void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, P
                 cont->state = state;
             }
 
-            cont->suspended.push_back(item);
+            interval_t value_i   = item->interval(item->rule->args[symcat->d]);
+            interval_t lin_idx_i = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
+            auto &suspended = cont->suspended[value_i][lin_idx_i];
+            suspended.push_back(item);
 
-            if (cont->suspended.size() == 1) {
+            if (suspended.size() == 1) {
                 if (ccat->fid <= initial_fid) {
                     size_t n_items = 0;
                     vector<ref<PgfItem>> items =
@@ -163,7 +179,7 @@ void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, P
                     if (it1 != next->completed.end()) {
                         auto *it2 = it1->second.lookup(ccat->value);
                         if (it2 != NULL) {
-                            auto *it3 = it2->lookup(lin_idx);
+                            auto *it3 = it2->lookup(lin_idx_i);
                             if (it3 != NULL) {
                                 CCat *arg = *it3;
                                 Item *new_item = new (item) Item;
@@ -292,21 +308,27 @@ void PgfAbstractParser::complete(Item *item, const PgfTextSpot &spot, bool bind)
         if (ccat->prods.size() == 1) {
             if (ccat->cont->ccat == NULL)
                 bu_predict(state, ccat);
-            size_t n_items = ccat->cont->suspended.size();
-            for (size_t i = 0; i < n_items; i++) {
-                Item *new_item = new (ccat->cont->suspended[i]) Item;
-                combine(state,new_item,ccat);
-            };
+
+            for (auto it1 : ccat->cont->suspended.overlaps(ccat->value)) {
+                for (auto it2 : it1.second.overlaps(ccat->lin_idx)) {
+                    size_t n_items = it2.second.size();
+                    for (size_t i = 0; i < n_items; i++) {
+                        Item *new_item = new (it2.second[i]) Item;
+                        combine(state,new_item,ccat);
+                    };
+                }
+            }
         } else {
             State *next = state;
             while (next != NULL) {
-                for (auto it : next->conts2[ccat]) {
-                    interval_t lin_idx = it.first;
-                    Cont *cont = it.second;
-                    if (cont != NULL) {
-                        Item *item = cont->suspended[0];
-                        auto symcat = ref<PgfSymbolCat>::untagged(item->syms[item->dot]);
-                        td_predict(next,cont,prod,item,item->rule->args[symcat->d],ref<PgfLParam>::from_ptr(&symcat->r));
+                Cont *cont = next->conts2[ccat];
+                if (cont != NULL) {
+                    for (auto it1 : cont->suspended) {
+                        for (auto it2 : it1.second) {
+                            Item *item = it2.second[0];
+                            auto symcat = ref<PgfSymbolCat>::untagged(item->syms[item->dot]);
+                            td_predict(next,cont,prod,item,item->rule->args[symcat->d],ref<PgfLParam>::from_ptr(&symcat->r));
+                        }
                     }
                 }
                 next = next->next;
@@ -1267,23 +1289,13 @@ void PgfParser::symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym)
     process(item, spot, true);
 }
 
-void PgfParser::suspend(State *state,ref<PgfConcrLincat> lincat,Item *item)
+void PgfParser::suspend(Cont *cont,Item *item,size_t n_suspended)
 {
-    Cont *&cont = state->conts1[lincat];
-    if (cont == NULL) {
-        cont = new Cont;
-        cont->ccat = NULL;
-        cont->lincat = lincat;
-        cont->state = state;
-    }
-
-    cont->suspended.push_back(item);
-
-    if (cont->suspended.size() == 1) {
+    if (n_suspended == 1) {
         std::function<void(ref<PgfSymbolCCat>,size_t,vector<ref<PgfItem>>)> f =
-            [this,state,item,cont](ref<PgfSymbolCCat> symcf, size_t n_items, vector<ref<PgfItem>> items) {
+            [this,item,cont](ref<PgfSymbolCCat> symcf, size_t n_items, vector<ref<PgfItem>> items) {
 
-                PgfItem *xitem = items[0];
+                ref<PgfItem> xitem = items[0];
 
                 Item *new_item = new (item) Item;
                 PgfSymbol sym = new_item->rule->syms[new_item->dot];
@@ -1308,21 +1320,21 @@ void PgfParser::suspend(State *state,ref<PgfConcrLincat> lincat,Item *item)
                     arg_ccat->covered = true;
                 }
 
-                state->completed[cont][symcf->value][symcf->lin_idx] = arg_ccat;
+                cont->state->completed[cont][symcf->value][symcf->lin_idx] = arg_ccat;
 
                 new_item->dot++;
                 new_item->args[sym_cat->d] = arg_ccat;
 
-                process(new_item, state->start, false);
+                process(new_item, cont->state->start, false);
             };
-        phrasetable_iter(concr->phrasetable,lincat,f);
+        phrasetable_iter(concr->phrasetable,cont->lincat,f);
     } else {
-        auto it1 = state->completed.find(cont);
-        if (it1 != state->completed.end()) {
+        auto it1 = cont->state->completed.find(cont);
+        if (it1 != cont->state->completed.end()) {
             for (auto it2 : it1->second) {
                 for (auto it3 : it2.second) {
                     Item *new_item = new (item) Item;
-                    combine(state, new_item, it3.second);
+                    combine(cont->state, new_item, it3.second);
                 }
             }
         }
@@ -1452,30 +1464,20 @@ void PgfParseTableMaker::symbol_bind(Item *item, const PgfTextSpot &spot, PgfSym
     delete item;
 }
 
-void PgfParseTableMaker::suspend(State *state,ref<PgfConcrLincat> lincat,Item *item)
+void PgfParseTableMaker::suspend(Cont *cont,Item *item,size_t n_suspended)
 {
-    Cont *&cont = state->conts1[lincat];
-    if (cont == NULL) {
-        cont = new Cont;
-        cont->ccat = NULL;
-        cont->lincat = lincat;
-        cont->state = state;
-    }
-
-    cont->suspended.push_back(item);
-
-    for (auto it1 : state->completed[cont]) {
+    for (auto it1 : cont->state->completed[cont]) {
         for (auto it2 : it1.second) {
             CCat *ccat = it2.second;
             if (ccat != NULL) {
                 Item *new_item = new (item) Item;
-                combine(state,new_item,ccat);
+                combine(cont->state,new_item,ccat);
             }
         }
     }
 
     auto pitem = clone_item(item);
-    auto acat  = ref<PgfSymbolACat>::from_ptr((PgfSymbolACat*) &lincat->name);
+    auto acat  = ref<PgfSymbolACat>::from_ptr((PgfSymbolACat*) &cont->lincat->name);
     auto phrasetable = phrasetable_insert(concr->phrasetable,acat.tagged(),pitem);
     concr->phrasetable = phrasetable;
 }
diff --git a/src/runtime/c/pgf/parser.h b/src/runtime/c/pgf/parser.h
index d735e57c3..5033a5298 100644
--- a/src/runtime/c/pgf/parser.h
+++ b/src/runtime/c/pgf/parser.h
@@ -101,7 +101,7 @@ protected:
         PgfTextSpot start, end;
         bool needs_bind;
         std::map<ref<PgfConcrLincat>,Cont*> conts1;
-        std::map<CCat*,interval_map<Cont*>> conts2;
+        std::map<CCat*,Cont*> conts2;
         std::map<Cont*,interval_map<interval_map<CCat*>>> completed;
         
         State *next;
@@ -111,7 +111,7 @@ protected:
         CCat *ccat;
         ref<PgfConcrLincat> lincat;
         State *state;
-        std::vector<Item*> suspended;
+        interval_map<interval_map<std::vector<Item*>>> suspended;
 
         ~Cont();
     };
@@ -215,7 +215,7 @@ protected:
     virtual State *new_state(const PgfTextSpot &start)=0;
     virtual void symbol_token(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym)=0;
     virtual void symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym)=0;
-    virtual void suspend(State *state,ref<PgfConcrLincat> lincat, Item *item)=0;
+    virtual void suspend(Cont *cont, Item *item, size_t n_suspended)=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, CCat *ccat)=0;
 
@@ -247,7 +247,7 @@ class PGF_INTERNAL_DECL PgfParser : private PgfAbstractParser, public PgfExprEnu
     virtual State *new_state(const PgfTextSpot &start);
     virtual void symbol_token(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym);
     virtual void symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym);
-    virtual void suspend(State *state,ref<PgfConcrLincat> lincat, Item *item);
+    virtual void suspend(Cont *cont,Item *item,size_t n_suspended);
     virtual void final_item(State *state,CCat *ccat,Item *item,interval_t value,interval_t lin_idx);
     virtual void bu_predict(State *state, CCat *ccat);
 
@@ -288,8 +288,8 @@ private:
     virtual State *new_state(const PgfTextSpot &start);
     virtual void symbol_token(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym);
     virtual void symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym);
-    virtual void suspend(State *state,ref<PgfConcrLincat> lincat,Item *item);
-    virtual void final_item(State *state,CCat *ccat,Item *item,interval_t value,interval_t lin_idx);
+    virtual void suspend(Cont *cont, Item *item, size_t n_suspended);
+    virtual void final_item(State *state, CCat *ccat,Item *item,interval_t value,interval_t lin_idx);
     virtual void bu_predict(State *state, CCat *ccat);
 
     static

From 1daa00aa29728033dd0d2c95288aa3802864e3e9 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 13 May 2026 22:05:44 +0200
Subject: [PATCH 111/144] bug fixes

---
 src/runtime/c/pgf/parser.cxx | 28 ++++++++++++++--------------
 1 file changed, 14 insertions(+), 14 deletions(-)

diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index a68a7ae4b..05533ad69 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -2,8 +2,8 @@
 #include "printer.h"
 #include "parser.h"
 
-//#define DEBUG_PARSER
-//#define DEBUG_EXPRS
+#define DEBUG_PARSER
+#define DEBUG_EXPRS
 
 PgfAbstractParser::PgfAbstractParser(ref<PgfConcr> concr)
 {
@@ -582,21 +582,15 @@ void PgfAbstractParser::td_predict(State *state, Cont *cont, Production *prod, I
             }
 
             for (size_t i = 0; i < item->args.size(); i++) {
-                if (prod->args[i] != NULL) {
-/*                    if (!item->instantiate(item->rule->args[i], prod->args[i]->value)) {
-                        delete item;
-                        goto next;
-                    }*/
-                } else {
-                    /*if (!item->instantiate(item->rule->args[i], prod->args[i]->value)) {
-                        delete item;
-                        continue;
-                    }*/
+                if (!item->instantiate(item->rule->args[i], prod->rule, &prod->vars[0], prod->rule->args[i])) {
+                    delete item;
+                    goto next;
                 }
                 item->args[i] = prod->args[i];
             }
 
             process(item, state->start, false);
+next:;
         }
     }
     default:;
@@ -1466,15 +1460,21 @@ void PgfParseTableMaker::symbol_bind(Item *item, const PgfTextSpot &spot, PgfSym
 
 void PgfParseTableMaker::suspend(Cont *cont,Item *item,size_t n_suspended)
 {
+    // collect the cats first, since calling combine in
+    // the loop will change the search index
+    std::vector<CCat*> ccats;
     for (auto it1 : cont->state->completed[cont]) {
         for (auto it2 : it1.second) {
             CCat *ccat = it2.second;
             if (ccat != NULL) {
-                Item *new_item = new (item) Item;
-                combine(cont->state,new_item,ccat);
+                ccats.push_back(ccat);
             }
         }
     }
+    for (CCat *ccat :  ccats) {
+        Item *new_item = new (item) Item;
+        combine(cont->state,new_item,ccat);
+    }
 
     auto pitem = clone_item(item);
     auto acat  = ref<PgfSymbolACat>::from_ptr((PgfSymbolACat*) &cont->lincat->name);

From 39b6fe8f2149ea9946f9f9f374518aeb8edf3a15 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 19 May 2026 17:56:09 +0200
Subject: [PATCH 112/144] added exprFunctions

---
 src/runtime/python/pypgf.c | 32 +++++++++++++++++++++++++++++++-
 1 file changed, 31 insertions(+), 1 deletion(-)

diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c
index 44f42ff22..23a7ec35f 100644
--- a/src/runtime/python/pypgf.c
+++ b/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,

From 5151b67afa172752565cba6288ad5ea5bb9d0110 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 20 May 2026 21:52:54 +0200
Subject: [PATCH 113/144] detect and preserve terms that cannot be evaluated

---
 src/compiler/api/GF/Compile/Compute.hs | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/src/compiler/api/GF/Compile/Compute.hs b/src/compiler/api/GF/Compile/Compute.hs
index 2c625eeb1..76400d7d7 100644
--- a/src/compiler/api/GF/Compile/Compute.hs
+++ b/src/compiler/api/GF/Compile/Compute.hs
@@ -574,6 +574,9 @@ patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
         (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)
+        (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

From 8f4403b7451c7ada424536367cc583822fee5564 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 22 May 2026 11:10:33 +0200
Subject: [PATCH 114/144] implement linearization with lindef

---
 src/runtime/c/pgf/linearizer.cxx | 134 +++++++++++++++++--------------
 src/runtime/c/pgf/linearizer.h   |  15 ++--
 2 files changed, 83 insertions(+), 66 deletions(-)

diff --git a/src/runtime/c/pgf/linearizer.cxx b/src/runtime/c/pgf/linearizer.cxx
index c6e2f487c..9fdc583be 100644
--- a/src/runtime/c/pgf/linearizer.cxx
+++ b/src/runtime/c/pgf/linearizer.cxx
@@ -217,8 +217,6 @@ PgfLinearizer::TreeLinNode::TreeLinNode(PgfLinearizer *linearizer, ref<PgfConcrL
 
 bool PgfLinearizer::TreeLinNode::resolve(PgfLinearizer *linearizer)
 {
-    vector<PgfHypo> hypos = lin->absfun->type->hypos;
-
     while (rule_index < lin->rules.size()) {
         Item *item = new (lin->rules[rule_index]) Item();
         item->rule = lin->rules[rule_index];
@@ -226,8 +224,6 @@ bool PgfLinearizer::TreeLinNode::resolve(PgfLinearizer *linearizer)
         int i = 0;
         TreeNode *arg = args;
         while (arg != NULL) {
-            arg->check_category(linearizer, &hypos[i].type->name);
-
             if (!item->instantiate(item->rule->args[i], arg->value))
                 goto next;
 
@@ -275,10 +271,9 @@ bool PgfLinearizer::TreeLinNode::resolve(PgfLinearizer *linearizer)
     return true;
 }
 
-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)
-        throw pgf_error("An attempt to linearize an expression which is not type correct");
+    return (textcmp(&lin->absfun->type->name, cat) == 0);
 }
 
 void PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
@@ -361,32 +356,36 @@ PgfLinearizer::TreeLindefNode::TreeLindefNode(PgfLinearizer *linearizer, PgfText
 
 bool PgfLinearizer::TreeLindefNode::resolve(PgfLinearizer *linearizer)
 {
-/*    while (rule_index < lincat->n_lindefs2) {
+    if (lincat == 0)
+        return true;
+
+    while (rule_index < lincat->n_lindefs) {
         ref<PgfConcrRule> rule = lincat->rules[rule_index];
         Item *item = new (rule) Item();
+        item->rule = rule;
 
         size_t max_value = 1;
         for (size_t i = 0; i < item->vars.size(); i++) {
             if (item->vars[i] == 0)
-                max_value *= item->rule->vars[i].range;
+                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 < item->vars.size(); i++) {
-                if (item->vars[i] == 0) {
-                    size_t range = item->rule->vars[i].range;
-                    item->vars[i] = v % range;
+            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;
                 }
             }
 
-            Item *new_item = new (item) Item;
-
-            size_t lin_idx = item->eval(new_item->rule->lin_idx);
+            size_t lin_idx = new_item->eval(new_item->rule->lin_idx);
             items[lin_idx] = new_item;
 
-            this->value = item->eval(new_item->rule->res);
+            this->value = new_item->eval(new_item->rule->res);
         }
         delete item;
 
@@ -399,19 +398,19 @@ bool PgfLinearizer::TreeLindefNode::resolve(PgfLinearizer *linearizer)
             return false;
         }
     }
-*/
+
     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)
-        throw pgf_error("Cannot find a lincat for a category");
-    this->items = new Item*[lincat->fields.size()]();
+    if (lincat != 0)
+        this->items = new Item*[lincat->fields.size()]();
+    return true;
 }
 
-void PgfLinearizer::TreeLindefNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r)
+void PgfLinearizer::TreeLindefNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r)
 {
     linearizer->flush_pre_stack(out, literal);
     out->symbol_token(literal);
@@ -425,39 +424,42 @@ void PgfLinearizer::TreeLindefNode::linearize_arg(PgfLinearizationOutputIface *o
 
 void PgfLinearizer::TreeLindefNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
 {
-/*    if (lincat != 0) {
-        PgfText *field = &*lincat->fields[lindex];
-        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;
-        }
+    if (lincat==0) {
+        linearize_arg(out, linearizer, 0, 0);
+        return;
+    }
 
-        ref<PgfSequence> seq = lincat->seqs[(rule_index-1)*lincat->fields.size() + lindex];
-//        linearize_seq(out, linearizer, seq);
+    PgfText *cat = &lincat->name;
+    PgfText *field = &*lincat->fields[lindex];
 
-        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);
-    }*/
+    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;
+    }
+
+    linearize_item(out, linearizer,
+                   items[lindex],items[lindex]->rule->syms.as_vector());
+
+    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;
+    }
 }
 
 ref<PgfConcrLincat> PgfLinearizer::TreeLindefNode::get_lincat(PgfLinearizer *linearizer)
@@ -562,10 +564,9 @@ 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)
-        throw pgf_error("An attempt to linearize an expression which is not type correct");
+    return (textcmp(&lincat->name, cat) == 0);
 }
 
 void PgfLinearizer::TreeLitNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
@@ -599,6 +600,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] = '_';
@@ -638,6 +640,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)
@@ -768,9 +774,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("]");
diff --git a/src/runtime/c/pgf/linearizer.h b/src/runtime/c/pgf/linearizer.h
index f9f49c8e2..0976de2fa 100644
--- a/src/runtime/c/pgf/linearizer.h
+++ b/src/runtime/c/pgf/linearizer.h
@@ -82,7 +82,7 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
 
         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, size_t r);
         virtual void linearize_var(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r);
         virtual void linearize_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item, vector<PgfSymbol> syms);
@@ -98,7 +98,7 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
 
         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 ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
         virtual ~TreeLinNode();
@@ -113,8 +113,8 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
 
         TreeLindefNode(PgfLinearizer *linearizer, PgfText *fun, PgfText *lit);
         virtual bool resolve(PgfLinearizer *linearizer);
-        virtual void check_category(PgfLinearizer *linearizer, PgfText *cat);
-        virtual void linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r);
+        virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat);
+        virtual void linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r);
         virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
         ~TreeLindefNode();
@@ -126,7 +126,7 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
 
         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 ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
         ~TreeLinrefNode();
@@ -137,7 +137,7 @@ 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 ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
         ~TreeLitNode() { free(literal); };
@@ -146,7 +146,7 @@ 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 ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
     };
@@ -183,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:

From a931b58dd97de1b1cd0f9fabd410d0cf6182a28a Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 22 May 2026 15:43:41 +0200
Subject: [PATCH 115/144] of by one error when counting terms of type Ints n

---
 src/compiler/api/GF/Grammar/Lookup.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Grammar/Lookup.hs b/src/compiler/api/GF/Grammar/Lookup.hs
index a95471b56..09c5ac53b 100644
--- a/src/compiler/api/GF/Grammar/Lookup.hs
+++ b/src/compiler/api/GF/Grammar/Lookup.hs
@@ -207,7 +207,7 @@ allParamValues gr ptyp =
 countParamValues :: ErrorMonad m => Grammar -> Type -> m Int
 countParamValues gr ptyp =
   case ptyp of
-    _ | Just n <- isTypeInts ptyp -> return (fromIntegral n)
+    _ | Just n <- isTypeInts ptyp -> return (fromIntegral n+1)
     QC c -> do (_,info) <- lookupOrigInfo gr c
                case info of
                  ResParam _ (Just (_,cnt)) -> return cnt

From ecaae795b03ac8904c96938e6e0601cea0cb4623 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Mon, 25 May 2026 21:11:40 +0200
Subject: [PATCH 116/144] add LT_INIT

---
 src/runtime/c/configure.ac | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/runtime/c/configure.ac b/src/runtime/c/configure.ac
index c9a1a2f07..31eec4173 100644
--- a/src/runtime/c/configure.ac
+++ b/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])

From b89fca9dd76c9664fae8ca13da699ffa04eb88b6 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 5 Jun 2026 10:25:11 +0200
Subject: [PATCH 117/144] make the PMCFG generation strict

---
 src/compiler/api/GF/Compile/GeneratePMCFG.hs | 17 +++++++++--------
 1 file changed, 9 insertions(+), 8 deletions(-)

diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
index eec1bf995..3bc8cd5ce 100644
--- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs
@@ -74,14 +74,15 @@ pmcfgForm g t ctxt ty = do
   let (ms,s',t',arg_params) = apply 0 Map.empty unit ctxt t []
   let v = eval g [] s' t' []
   (ms,_,_,fn) <- breakDown g ms unit 0 [] v ty (return []) empty
-  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)
+  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
 

From 4e8bc0d872a1aa07ed709eafcb5cf8786993e73e Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Mon, 27 Jul 2026 15:35:28 +0200
Subject: [PATCH 118/144] in generateExprs, make sure that the NGF is not
 accidetally GCted

---
 src/runtime/haskell/PGF2.hsc | 17 +++++++++--------
 1 file changed, 9 insertions(+), 8 deletions(-)

diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc
index 05226ab3d..a1a0c6e5d 100644
--- a/src/runtime/haskell/PGF2.hsc
+++ b/src/runtime/haskell/PGF2.hsc
@@ -848,20 +848,21 @@ 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)
-    exprs <- enumerateExprs (c_db c) c_enum
+    c_enum <- withPgfExn "parse" (pgf_parse (c_db c) c_revision_ptr c_ty marshaller unmarshaller c_sent)
+    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_enum $ \c_enum_ptr -> 
+      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
         if c_expr == castPtrToStablePtr nullPtr
@@ -1164,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)
-        enumerateExprs (a_db p) c_enum
+        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) (a_revision p) c_enum
 
 generateAllFrom :: PGF -> Expr -> [(Expr,Float)]
 generateAllFrom p ty = generateAllFromExt p ty maxBound []

From ec7354ca1c217ce6d9532bc49edd9d1d625e2321 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Mon, 27 Jul 2026 16:00:33 +0200
Subject: [PATCH 119/144] bugfixe in td_epsilon and better pretty printing

---
 src/runtime/c/pgf/parser.cxx | 46 ++++++++++++++++++------------------
 src/runtime/c/pgf/parser.h   |  2 +-
 2 files changed, 24 insertions(+), 24 deletions(-)

diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index 05533ad69..1a5586e6f 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -2,8 +2,8 @@
 #include "printer.h"
 #include "parser.h"
 
-#define DEBUG_PARSER
-#define DEBUG_EXPRS
+//#define DEBUG_PARSER
+//#define DEBUG_EXPRS
 
 PgfAbstractParser::PgfAbstractParser(ref<PgfConcr> concr)
 {
@@ -535,20 +535,16 @@ void PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref<PgfItem> pitem,
                         arg_ccat->covered = true;
                     }
                     item->args[i] = arg_ccat;
+                }
 
-/*                    if (!item->instantiate(item->rule->args[i], pitem->args[i]->value)) {
-                        delete item;
-                        goto next;
-                    }*/
-                } else {
-                    /*if (!item->instantiate(item->rule->args[i], pitem->args[i]->value)) {
-                        delete item;
-                        continue;
-                    }*/
+                if (!item->instantiate(item->rule->args[i], pitem->rule, &pitem->vars[0], pitem->rule->args[i])) {
+                    delete item;
+                    goto next;
                 }
             }
 
             process(item, state->start, false);
+next:;
         }
     }
     default:;
@@ -652,12 +648,12 @@ void PgfAbstractParser::print_item(Item *item, const PgfTextSpot &spot)
     if (item->cont) {
         if (item->cont->ccat == NULL) {
             printer.efun(&item->cont->lincat->name);
-            printer.puts("(");
-            printer.lparam(item->rule->res);
-            printer.puts(")");
         } else {
             printer.emeta(item->cont->ccat->fid);
         }
+        printer.puts("(");
+        printer.lparam(item->rule->res);
+        printer.puts(")");
     }
     printer.puts(" -> ");
 
@@ -674,12 +670,12 @@ void PgfAbstractParser::print_item(Item *item, const PgfTextSpot &spot)
             CCat *ccat = item->args[i];
             if (ccat == NULL) {
                 printer.efun(&lin->absfun->type->hypos[i].type->name);
-                printer.puts("(");
-                printer.lparam(item->rule->args[i]);
-                printer.puts(")");
             } else {
                 printer.emeta(ccat->fid);
             }
+            printer.puts("(");
+            printer.lparam(item->rule->args[i]);
+            printer.puts(")");
         }
         printer.puts("]; ");
         break;
@@ -724,6 +720,10 @@ void PgfAbstractParser::print_prod(CCat *ccat, Production *prod)
     }
 
     printer.emeta(ccat->fid);
+    printer.puts("(");
+    printer.lparam(prod->rule->res);
+    printer.puts(")");
+
     printer.puts(" -> ");
 
     switch (ref<object>::get_tag(prod->rule->container)) {
@@ -739,12 +739,12 @@ void PgfAbstractParser::print_prod(CCat *ccat, Production *prod)
             CCat *ccat = prod->args[i];
             if (ccat == NULL) {
                 printer.efun(&lin->absfun->type->hypos[i].type->name);
-                printer.puts("(");
-                printer.lparam(prod->rule->args[i]);
-                printer.puts(")");
             } else {
                 printer.emeta(ccat->fid);
             }
+            printer.puts("(");
+            printer.lparam(prod->rule->args[i]);
+            printer.puts(")");
         }
         printer.puts("]");
         break;
@@ -1368,7 +1368,7 @@ void PgfParser::print_expr_state_left(PgfPrinter *printer, PgfMarshaller *m, Exp
         printer->puts("::");
 }
 
-void PgfParser::print_expr_state_right(PgfPrinter *printer, PgfMarshaller *m, ExprState *estate)
+void PgfParser::print_expr_state_right(PgfPrinter *printer, ExprState *estate)
 {
     for (size_t i = estate->index+1; i < estate->n_args; i++) {
         printer->puts(" ");
@@ -1381,7 +1381,7 @@ void PgfParser::print_expr_state_right(PgfPrinter *printer, PgfMarshaller *m, Ex
     if (estate->res && estate->res->pending.size() > 0) {
         printer->puts(")");
         ExprState *parent = estate->res->pending[0];
-        print_expr_state_right(printer, m, parent);
+        print_expr_state_right(printer, parent);
     }
 }
 
@@ -1391,7 +1391,7 @@ void PgfParser::print_expr_state(PgfMarshaller *m, ExprState *estate)
     printer.nprintf(64,"[%f] ",estate->prob);
     print_expr_state_left(&printer, m, estate);
     printer.puts(" .");
-    print_expr_state_right(&printer, m, estate);
+    print_expr_state_right(&printer, estate);
 
     PgfText *text = printer.get_text();
     fprintf(stderr, "%s\n", text->text);
diff --git a/src/runtime/c/pgf/parser.h b/src/runtime/c/pgf/parser.h
index 5033a5298..35a799682 100644
--- a/src/runtime/c/pgf/parser.h
+++ b/src/runtime/c/pgf/parser.h
@@ -261,7 +261,7 @@ class PGF_INTERNAL_DECL PgfParser : private PgfAbstractParser, public PgfExprEnu
     static
     void print_expr_state_left(PgfPrinter *printer, PgfMarshaller *m, ExprState *estate);
     static
-    void print_expr_state_right(PgfPrinter *printer, PgfMarshaller *m, ExprState *estate);
+    void print_expr_state_right(PgfPrinter *printer, ExprState *estate);
     static
     void print_expr_state(PgfMarshaller *m, ExprState *estate);
 

From cccce4d0640e1465097b55cba06ed306251ec31f Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 4 Aug 2026 10:39:42 +0200
Subject: [PATCH 120/144] incremental chart construction

---
 src/runtime/c/pgf/data.h          |   1 +
 src/runtime/c/pgf/intervalmap.h   |   4 +-
 src/runtime/c/pgf/parser.cxx      | 392 +++++++++++++++++++++---------
 src/runtime/c/pgf/parser.h        |  64 +++--
 src/runtime/c/pgf/pgf.cxx         |   1 +
 src/runtime/c/pgf/phrasetable.cxx |   7 +-
 src/runtime/c/pgf/phrasetable.h   |   2 +-
 src/runtime/c/pgf/reader.cxx      |   2 +
 8 files changed, 328 insertions(+), 145 deletions(-)

diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h
index 05c5c3f96..cdb6b68d0 100644
--- a/src/runtime/c/pgf/data.h
+++ b/src/runtime/c/pgf/data.h
@@ -262,6 +262,7 @@ struct PGF_INTERNAL_DECL PgfSymbolCCat {
     ref<PgfConcrLincat> lincat;
     interval_t value;
     interval_t lin_idx;
+    prob_t viterbi_prob;
     PgfMetaId fid;
 };
 
diff --git a/src/runtime/c/pgf/intervalmap.h b/src/runtime/c/pgf/intervalmap.h
index e78b139f6..ce8c4cf04 100644
--- a/src/runtime/c/pgf/intervalmap.h
+++ b/src/runtime/c/pgf/intervalmap.h
@@ -12,11 +12,11 @@ class PGF_INTERNAL_DECL interval_map {
         size_t sz;
         size_t start, end, max;
 
-        V value;
-
         Node *left;
         Node *right;
 
+        V value;
+
         Node(size_t start, size_t end)
         {
             this->sz = 1;
diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index 1a5586e6f..a7d6acc63 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -1,6 +1,7 @@
 #include "data.h"
 #include "printer.h"
 #include "parser.h"
+#include <math.h>
 
 //#define DEBUG_PARSER
 //#define DEBUG_EXPRS
@@ -9,7 +10,6 @@ PgfAbstractParser::PgfAbstractParser(ref<PgfConcr> concr)
 {
     this->concr = concr;
 
-    this->first_state = NULL;
     this->current_state = NULL;
     this->initial_fid = concr->last_fid;
     this->last_fid = concr->last_fid;
@@ -54,7 +54,7 @@ PgfAbstractParser::Cont::~Cont()
 
 PgfAbstractParser::~PgfAbstractParser()
 {
-    State *state = first_state;
+    State *state = current_state;
     while (state != NULL) {
         for (auto it1 : state->completed) {
      /*       for (auto it2 : it1) {
@@ -76,22 +76,22 @@ PgfAbstractParser::~PgfAbstractParser()
     }
 }
 
-void PgfAbstractParser::process(Item *item, const PgfTextSpot &spot, bool bind)
+void PgfAbstractParser::process(Item *item, State *state)
 {
 #ifdef DEBUG_PARSER
-    print_item(item,spot);
+    print_item(item,state);
 #endif
 
     if (item->dot < item->syms.size()) {
-        symbol(item,spot,bind,item->syms[item->dot]);
+        symbol(item,state,item->syms[item->dot]);
     } else if (item->pre_alt > 0) {
         item->dot     = item->pre_dot+1;
         item->pre_alt = 0;
         item->pre_dot = 0;
         item->syms    = item->rule->syms.as_vector();
-        process(item,spot,bind);
+        process(item,state);
     } else {
-        complete(item,spot,bind);
+        complete(item,state);
     }
 }
 
@@ -99,14 +99,12 @@ PGF_INTERNAL_DECL
 int text_symbol_cmp(PgfTextSpot *spot, const uint8_t *end,
                     PgfSymbol sym, bool case_sensitive);
 
-void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym)
+void PgfAbstractParser::symbol(Item *item, State *state, PgfSymbol sym)
 {
     switch (ref<PgfSymbol>::get_tag(sym)) {
     case PgfSymbolCat::tag: {
         auto symcat = ref<PgfSymbolCat>::untagged(sym);
 
-        State *state = new_state(spot);
-
         CCat *ccat = item->args[symcat->d];
         if (ccat == NULL) {
             ref<PgfConcrLincat> lincat = 0;
@@ -125,6 +123,7 @@ void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, P
             }
 
             if (lincat != 0) {
+                size_t n_suspended1 = state->conts1.size();
                 Cont *&cont = state->conts1[lincat];
                 if (cont == NULL) {
                     cont = new Cont;
@@ -138,7 +137,7 @@ void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, P
                 auto &suspended = cont->suspended[value_i][lin_idx_i];
                 suspended.push_back(item);
 
-                suspend(cont,item,suspended.size());
+                suspend(cont,item,n_suspended1,suspended.size());
             }
         } else {
             Cont *&cont = state->conts2[ccat];
@@ -154,10 +153,24 @@ void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, P
 
             interval_t value_i   = item->interval(item->rule->args[symcat->d]);
             interval_t lin_idx_i = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
+
+            bool subsumed = false;
+            for (auto it1 : cont->suspended.overlaps(value_i)) {
+                if (it1.first.first <= value_i.first && it1.first.second >= value_i.second) {
+                    for (auto it2 : it1.second.overlaps(lin_idx_i)) {
+                        if (it2.first.first <= lin_idx_i.first && it2.first.second >= lin_idx_i.second) {
+                            subsumed = true;
+                            goto found;
+                        }
+                    }
+                }
+            }
+found:;
+
             auto &suspended = cont->suspended[value_i][lin_idx_i];
             suspended.push_back(item);
 
-            if (suspended.size() == 1) {
+            if (!subsumed && suspended.size() == 1) {
                 if (ccat->fid <= initial_fid) {
                     size_t n_items = 0;
                     vector<ref<PgfItem>> items =
@@ -165,11 +178,11 @@ void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, P
 
                     for (size_t i = 0; i < n_items; i++) {
                         ref<PgfItem> pitem = items[i];
-                        td_epsilon(state,cont,pitem,item,item->rule->args[symcat->d],ref<PgfLParam>::from_ptr(&symcat->r));
+                        td_epsilon(state,cont,pitem,item,symcat);
                     }
                 } else {
                     for (Production *prod : ccat->prods) {
-                        td_predict(state,cont,prod,item,item->rule->args[symcat->d],ref<PgfLParam>::from_ptr(&symcat->r));
+                        td_predict(state,cont,prod,item,symcat);
                     }
                 }
             } else {
@@ -194,7 +207,7 @@ void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, P
         break;
     }
     case PgfSymbolKS::tag: {
-        symbol_token(item, spot, bind, sym);
+        symbol_token(item, state, sym);
         break;
     }
     case PgfSymbolKP::tag: {
@@ -206,7 +219,9 @@ void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, P
         new_item->dot     = 0;
         new_item->syms    = symkp->default_form;
         new_item->rule    = item->rule;
-        process(new_item, spot, bind);
+        new_item->inside_prob  = item->inside_prob;
+        new_item->outside_prob = item->outside_prob;
+        process(new_item, state);
 
         for (size_t i = 0; i < symkp->alts.size(); i++) {
             Item *new_item = new(item) Item;
@@ -215,22 +230,18 @@ void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, P
             new_item->dot     = 0;
             new_item->syms    = symkp->alts[i].form;
             new_item->rule    = item->rule;
-            process(new_item, spot, bind);
+            new_item->inside_prob  = item->inside_prob;
+            new_item->outside_prob = item->outside_prob;
+            process(new_item, state);
         }
 
         delete item;
         break;
     }
-    case PgfSymbolBIND::tag: {
-        symbol_bind(item, spot, sym);
-        break;
-    }
+    case PgfSymbolBIND::tag:
     case PgfSymbolSOFTBIND::tag:
     case PgfSymbolSOFTSPACE::tag: {
-        item->dot++;
-        process(new (item) Item, spot, true);
-        process(new (item) Item, spot, false);
-        delete item;
+        symbol_bind(item, state, sym);
         break;
     }
     case PgfSymbolNE::tag:
@@ -239,15 +250,13 @@ void PgfAbstractParser::symbol(Item *item, const PgfTextSpot &spot, bool bind, P
     case PgfSymbolCAPIT::tag:
     case PgfSymbolALLCAPIT::tag:
         item->dot++;
-        process(item, spot, bind);
+        process(item, state);
         break;
     }
 }
 
-void PgfAbstractParser::complete(Item *item, const PgfTextSpot &spot, bool bind)
+void PgfAbstractParser::complete(Item *item, State *state)
 {
-    State *state = new_state(spot);
-
     switch (ref<object>::get_tag(item->rule->container)) {
     case PgfConcrLin::tag: {
         auto lin = ref<PgfConcrLin>::untagged(item->rule->container);
@@ -263,6 +272,7 @@ void PgfAbstractParser::complete(Item *item, const PgfTextSpot &spot, bool bind)
             ccat->lin_idx = lin_idx;
             ccat->value = res;
             ccat->covered = false;
+            ccat->viterbi_prob = item->inside_prob;
 
 #ifdef DEBUG_PARSER
             {
@@ -327,7 +337,7 @@ void PgfAbstractParser::complete(Item *item, const PgfTextSpot &spot, bool bind)
                         for (auto it2 : it1.second) {
                             Item *item = it2.second[0];
                             auto symcat = ref<PgfSymbolCat>::untagged(item->syms[item->dot]);
-                            td_predict(next,cont,prod,item,item->rule->args[symcat->d],ref<PgfLParam>::from_ptr(&symcat->r));
+                            td_predict(next,cont,prod,item,symcat);
                         }
                     }
                 }
@@ -492,11 +502,15 @@ void PgfAbstractParser::combine(State *state, Item *item, CCat *ccat)
     }
 
     item->dot++;
+    if (item->args[sym_cat->d] != NULL) {
+        item->inside_prob -= item->args[sym_cat->d]->viterbi_prob;
+    }
     item->args[sym_cat->d] = ccat;
-    process(item, state->start, false);
+    item->inside_prob += ccat->viterbi_prob;
+    state->push_item(item);
 }
 
-void PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref<PgfItem> pitem, Item *xitem, ref<PgfLParam> value, ref<PgfLParam> lin_idx)
+void PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref<PgfItem> pitem, Item *xitem, ref<PgfSymbolCat> symcat)
 {
     switch (ref<object>::get_tag(pitem->rule->container)) {
     case PgfConcrLin::tag: {
@@ -510,12 +524,14 @@ void PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref<PgfItem> pitem,
             item->pre_dot = 0;
             item->syms    = rule->syms.as_vector();
             item->rule    = rule;
+            item->inside_prob = lin->absfun->prob;
+            item->outside_prob = xitem->outside_prob+xitem->inside_prob-xitem->args[symcat->d]->viterbi_prob;
 
-            if (!item->instantiate(item->rule->res, xitem->rule, &xitem->vars[0], value)) {
+            if (!item->instantiate(item->rule->res, xitem->rule, &xitem->vars[0], xitem->rule->args[symcat->d])) {
                 delete item;
                 continue;
             }
-            if (!item->instantiate(item->rule->lin_idx, xitem->rule, &xitem->vars[0], lin_idx)) {
+            if (!item->instantiate(item->rule->lin_idx, xitem->rule, &xitem->vars[0], ref<PgfLParam>::from_ptr(&symcat->r))) {
                 delete item;
                 continue;
             }
@@ -533,8 +549,10 @@ void PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref<PgfItem> pitem,
                         arg_ccat->lin_idx = arg->lin_idx;
                         arg_ccat->value = arg->value;
                         arg_ccat->covered = true;
+                        arg_ccat->viterbi_prob = arg->viterbi_prob;
                     }
                     item->args[i] = arg_ccat;
+                    item->inside_prob += arg_ccat->viterbi_prob;
                 }
 
                 if (!item->instantiate(item->rule->args[i], pitem->rule, &pitem->vars[0], pitem->rule->args[i])) {
@@ -543,7 +561,7 @@ void PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref<PgfItem> pitem,
                 }
             }
 
-            process(item, state->start, false);
+            state->push_item(item);
 next:;
         }
     }
@@ -552,7 +570,7 @@ next:;
     }
 }
 
-void PgfAbstractParser::td_predict(State *state, Cont *cont, Production *prod, Item *xitem, ref<PgfLParam> value, ref<PgfLParam> lin_idx)
+void PgfAbstractParser::td_predict(State *state, Cont *cont, Production *prod, Item *xitem, ref<PgfSymbolCat> symcat)
 {
     switch (ref<object>::get_tag(prod->rule->container)) {
     case PgfConcrLin::tag: {
@@ -566,13 +584,15 @@ void PgfAbstractParser::td_predict(State *state, Cont *cont, Production *prod, I
             item->pre_dot = 0;
             item->syms    = rule->syms.as_vector();
             item->rule    = rule;
+            item->inside_prob = lin->absfun->prob;
+            item->outside_prob = xitem->outside_prob+xitem->inside_prob-xitem->args[symcat->d]->viterbi_prob;
 
-            if (!item->instantiate(item->rule->res, xitem->rule, &xitem->vars[0], value)) {
+            if (!item->instantiate(item->rule->res, xitem->rule, &xitem->vars[0], xitem->rule->args[symcat->d])) {
                 delete item;
                 continue;
             }
 
-            if (!item->instantiate(item->rule->lin_idx, xitem->rule, &xitem->vars[0], lin_idx)) {
+            if (!item->instantiate(item->rule->lin_idx, xitem->rule, &xitem->vars[0], ref<PgfLParam>::from_ptr(&symcat->r))) {
                 delete item;
                 continue;
             }
@@ -583,9 +603,12 @@ void PgfAbstractParser::td_predict(State *state, Cont *cont, Production *prod, I
                     goto next;
                 }
                 item->args[i] = prod->args[i];
+                if (item->args[i] != NULL) {
+                    item->inside_prob += item->args[i]->viterbi_prob;
+                }
             }
 
-            process(item, state->start, false);
+            state->push_item(item);
 next:;
         }
     }
@@ -634,11 +657,11 @@ void print_symbols(PgfPrinter &printer, PgfConcrRule *rule, vector<PgfSymbol> sy
         printer.puts(" . ");
 }
 
-void PgfAbstractParser::print_item(Item *item, const PgfTextSpot &spot)
+void PgfAbstractParser::print_item(Item *item, State *state)
 {
     PgfPrinter printer(NULL,0,NULL);
 
-    printer.nprintf(32, "[%zd-%zd; ", item->cont ? item->cont->state->end.pos : 0, spot.pos);
+    printer.nprintf(32, "[%zd-%zd; ", item->cont ? item->cont->state->end.pos : 0, state->start.pos);
 
     if (item->vars.size() > 0) {
         printer.lvar_ranges(item->rule->ranges, &item->vars[0]);
@@ -703,7 +726,7 @@ void PgfAbstractParser::print_item(Item *item, const PgfTextSpot &spot)
     printer.lparam(item->rule->lin_idx);
     printer.puts(" : ");
     print_symbols(printer, item->rule, item->syms, item->pre_alt, item->pre_dot, item->dot);
-    printer.puts("]");
+    printer.nprintf(40,"; %f+%f=%f]", item->inside_prob, item->outside_prob, item->inside_prob+item->outside_prob);
 
     PgfText *text = printer.get_text();
     fprintf(stderr, "%s\n", text->text);
@@ -780,14 +803,16 @@ PgfParser::PgfParser(ref<PgfConcr> concr, PgfText *sentence, bool case_sensitive
 {
     this->m = m;
     this->u = u;
-    this->sentence = sentence;
-    this->end = (uint8_t *) (sentence->text+sentence->size);
+    this->sentence = textdup(sentence);
+    this->end = (uint8_t *) (this->sentence->text+this->sentence->size);
     this->case_sensitive = case_sensitive;
 }
 
 PgfParser::~PgfParser()
 {
-    State *state = first_state;
+    free(sentence);
+
+    State *state = current_state;
     while (state != NULL) {
         for (auto it1 : state->completed) {
             for (auto it2 : it1.second) {
@@ -832,13 +857,7 @@ void PgfParser::bu_predict(PgfPhrasetable phrasetable,
         return;
 
     PgfTextSpot current = state->end;
-    int cmp;
-    if (state->needs_bind) {
-        uint8_t tag = ref<PgfSymbol>::get_tag(phrasetable->sym);
-        cmp = ((int) PgfSymbolBIND::tag) - ((int) tag);
-    } else {
-        cmp = text_symbol_cmp(&current,end,phrasetable->sym,case_sensitive);
-    }
+    int cmp = text_symbol_cmp(&current,end,phrasetable->sym,case_sensitive);
     if (cmp < 0) {
         bu_predict(phrasetable->left,state,min,max);
     } else if (cmp > 0) {
@@ -856,16 +875,14 @@ void PgfParser::bu_predict(PgfPhrasetable phrasetable,
             bu_predict(phrasetable->left,state,min,len);
 
         if (len > 0) {
-            if (*current.ptr != ' ' && *current.ptr != 0)
-                return;
-
+            State *next_state = new_state(current);
             for (size_t i = 0; i < phrasetable->n_items; i++) {
                 std::map<ref<PgfConcrLincat>, bool> visited;
                 //if (!td_reachable(state, phrasetable->items[i], visited))
                 //    continue;
                 Item *item = bu_item(state, phrasetable->items[i]);
                 item->dot++;
-                process(item, current, false);
+                next_state->push_item(item);
             }
         }
 
@@ -874,6 +891,42 @@ void PgfParser::bu_predict(PgfPhrasetable phrasetable,
      }
 }
 
+void PgfParser::bu_predict(PgfPhrasetable phrasetable,
+                           State *state)
+{
+    if (phrasetable == 0)
+        return;
+
+    PgfTextSpot current = state->end;
+    int cmp;
+    uint8_t tag = ref<PgfSymbol>::get_tag(phrasetable->sym);
+    cmp = ((int) PgfSymbolBIND::tag) - ((int) tag);
+    if (cmp < 0) {
+        bu_predict(phrasetable->left,state);
+    } else if (cmp > 0) {
+        bu_predict(phrasetable->right,state);
+    } else {
+        State *next_state = state->next;
+        if (next_state == NULL || state->end.pos != next_state->start.pos) {
+            next_state = new State;
+            next_state->start = state->end;
+            next_state->end   = state->end;
+            next_state->next  = state->next;
+            next_state->needs_bind = false;
+            state->next = next_state;
+        }
+
+        for (size_t i = 0; i < phrasetable->n_items; i++) {
+            std::map<ref<PgfConcrLincat>, bool> visited;
+            //if (!td_reachable(state, phrasetable->items[i], visited))
+            //    continue;
+            Item *item = bu_item(state, phrasetable->items[i]);
+            item->dot++;
+            next_state->push_item(item);
+        }
+    }
+}
+
 void PgfParser::bu_predict(State *state, CCat *ccat)
 {
     size_t n_items = 0;
@@ -944,6 +997,8 @@ PgfAbstractParser::Item *PgfParser::bu_item(State *state, ref<PgfItem> pitem)
         item->dot     = pitem->dot;
         item->syms    = pitem->rule->syms.as_vector();
         item->rule    = pitem->rule;
+        item->inside_prob = lin->absfun->prob;
+        item->outside_prob = 0;
         break;
     }
     case PgfConcrLincat::tag: {
@@ -964,6 +1019,8 @@ PgfAbstractParser::Item *PgfParser::bu_item(State *state, ref<PgfItem> pitem)
         item->dot     = pitem->dot;
         item->syms    = pitem->rule->syms.as_vector();
         item->rule    = pitem->rule;
+        item->inside_prob = 0;
+        item->outside_prob = 0;
         break;
     }
     }
@@ -994,8 +1051,10 @@ PgfAbstractParser::Item *PgfParser::bu_item(State *state, ref<PgfItem> pitem)
                 arg_ccat->lin_idx = arg->lin_idx;
                 arg_ccat->value = arg->value;
                 arg_ccat->covered = true;
+                arg_ccat->viterbi_prob = arg->viterbi_prob;
             }
             item->args[i] = arg_ccat;
+            item->inside_prob += arg_ccat->viterbi_prob;
         }
     }
 
@@ -1014,6 +1073,7 @@ void PgfParser::make_chunks(State *state, std::vector<CCat*> &chunks, prob_t pro
         estate->n_args = chunks.size();
         for (size_t i = 0; i < estate->n_args; i++) {
             estate->args[i] = chunks[estate->n_args-i-1];
+            estate->prob += estate->args[i]->viterbi_prob;
         }
         queue.push_back(estate);
         std::push_heap(queue.begin(), queue.end(), estate_comp);
@@ -1041,8 +1101,6 @@ void PgfParser::prepare(ref<PgfConcrLincat> start)
 
     PgfTextSpot start_spot = {0, (uint8_t *) sentence->text};
     State *state = new_state(start_spot);
-    state->needs_bind = false;
-    current_state = state;
 
     for (size_t i = start->n_lindefs; i < start->rules.size(); i++) {
         ref<PgfConcrRule> rule = start->rules[i];
@@ -1053,18 +1111,9 @@ void PgfParser::prepare(ref<PgfConcrLincat> start)
         item->pre_dot = 0;
         item->syms    = rule->syms.as_vector();
         item->rule    = rule;
-        process(item, start_spot, false);
-    }
-
-    while (current_state != NULL) {
-        bu_predict(concr->phrasetable, current_state, 1, sentence->size);
-        state = current_state;
-        current_state = current_state->next;
-    }
-
-    if (queue.size() == 0) {
-        std::vector<CCat*> chunks;
-        make_chunks(state, chunks, 0);
+        item->inside_prob  = 0;
+        item->outside_prob = 0;
+        state->push_item(item);
     }
 }
 
@@ -1072,6 +1121,57 @@ PgfExpr PgfParser::fetch(PgfDB *db, prob_t *prob)
 {
     DB_scope scope(db, READER_SCOPE);
 
+    bool first_fetch = (initial_fid == last_fid);
+
+    for (;;) {
+        State *state = current_state;
+        prob_t min_prob  = INFINITY;
+        State *min_state = NULL;
+        if (queue.size() > 0) {
+            min_prob = queue.front()->prob;
+        }
+
+        while (state != NULL) {
+            if (state->queue.size() > 0) {
+                Item *item = state->queue.front();
+                prob_t prob = item->outside_prob + item->inside_prob;
+                if (min_prob > prob) {
+                    min_prob  = prob;
+                    min_state = state;
+                }
+            }
+            state = state->next;
+        }
+
+        if (min_state == NULL)
+            break;
+
+        State *prev = current_state;
+        current_state = NULL;
+        while (current_state != min_state) {
+            State *next = prev->next;
+            prev->next = current_state;
+            current_state = prev;
+            prev = next;
+        }
+
+        Item *item = current_state->pop_item();
+        process(item,current_state);
+
+        while (current_state != NULL) {
+            State *next = current_state->next;
+            current_state->next = prev;
+            prev = current_state;
+            current_state = next;
+        }
+        current_state = prev;
+    }
+
+    if (first_fetch && queue.size() == 0) {
+        std::vector<CCat*> chunks;
+        make_chunks(current_state, chunks, 0);
+    }
+
     while (queue.size() > 0) {
         ExprState *estate = queue.front();
         std::pop_heap(queue.begin(), queue.end(), estate_comp);
@@ -1122,7 +1222,7 @@ PgfExpr PgfParser::process_expr(ExprState *estate, prob_t *prob)
 
                         ExprState *new_estate = new(pitem->args.size()) ExprState;
                         new_estate->expr   = u->efun(&lin->name);
-                        new_estate->prob   = estate->prob+lin->absfun->prob;
+                        new_estate->prob   = estate->prob-ccat->viterbi_prob+lin->absfun->prob;
                         new_estate->hash   = 0;
                         new_estate->res    = ccat;
                         new_estate->index  = 0;
@@ -1143,8 +1243,10 @@ PgfExpr PgfParser::process_expr(ExprState *estate, prob_t *prob)
                                     arg_ccat->lin_idx = arg->lin_idx;
                                     arg_ccat->value = arg->value;
                                     arg_ccat->covered = true;
+                                    arg_ccat->viterbi_prob = arg->viterbi_prob;
                                 }
                                 new_estate->args[i] = arg_ccat;
+                                new_estate->prob += arg_ccat->viterbi_prob;
                             }
                         }
                         queue.push_back(new_estate);
@@ -1156,7 +1258,7 @@ PgfExpr PgfParser::process_expr(ExprState *estate, prob_t *prob)
 
                         ExprState *new_estate = new(prod->args.size()) ExprState;
                         new_estate->expr   = u->efun(&lin->name);
-                        new_estate->prob   = estate->prob+lin->absfun->prob;
+                        new_estate->prob   = estate->prob-ccat->viterbi_prob+lin->absfun->prob;
                         new_estate->hash   = 0;
                         new_estate->res    = ccat;
                         new_estate->index  = 0;
@@ -1166,6 +1268,9 @@ PgfExpr PgfParser::process_expr(ExprState *estate, prob_t *prob)
                         }
                         for (size_t i = 0; i < new_estate->n_args; i++) {
                             new_estate->args[i] = prod->args[i];
+                            if (prod->args[i] != NULL) {
+                                new_estate->prob += prod->args[i]->viterbi_prob;
+                            }
                         }
                         queue.push_back(new_estate);
                         std::push_heap(queue.begin(), queue.end(), estate_comp);
@@ -1175,7 +1280,7 @@ PgfExpr PgfParser::process_expr(ExprState *estate, prob_t *prob)
                 for (ExprProb ep : ccat->exprs) {
                     ExprState *app_state = new(estate->n_args) ExprState;
                     app_state->expr  = estate->expr ? u->eapp(estate->expr, ep.expr) : ep.expr;
-                    app_state->prob  = estate->prob+ep.prob;
+                    app_state->prob  = estate->prob-ccat->viterbi_prob+ep.prob;
                     app_state->hash  = estate->hash * 31 + ep.hash;
                     app_state->res   = estate->res;
                     app_state->index = estate->index+1;
@@ -1194,7 +1299,7 @@ PgfExpr PgfParser::process_expr(ExprState *estate, prob_t *prob)
             return estate->expr;
         }
 
-        prob_t prob = estate->prob - estate->res->pending[0]->prob;
+        prob_t prob = estate->prob - (estate->res->pending[0]->prob-estate->res->viterbi_prob);
         for (size_t i = estate->res->exprs.size(); i > 0; i--) {
             ExprProb &ep = estate->res->exprs[i-1];
             if (ep.prob != prob)
@@ -1207,7 +1312,7 @@ PgfExpr PgfParser::process_expr(ExprState *estate, prob_t *prob)
         for (ExprState *parent : estate->res->pending) {
             ExprState *app_state = new(parent->n_args) ExprState;
             app_state->expr  = parent->expr ? u->eapp(parent->expr, estate->expr) : estate->expr;
-            app_state->prob  = parent->prob+prob;
+            app_state->prob  = parent->prob-estate->res->viterbi_prob+prob;
             app_state->hash  = parent->hash * 31 + estate->hash;
             app_state->res   = parent->res;
             app_state->index = parent->index+1;
@@ -1224,7 +1329,7 @@ PgfExpr PgfParser::process_expr(ExprState *estate, prob_t *prob)
 
 PgfAbstractParser::State *PgfParser::new_state(const PgfTextSpot &start)
 {
-    State **prev = &first_state;
+    State **prev = &current_state;
     State *state = current_state;
     while (state != NULL && state->start.ptr <= start.ptr) {
         if (state->start.ptr == start.ptr)
@@ -1248,42 +1353,48 @@ PgfAbstractParser::State *PgfParser::new_state(const PgfTextSpot &start)
         state->end.ptr = ptr;
     }
 
-    state->needs_bind = (state->start.pos == state->end.pos);
+    state->needs_bind = (state->start.pos > 0 && state->start.pos == state->end.pos);
 
     return state;
 }
 
-void PgfParser::symbol_token(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym)
+void PgfParser::symbol_token(Item *item, State *state, PgfSymbol sym)
 {
-    PgfTextSpot next = spot;
-
-    const uint8_t *start = next.ptr;
-    for (;;) {
-        const uint8_t *ptr = next.ptr;
-        uint32_t ucs = pgf_utf8_decode(&ptr);
-        if (!pgf_utf8_is_space(ucs))
-            break;
-        next.ptr = ptr;
-        next.pos++;
-    }
-
-    if (bind != (spot.ptr == next.ptr))
-        return;
-
+    PgfTextSpot next = state->end;
     if (text_symbol_cmp(&next,end,sym,case_sensitive) != 0)
         return;
 
+    State *next_state = new_state(next);
+
     item->dot++;
-    process(item, next, false);
+    process(item, next_state);
 }
 
-void PgfParser::symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym)
+void PgfParser::symbol_bind(Item *item, State *state, PgfSymbol sym)
 {
-    item->dot++;
-    process(item, spot, true);
+    if (state->needs_bind) {
+        State *next_state = state->next;
+        if (next_state == NULL || state->end.pos != next_state->start.pos) {
+            next_state = new State;
+            next_state->start = state->end;
+            next_state->end   = state->end;
+            next_state->next  = state->next;
+            next_state->needs_bind = false;
+            state->next = next_state;
+        }
+        item->dot++;
+        next_state->push_item(item);
+    } else {
+        if (ref<PgfSymbol>::get_tag(sym) == PgfSymbolBIND::tag) {
+            delete item;
+        } else {
+            item->dot++;
+            process(item, state);
+        }
+    }
 }
 
-void PgfParser::suspend(Cont *cont,Item *item,size_t n_suspended)
+void PgfParser::suspend(Cont *cont,Item *item,size_t n_suspended1,size_t n_suspended)
 {
     if (n_suspended == 1) {
         std::function<void(ref<PgfSymbolCCat>,size_t,vector<ref<PgfItem>>)> f =
@@ -1312,26 +1423,40 @@ void PgfParser::suspend(Cont *cont,Item *item,size_t n_suspended)
                     arg_ccat->lin_idx = symcf->lin_idx;
                     arg_ccat->value = symcf->value;
                     arg_ccat->covered = true;
+                    arg_ccat->viterbi_prob = symcf->viterbi_prob;
                 }
 
                 cont->state->completed[cont][symcf->value][symcf->lin_idx] = arg_ccat;
 
                 new_item->dot++;
                 new_item->args[sym_cat->d] = arg_ccat;
+                new_item->inside_prob += arg_ccat->viterbi_prob;
 
-                process(new_item, cont->state->start, false);
+                cont->state->push_item(new_item);
             };
         phrasetable_iter(concr->phrasetable,cont->lincat,f);
-    } else {
-        auto it1 = cont->state->completed.find(cont);
-        if (it1 != cont->state->completed.end()) {
+    }
+
+    State *state = cont->state;
+    while (state != NULL) {
+        auto it1 = state->completed.find(cont);
+        if (it1 != state->completed.end()) {
             for (auto it2 : it1->second) {
                 for (auto it3 : it2.second) {
                     Item *new_item = new (item) Item;
-                    combine(cont->state, new_item, it3.second);
+                    combine(state, new_item, it3.second);
                 }
             }
         }
+        state = state->next;
+    }
+
+    if (n_suspended1 == 0) {
+        if (cont->state->needs_bind) {
+            bu_predict(concr->phrasetable, cont->state);
+        } else {
+            bu_predict(concr->phrasetable, cont->state, 1, sentence->size);
+        }
     }
 }
 
@@ -1347,6 +1472,7 @@ void PgfParser::final_item(State *state, CCat *ccat, Item *item, interval_t valu
         estate->n_args = item->args.size();
         for (size_t i = 0; i < estate->n_args; i++) {
             estate->args[i] = item->args[i];
+            estate->prob += estate->args[i]->viterbi_prob;
         }
         queue.push_back(estate);
         std::push_heap(queue.begin(), queue.end(), estate_comp);
@@ -1390,7 +1516,15 @@ void PgfParser::print_expr_state(PgfMarshaller *m, ExprState *estate)
     PgfPrinter printer(NULL,0,m);
     printer.nprintf(64,"[%f] ",estate->prob);
     print_expr_state_left(&printer, m, estate);
-    printer.puts(" .");
+    printer.puts(" . ");
+
+    if (estate->index < estate->n_args) {
+        if (estate->args[estate->index] != NULL)
+            printer.emeta(estate->args[estate->index]->fid);
+        else
+            printer.puts("?");
+    }
+
     print_expr_state_right(&printer, estate);
 
     PgfText *text = printer.get_text();
@@ -1402,12 +1536,11 @@ void PgfParser::print_expr_state(PgfMarshaller *m, ExprState *estate)
 PgfParseTableMaker::PgfParseTableMaker(ref<PgfConcr> concr)
     : PgfAbstractParser(concr)
 {
-    first_state = new State;
-    first_state->start.pos = 0;
-    first_state->start.ptr = NULL;
-    first_state->end       = first_state->start;
-    first_state->next      = NULL;
-    current_state = first_state;
+    current_state = new State;
+    current_state->start.pos = 0;
+    current_state->start.ptr = NULL;
+    current_state->end       = current_state->start;
+    current_state->next      = NULL;
 }
 
 ref<PgfItem> PgfParseTableMaker::clone_item(Item *item)
@@ -1421,7 +1554,7 @@ ref<PgfItem> PgfParseTableMaker::clone_item(Item *item)
     pitem->dot     = item->dot;
     pitem->rule    = item->rule;
     memcpy(&pitem->vars[0],&item->vars[0],sizeof(size_t) * item->vars.size());
-    
+
     for (size_t i = 0; i < item->args.size(); i++) {
         ref<PgfSymbolCCat> symcf = 0;
         if (item->args[i] != NULL) {
@@ -1430,6 +1563,7 @@ ref<PgfItem> PgfParseTableMaker::clone_item(Item *item)
             symcf->value   = item->args[i]->value;
             symcf->lin_idx = item->args[i]->lin_idx;
             symcf->fid     = item->args[i]->fid;
+            symcf->viterbi_prob = item->args[i]->viterbi_prob;
         }
         pitem->args[i] = symcf;
     }
@@ -1439,10 +1573,10 @@ ref<PgfItem> PgfParseTableMaker::clone_item(Item *item)
 
 PgfAbstractParser::State *PgfParseTableMaker::new_state(const PgfTextSpot &start)
 {
-    return this->first_state;
+    return current_state;
 }
 
-void PgfParseTableMaker::symbol_token(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym)
+void PgfParseTableMaker::symbol_token(Item *item, State *state, PgfSymbol sym)
 {
     auto pitem = clone_item(item);
     auto phrasetable = phrasetable_insert(concr->phrasetable,sym,pitem);
@@ -1450,15 +1584,21 @@ void PgfParseTableMaker::symbol_token(Item *item, const PgfTextSpot &spot, bool
     delete item;
 }
 
-void PgfParseTableMaker::symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym)
+void PgfParseTableMaker::symbol_bind(Item *item, State *state, PgfSymbol sym)
 {
     auto pitem = clone_item(item);
-    auto phrasetable = phrasetable_insert(concr->phrasetable,sym,pitem);
+    auto phrasetable = phrasetable_insert(concr->phrasetable,ref<PgfSymbolBIND>(0).tagged(),pitem);
     concr->phrasetable = phrasetable;
-    delete item;
+
+    if (ref<PgfSymbol>::get_tag(sym) == PgfSymbolBIND::tag) {
+        delete item;
+    } else {
+        item->dot++;
+        process(item,state);
+    }
 }
 
-void PgfParseTableMaker::suspend(Cont *cont,Item *item,size_t n_suspended)
+void PgfParseTableMaker::suspend(Cont *cont,Item *item,size_t n_suspended1,size_t n_suspended)
 {
     // collect the cats first, since calling combine in
     // the loop will change the search index
@@ -1488,7 +1628,7 @@ void PgfParseTableMaker::final_item(State *state, CCat *ccat, Item *item, interv
     
     PgfPhrasetable phrasetable = concr->phrasetable;
     phrasetable = phrasetable_insert(phrasetable,
-                                     item->cont->lincat, value, lin_idx, ccat->fid,
+                                     item->cont->lincat, value, lin_idx, ccat->fid, ccat->viterbi_prob,
                                      pitem);
     concr->phrasetable = phrasetable;
 }
@@ -1503,12 +1643,12 @@ void PgfParseTableMaker::insert_rule(ref<PgfConcrRule> rule)
     case PgfConcrLin::tag: {
         auto lin = ref<PgfConcrLin>::untagged(rule->container);
 
-        Cont *&cont = first_state->conts1[lin->lincat];
+        Cont *&cont = current_state->conts1[lin->lincat];
         if (cont == NULL) {
             cont = new Cont;
             cont->ccat = NULL;
             cont->lincat = lin->lincat;
-            cont->state = first_state;
+            cont->state = current_state;
         }
 
         Item *item = new(rule) Item;
@@ -1518,7 +1658,17 @@ void PgfParseTableMaker::insert_rule(ref<PgfConcrRule> rule)
         item->pre_dot = 0;
         item->syms    = rule->syms.as_vector();
         item->rule    = rule;
-        return process(item, first_state->end, false);
+        item->inside_prob = lin->absfun->prob;
+        item->outside_prob = 0;
+        current_state->push_item(item);
     }
     }
 }
+
+void PgfParseTableMaker::prepare()
+{
+    while (current_state->has_items()) {
+        Item *item = current_state->pop_item();
+        process(item,current_state);
+    }
+}
diff --git a/src/runtime/c/pgf/parser.h b/src/runtime/c/pgf/parser.h
index 35a799682..72403733a 100644
--- a/src/runtime/c/pgf/parser.h
+++ b/src/runtime/c/pgf/parser.h
@@ -89,6 +89,7 @@ protected:
         State *state;
         interval_t value;
         interval_t lin_idx;
+        prob_t viterbi_prob;
         bool covered;
         std::vector<Production*> prods;
         std::vector<ExprState*> pending;
@@ -103,8 +104,25 @@ protected:
         std::map<ref<PgfConcrLincat>,Cont*> conts1;
         std::map<CCat*,Cont*> conts2;
         std::map<Cont*,interval_map<interval_map<CCat*>>> completed;
-        
+        std::vector<Item*> queue;
+
         State *next;
+
+        bool has_items() {
+            return queue.size() > 0;
+        }
+
+        void push_item(Item *item) {
+            queue.push_back(item);
+            std::push_heap(queue.begin(), queue.end(), item_comp);
+        }
+
+        Item *pop_item() {
+            Item *item = queue.front();
+            std::pop_heap(queue.begin(), queue.end(), item_comp);
+            queue.pop_back();
+            return item;
+        }
     };
 
     struct Cont {
@@ -123,6 +141,8 @@ protected:
         uint16_t dot;
         vector<PgfSymbol> syms;
         ref<PgfConcrRule> rule;
+        prob_t inside_prob;
+        prob_t outside_prob;
 
         struct {
             size_t &operator[](int i) const {
@@ -177,6 +197,12 @@ protected:
                          PgfConcrRule *rule, size_t *values, ref<PgfLParam> lparam2);
     };
 
+    static struct ItemComparator : std::less<Item*> {
+        bool operator()(Item *item1, Item *item2) {
+            return item1->inside_prob+item1->outside_prob > item2->inside_prob+item2->outside_prob;
+        }
+    } item_comp;
+
     struct ExprState {
         PgfExpr expr;
         prob_t prob;
@@ -204,29 +230,29 @@ protected:
         }
     };
 
-    State *first_state, *current_state;
+    State *current_state;
     std::map<ref<PgfConcrLincat>,interval_map<interval_map<CCat*>>> epsilons;
     PgfMetaId initial_fid, last_fid;
 
-    void process(Item *item, const PgfTextSpot &spot, bool bind);
-    void symbol(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym);
-    void complete(Item *item, const PgfTextSpot &spot, bool bind);
+    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)=0;
-    virtual void symbol_token(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym)=0;
-    virtual void symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym)=0;
-    virtual void suspend(Cont *cont, Item *item, size_t n_suspended)=0;
+    virtual void symbol_token(Item *item, State *state, PgfSymbol sym)=0;
+    virtual void symbol_bind(Item *item, State *state, PgfSymbol sym)=0;
+    virtual void suspend(Cont *cont, Item *item, size_t n_suspended1, size_t n_suspended)=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, CCat *ccat)=0;
 
-    void td_epsilon(State *state, Cont *cont, ref<PgfItem> pitem, Item *xitem, ref<PgfLParam> value, ref<PgfLParam> lin_idx);
-    void td_predict(State *state, Cont *cont, Production *prod, Item *xitem, ref<PgfLParam> value, ref<PgfLParam> lin_idx);
+    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);
 
     void get_info(CCat *ccat, ref<PgfConcrRule> *rule, size_t **pvalues);
 
     static
-    void print_item(Item *item, const PgfTextSpot &spot);
+    void print_item(Item *item, State *state);
 
     static
     void print_prod(CCat *ccat, Production *prod);
@@ -245,12 +271,13 @@ class PGF_INTERNAL_DECL PgfParser : private PgfAbstractParser, public PgfExprEnu
     bool case_sensitive;
 
     virtual State *new_state(const PgfTextSpot &start);
-    virtual void symbol_token(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym);
-    virtual void symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym);
-    virtual void suspend(Cont *cont,Item *item,size_t n_suspended);
+    virtual void symbol_token(Item *item, State *state, PgfSymbol sym);
+    virtual void symbol_bind(Item *item, State *state, PgfSymbol sym);
+    virtual void suspend(Cont *cont,Item *item,size_t n_suspended1,size_t n_suspended);
     virtual void final_item(State *state,CCat *ccat,Item *item,interval_t value,interval_t lin_idx);
     virtual void bu_predict(State *state, CCat *ccat);
 
+    void bu_predict(PgfPhrasetable phrasetable, State *state);
     void bu_predict(PgfPhrasetable phrasetable, State *state, 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);
@@ -265,7 +292,7 @@ class PGF_INTERNAL_DECL PgfParser : private PgfAbstractParser, public PgfExprEnu
     static
     void print_expr_state(PgfMarshaller *m, ExprState *estate);
 
-    struct ExprStateComparator : std::less<ExprState*> {
+    static struct ExprStateComparator : std::less<ExprState*> {
         bool operator()(ExprState *estate1, ExprState *estate2) {
             return estate1->prob > estate2->prob;
         }
@@ -286,9 +313,9 @@ class PGF_INTERNAL_DECL PgfParseTableMaker : private PgfAbstractParser
 {
 private:
     virtual State *new_state(const PgfTextSpot &start);
-    virtual void symbol_token(Item *item, const PgfTextSpot &spot, bool bind, PgfSymbol sym);
-    virtual void symbol_bind(Item *item, const PgfTextSpot &spot, PgfSymbol sym);
-    virtual void suspend(Cont *cont, Item *item, size_t n_suspended);
+    virtual void symbol_token(Item *item, State *state, PgfSymbol sym);
+    virtual void symbol_bind(Item *item, State *state, PgfSymbol sym);
+    virtual void suspend(Cont *cont, Item *item, size_t n_suspended1, size_t n_suspended);
     virtual void final_item(State *state, CCat *ccat,Item *item,interval_t value,interval_t lin_idx);
     virtual void bu_predict(State *state, CCat *ccat);
 
@@ -298,6 +325,7 @@ private:
 public:
     PgfParseTableMaker(ref<PgfConcr> concr);
     void insert_rule(ref<PgfConcrRule> rule);
+    void prepare();
     PgfMetaId get_last_fid() { return last_fid; };
 };
 
diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx
index 8c473327c..4b42df273 100644
--- a/src/runtime/c/pgf/pgf.cxx
+++ b/src/runtime/c/pgf/pgf.cxx
@@ -1726,6 +1726,7 @@ void pgf_free_parse_table(PgfDB *db,
     ref<PgfPGF> pgf = db->revision2pgf(revision);
     ref<PgfConcr> concr = db->revision2concr(cnc_revision);
 
+    table_maker->prepare();
     concr->last_fid = table_maker->get_last_fid();
     delete table_maker;
 }
diff --git a/src/runtime/c/pgf/phrasetable.cxx b/src/runtime/c/pgf/phrasetable.cxx
index 9063bf4cf..d98b97a7e 100644
--- a/src/runtime/c/pgf/phrasetable.cxx
+++ b/src/runtime/c/pgf/phrasetable.cxx
@@ -1001,7 +1001,7 @@ PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
 PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
                                   ref<PgfConcrLincat> lincat,
                                   interval_t value, interval_t lin_idx,
-                                  PgfMetaId fid,
+                                  PgfMetaId fid, prob_t viterbi_prob,
                                   ref<PgfItem> item)
 {
     if (table == 0) {
@@ -1010,6 +1010,7 @@ PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
         symcf->value   = value;
         symcf->lin_idx = lin_idx;
         symcf->fid = fid;
+        symcf->viterbi_prob = viterbi_prob;
         PgfPhrasetable new_table = PgfPhrasetableNode::new_node(symcf.tagged(),1);
         new_table->n_items = 1;
         new_table->items[0] = item;
@@ -1019,12 +1020,12 @@ PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
     int cmp = symbol_cmp(lincat,value,lin_idx,table->sym);
     if (cmp < 0) {
         PgfPhrasetable left = phrasetable_insert(table->left,
-                                                lincat, value, lin_idx, fid, item);
+                                                lincat, value, lin_idx, fid, viterbi_prob, item);
         table = PgfPhrasetableNode::upd_node(table,left,table->right);
         return PgfPhrasetableNode::balanceL(table);
     } else if (cmp > 0) {
         PgfPhrasetable right = phrasetable_insert(table->right,
-                                                  lincat, value, lin_idx, fid, item);
+                                                  lincat, value, lin_idx, fid, viterbi_prob, item);
         table = PgfPhrasetableNode::upd_node(table, table->left, right);
         return PgfPhrasetableNode::balanceR(table);
     } else {
diff --git a/src/runtime/c/pgf/phrasetable.h b/src/runtime/c/pgf/phrasetable.h
index f54b61bb2..acf718616 100644
--- a/src/runtime/c/pgf/phrasetable.h
+++ b/src/runtime/c/pgf/phrasetable.h
@@ -91,7 +91,7 @@ PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
 PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
                                   ref<PgfConcrLincat> lincat,
                                   interval_t value, interval_t lin_idx,
-                                  PgfMetaId fid,
+                                  PgfMetaId fid, prob_t viterbi_prob,
                                   ref<PgfItem> item);
 
 PGF_INTERNAL_DECL
diff --git a/src/runtime/c/pgf/reader.cxx b/src/runtime/c/pgf/reader.cxx
index cb1e5199a..f8ec65453 100644
--- a/src/runtime/c/pgf/reader.cxx
+++ b/src/runtime/c/pgf/reader.cxx
@@ -712,6 +712,8 @@ 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;
 

From 6307d37d0f2d5f4bf9967c573544d566e13be76c Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 4 Aug 2026 11:09:40 +0200
Subject: [PATCH 121/144] simplification

---
 src/runtime/c/pgf/parser.cxx | 10 ++--------
 1 file changed, 2 insertions(+), 8 deletions(-)

diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index a7d6acc63..186eb164a 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -1600,21 +1600,15 @@ void PgfParseTableMaker::symbol_bind(Item *item, State *state, PgfSymbol sym)
 
 void PgfParseTableMaker::suspend(Cont *cont,Item *item,size_t n_suspended1,size_t n_suspended)
 {
-    // collect the cats first, since calling combine in
-    // the loop will change the search index
-    std::vector<CCat*> ccats;
     for (auto it1 : cont->state->completed[cont]) {
         for (auto it2 : it1.second) {
             CCat *ccat = it2.second;
             if (ccat != NULL) {
-                ccats.push_back(ccat);
+                Item *new_item = new (item) Item;
+                combine(cont->state,new_item,ccat);
             }
         }
     }
-    for (CCat *ccat :  ccats) {
-        Item *new_item = new (item) Item;
-        combine(cont->state,new_item,ccat);
-    }
 
     auto pitem = clone_item(item);
     auto acat  = ref<PgfSymbolACat>::from_ptr((PgfSymbolACat*) &cont->lincat->name);

From 21c5280908c63d42f69a2308ab1921cc461a8dd6 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 4 Aug 2026 15:20:51 +0200
Subject: [PATCH 122/144] reuse the namespace Node for the phrasetable

---
 src/runtime/c/pgf/parser.cxx      |  12 +-
 src/runtime/c/pgf/phrasetable.cxx | 313 +++++-------------------------
 src/runtime/c/pgf/phrasetable.h   |  40 +---
 3 files changed, 57 insertions(+), 308 deletions(-)

diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index 186eb164a..aeff7c50e 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -857,7 +857,7 @@ void PgfParser::bu_predict(PgfPhrasetable phrasetable,
         return;
 
     PgfTextSpot current = state->end;
-    int cmp = text_symbol_cmp(&current,end,phrasetable->sym,case_sensitive);
+    int cmp = text_symbol_cmp(&current,end,phrasetable->value.sym,case_sensitive);
     if (cmp < 0) {
         bu_predict(phrasetable->left,state,min,max);
     } else if (cmp > 0) {
@@ -876,11 +876,11 @@ void PgfParser::bu_predict(PgfPhrasetable phrasetable,
 
         if (len > 0) {
             State *next_state = new_state(current);
-            for (size_t i = 0; i < phrasetable->n_items; i++) {
+            for (size_t i = 0; i < phrasetable->value.n_items; i++) {
                 std::map<ref<PgfConcrLincat>, bool> visited;
                 //if (!td_reachable(state, phrasetable->items[i], visited))
                 //    continue;
-                Item *item = bu_item(state, phrasetable->items[i]);
+                Item *item = bu_item(state, phrasetable->value.items[i]);
                 item->dot++;
                 next_state->push_item(item);
             }
@@ -899,7 +899,7 @@ void PgfParser::bu_predict(PgfPhrasetable phrasetable,
 
     PgfTextSpot current = state->end;
     int cmp;
-    uint8_t tag = ref<PgfSymbol>::get_tag(phrasetable->sym);
+    uint8_t tag = ref<PgfSymbol>::get_tag(phrasetable->value.sym);
     cmp = ((int) PgfSymbolBIND::tag) - ((int) tag);
     if (cmp < 0) {
         bu_predict(phrasetable->left,state);
@@ -916,11 +916,11 @@ void PgfParser::bu_predict(PgfPhrasetable phrasetable,
             state->next = next_state;
         }
 
-        for (size_t i = 0; i < phrasetable->n_items; i++) {
+        for (size_t i = 0; i < phrasetable->value.n_items; i++) {
             std::map<ref<PgfConcrLincat>, bool> visited;
             //if (!td_reachable(state, phrasetable->items[i], visited))
             //    continue;
-            Item *item = bu_item(state, phrasetable->items[i]);
+            Item *item = bu_item(state, phrasetable->value.items[i]);
             item->dot++;
             next_state->push_item(item);
         }
diff --git a/src/runtime/c/pgf/phrasetable.cxx b/src/runtime/c/pgf/phrasetable.cxx
index d98b97a7e..a7d17152d 100644
--- a/src/runtime/c/pgf/phrasetable.cxx
+++ b/src/runtime/c/pgf/phrasetable.cxx
@@ -394,223 +394,6 @@ int symbol_cmp(PgfSymbol sym1, PgfSymbol sym2)
     }
 }
 
-ref<PgfPhrasetableNode> PgfPhrasetableNode::new_node(PgfSymbol sym, size_t n_items)
-{
-    auto items = vector<ref<PgfItem>>::alloc(n_items);
-
-    auto node = PgfDB::malloc<PgfPhrasetableNode>();
-    node->sym     = sym;
-    node->n_items = 0;
-    node->items   = items;
-    node->txn_id  = PgfDB::get_txn_id();
-    node->sz      = 1;
-    node->left    = 0;
-    node->right   = 0;
-    
-    return node;
-}
-
-PgfPhrasetable PgfPhrasetableNode::upd_node(PgfPhrasetable node, PgfPhrasetable left, PgfPhrasetable right)
-{
-    if (node->txn_id != PgfDB::get_txn_id()) {
-        PgfPhrasetable new_node = PgfDB::malloc<PgfPhrasetableNode>();
-        new_node->sym      = node->sym;
-        new_node->n_items  = node->n_items;
-        new_node->items    = node->items;
-        new_node->txn_id   = PgfDB::get_txn_id();
-        release(node);
-        node = new_node;
-    }
-
-    node->sz        = 1+PgfPhrasetableNode::size(left)+PgfPhrasetableNode::size(right);
-    node->left      = left;
-    node->right     = right;
-
-    return node;
-}
-
-PgfPhrasetable PgfPhrasetableNode::balanceL(PgfPhrasetable node)
-{
-    if (node->right == 0) {
-        if (node->left == 0) {
-            return node;
-        } else {
-            if (node->left->left == 0) {
-                if (node->left->right == 0) {
-                    return node;
-                } else {
-                    PgfPhrasetable left_right = node->left->right;
-                    PgfPhrasetable left  = upd_node(node->left,0,0);
-                    PgfPhrasetable right = upd_node(node,0,0);
-                    return upd_node(left_right,
-                                    left,
-                                    right);
-                }
-            } else {
-                if (node->left->right == 0) {
-                    PgfPhrasetable left  = node->left;
-                    PgfPhrasetable right = upd_node(node,0,0);
-                    return upd_node(left,
-                                    left->left,
-                                    right);
-                } else {
-                    if (node->left->right->sz < RATIO * node->left->left->sz) {
-                        PgfPhrasetable left  = node->left;
-                        PgfPhrasetable right =
-                            upd_node(node,
-                                     left->right,
-                                     0);
-                        return upd_node(left,
-                                        left->left,
-                                        right);
-                    } else {
-                        PgfPhrasetable left_right = node->left->right;
-                        PgfPhrasetable left  =
-                            upd_node(node->left,
-                                     node->left->left,
-                                     left_right->left);
-                        PgfPhrasetable right =
-                            upd_node(node,
-                                     left_right->right,
-                                     0);
-                        return upd_node(left_right,
-                                        left,
-                                        right);
-                    }
-                }
-            }
-        }
-    } else {
-        if (node->left == 0) {
-            return node;
-        } else {
-            if (node->left->sz > DELTA*node->right->sz) {
-                if (node->left->right->sz < RATIO*node->left->left->sz) {
-                    PgfPhrasetable left  = node->left;
-                    PgfPhrasetable right =
-                        upd_node(node,
-                                 left->right,
-                                 node->right);
-                    return upd_node(left,
-                                    left->left,
-                                    right);
-                } else {
-                    PgfPhrasetable left_right = node->left->right;
-                    PgfPhrasetable left  =
-                        upd_node(node->left,
-                                 node->left->left,
-                                 left_right->left);
-                    PgfPhrasetable right =
-                        upd_node(node,
-                                 left_right->right,
-                                 node->right);
-                    return upd_node(left_right,
-                                    left,
-                                    right);
-                }
-            } else {
-                return node;
-            }
-        }
-    }
-}
-
-PgfPhrasetable PgfPhrasetableNode::balanceR(PgfPhrasetable node)
-{
-    if (node->left == 0) {
-        if (node->right == 0) {
-            return node;
-        } else {
-            if (node->right->left == 0) {
-                if (node->right->right == 0) {
-                    return node;
-                } else {
-                    PgfPhrasetable right = node->right;
-                    PgfPhrasetable left  =
-                        upd_node(node,
-                                 0,
-                                 0);
-                    return upd_node(right,
-                                    left,
-                                    right->right);
-                }
-            } else {
-                if (node->right->right == 0) {
-                    PgfPhrasetable right_left = node->right->left;
-                    PgfPhrasetable right =
-                        upd_node(node->right,0,0);
-                    PgfPhrasetable left =
-                        upd_node(node,0,0);
-                    return upd_node(right_left,
-                                    left,
-                                    right);
-                } else {
-                    if (node->right->left->sz < RATIO * node->right->right->sz) {
-                        PgfPhrasetable right = node->right;
-                        PgfPhrasetable left  =
-                            upd_node(node,
-                                     0,
-                                     right->left);
-                        return upd_node(right,
-                                        left,
-                                        right->right);
-                    } else {
-                        PgfPhrasetable right_left = node->right->left;
-                        PgfPhrasetable right =
-                            upd_node(node->right,
-                                     right_left->right,
-                                     node->right->right);
-                        PgfPhrasetable left =
-                            upd_node(node,
-                                     0,
-                                     right_left->left);
-                        return upd_node(right_left,
-                                        left,
-                                        right);
-                    }
-                }
-            }
-        }
-    } else {
-        if (node->right == 0) {
-            return node;
-        } else {
-            if (node->right->sz > DELTA*node->left->sz) {
-                if (node->right->left->sz < RATIO*node->right->right->sz) {
-                    PgfPhrasetable right = node->right;
-                    PgfPhrasetable left =
-                        upd_node(node,
-                                 node->left,
-                                 right->left);
-                    return upd_node(right,
-                                    left,
-                                    right->right);
-                } else {
-                    PgfPhrasetable right_left = node->right->left;
-                    PgfPhrasetable right =
-                        upd_node(node->right,
-                                 right_left->right,
-                                 node->right->right);
-                    PgfPhrasetable left =
-                        upd_node(node,
-                                 node->left,
-                                 right_left->left);
-                    return upd_node(right_left,
-                                    left,
-                                    right);
-                }
-            } else {
-                return node;
-            }
-        }
-    }
-}
-
-void PgfPhrasetableNode::release(ref<PgfPhrasetableNode> node)
-{
-    PgfDB::free(node);
-}
-
 void phrasetable_iter(PgfPhrasetable table, ref<PgfConcrLincat> lincat, std::function<void(ref<PgfSymbolCCat> arg,size_t,vector<ref<PgfItem>>)> &f)
 {
     if (table == 0)
@@ -618,11 +401,11 @@ void phrasetable_iter(PgfPhrasetable table, ref<PgfConcrLincat> lincat, std::fun
 
     int cmp = 0;
     ref<PgfSymbolCCat> symcf = 0;
-    uint8_t tag = ref<PgfSymbol>::get_tag(table->sym);
+    uint8_t tag = ref<PgfSymbol>::get_tag(table->value.sym);
     if (PgfSymbolCCat::tag != tag) {
         cmp = ((int) PgfSymbolCCat::tag) - ((int) tag);
     } else {
-        symcf = ref<PgfSymbolCCat>::untagged(table->sym);
+        symcf = ref<PgfSymbolCCat>::untagged(table->value.sym);
         cmp = textcmp(&lincat->name, &symcf->lincat->name);
     }
 
@@ -632,7 +415,7 @@ void phrasetable_iter(PgfPhrasetable table, ref<PgfConcrLincat> lincat, std::fun
         phrasetable_iter(table->right, lincat, f);
     else {
         phrasetable_iter(table->left,  lincat, f);
-        f(symcf,table->n_items,table->items);
+        f(symcf,table->value.n_items,table->value.items);
         phrasetable_iter(table->right, lincat, f);
     }
 }
@@ -640,14 +423,14 @@ void phrasetable_iter(PgfPhrasetable table, ref<PgfConcrLincat> lincat, std::fun
 vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable table, PgfSymbol sym, size_t *n_items)
 {
     while (table != 0) {
-        int cmp = symbol_cmp(sym,table->sym);
+        int cmp = symbol_cmp(sym,table->value.sym);
         if (cmp < 0)
             table = table->left;
         else if (cmp > 0)
             table = table->right;
         else {
-            *n_items = table->n_items;
-            return table->items;
+            *n_items = table->value.n_items;
+            return table->value.items;
         }
     }
 
@@ -661,11 +444,11 @@ vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable phrasetable,
 {
     while (phrasetable != 0) {
         int cmp;
-        uint8_t tag = ref<PgfSymbol>::get_tag(phrasetable->sym);
+        uint8_t tag = ref<PgfSymbol>::get_tag(phrasetable->value.sym);
         if (PgfSymbolACat::tag != tag) {
             cmp = ((int) PgfSymbolACat::tag) - ((int) tag);
         } else {
-            auto symcf = ref<PgfSymbolACat>::untagged(phrasetable->sym);
+            auto symcf = ref<PgfSymbolACat>::untagged(phrasetable->value.sym);
             cmp = textcmp(&lincat->name, &symcf->name);
         }
         if (cmp < 0)
@@ -673,8 +456,8 @@ vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable phrasetable,
         else if (cmp > 0)
             phrasetable = phrasetable->right;
         else {
-            *n_items = phrasetable->n_items;
-            return phrasetable->items;
+            *n_items = phrasetable->value.n_items;
+            return phrasetable->value.items;
         }
     }
 
@@ -695,7 +478,7 @@ void phrasetable_lookup(PgfPhrasetable table,
     spot.pos = 0;
     spot.ptr = (uint8_t *) sentence->text;
     const uint8_t *end = spot.ptr+sentence->size;
-    int cmp = text_symbol_cmp(&spot,end,table->sym,case_sensitive);
+    int cmp = text_symbol_cmp(&spot,end,table->value.sym,case_sensitive);
     if (cmp < 0) {
         phrasetable_lookup(table->left,sentence,case_sensitive,scanner,err);
     } else if (cmp > 0) {
@@ -707,8 +490,8 @@ void phrasetable_lookup(PgfPhrasetable table,
                 return;
         }
 
-        for (size_t i = 0; i < table->n_items; i++) {
-            ref<PgfItem> item = table->items[i];
+        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(item->rule->container);
@@ -808,7 +591,7 @@ void phrasetable_lookup_prefixes(PgfCohortsState *state,
         return;
 
     PgfTextSpot current = state->spot;
-    int cmp = text_symbol_cmp(&current,state->end,table->sym,state->case_sensitive);
+    int cmp = text_symbol_cmp(&current,state->end,table->value.sym,state->case_sensitive);
     if (cmp < 0) {
         phrasetable_lookup_prefixes(state,table->left,min,max);
     } else if (cmp > 0) {
@@ -847,8 +630,8 @@ void phrasetable_lookup_prefixes(PgfCohortsState *state,
             }
             state->queue.push(current);
 
-            for (size_t i = 0; i < table->n_items; i++) {
-                auto rule = table->items[i]->rule;
+            for (size_t i = 0; i < table->value.n_items; i++) {
+                auto rule = table->value.items[i]->rule;
                 switch (ref<PgfConcrLin>::get_tag(rule->container)) {
                 case PgfConcrLin::tag: {
                     ref<PgfConcrLin> lin = ref<PgfConcrLin>::untagged(rule->container);
@@ -962,42 +745,43 @@ void phrasetable_lookup_cohorts(PgfPhrasetable table,
     }
 }
 
+PGF_INTERNAL
 PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
                                   PgfSymbol sym,
                                   ref<PgfItem> item)
 {
     if (table == 0) {
-        PgfPhrasetable new_table = PgfPhrasetableNode::new_node(sym,1);
-        new_table->n_items = 1;
-        new_table->items[0] = item;
-        return new_table;
+        auto items = vector<ref<PgfItem>>::alloc(1);
+        items[0] = item;
+        return Node<PgfPhrasetableValue>::new_node({.sym=sym,.n_items=1,.items=items});
 	}
 
-    int cmp = symbol_cmp(sym,table->sym);
+    int cmp = symbol_cmp(sym,table->value.sym);
     if (cmp < 0) {
         PgfPhrasetable left = phrasetable_insert(table->left, sym, item);
-        table = PgfPhrasetableNode::upd_node(table,left,table->right);
-        return PgfPhrasetableNode::balanceL(table);
+        table = Node<PgfPhrasetableValue>::upd_node(table,left,table->right);
+        return Node<PgfPhrasetableValue>::balanceL(table);
     } else if (cmp > 0) {
         PgfPhrasetable right = phrasetable_insert(table->right, sym, item);
-        table = PgfPhrasetableNode::upd_node(table, table->left, right);
-        return PgfPhrasetableNode::balanceR(table);
+        table = Node<PgfPhrasetableValue>::upd_node(table, table->left, right);
+        return Node<PgfPhrasetableValue>::balanceR(table);
     } else {
         PgfPhrasetable new_table =
-            PgfPhrasetableNode::upd_node(table, table->left, table->right);
+            Node<PgfPhrasetableValue>::upd_node(table, table->left, table->right);
 
-        auto items = new_table->items;
-        if (new_table->n_items >= items.size()) {
-            size_t new_len = get_next_padovan(new_table->n_items+1);
+        auto items = new_table->value.items;
+        if (new_table->value.n_items >= items.size()) {
+            size_t new_len = get_next_padovan(new_table->value.n_items+1);
             items = items.realloc(new_len, new_table->txn_id);
         }
-        items[new_table->n_items] = item;
-        new_table->n_items++;
-        new_table->items = items;
+        items[new_table->value.n_items] = item;
+        new_table->value.n_items++;
+        new_table->value.items = items;
         return new_table;
     }
 }
 
+PGF_INTERNAL
 PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
                                   ref<PgfConcrLincat> lincat,
                                   interval_t value, interval_t lin_idx,
@@ -1011,35 +795,34 @@ PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
         symcf->lin_idx = lin_idx;
         symcf->fid = fid;
         symcf->viterbi_prob = viterbi_prob;
-        PgfPhrasetable new_table = PgfPhrasetableNode::new_node(symcf.tagged(),1);
-        new_table->n_items = 1;
-        new_table->items[0] = item;
-        return new_table;
+        auto items = vector<ref<PgfItem>>::alloc(1);
+        items[0] = item;
+        return Node<PgfPhrasetableValue>::new_node({.sym=symcf.tagged(),.n_items=1,.items=items});
 	}
 
-    int cmp = symbol_cmp(lincat,value,lin_idx,table->sym);
+    int cmp = symbol_cmp(lincat,value,lin_idx,table->value.sym);
     if (cmp < 0) {
         PgfPhrasetable left = phrasetable_insert(table->left,
                                                 lincat, value, lin_idx, fid, viterbi_prob, item);
-        table = PgfPhrasetableNode::upd_node(table,left,table->right);
-        return PgfPhrasetableNode::balanceL(table);
+        table = Node<PgfPhrasetableValue>::upd_node(table,left,table->right);
+        return Node<PgfPhrasetableValue>::balanceL(table);
     } else if (cmp > 0) {
         PgfPhrasetable right = phrasetable_insert(table->right,
                                                   lincat, value, lin_idx, fid, viterbi_prob, item);
-        table = PgfPhrasetableNode::upd_node(table, table->left, right);
-        return PgfPhrasetableNode::balanceR(table);
+        table = Node<PgfPhrasetableValue>::upd_node(table, table->left, right);
+        return Node<PgfPhrasetableValue>::balanceR(table);
     } else {
         PgfPhrasetable new_table =
-            PgfPhrasetableNode::upd_node(table, table->left, table->right);
+            Node<PgfPhrasetableValue>::upd_node(table, table->left, table->right);
 
-        auto items = new_table->items;
-        if (new_table->n_items >= items.size()) {
-            size_t new_len = get_next_padovan(new_table->n_items+1);
+        auto items = new_table->value.items;
+        if (new_table->value.n_items >= items.size()) {
+            size_t new_len = get_next_padovan(new_table->value.n_items+1);
             items = items.realloc(new_len, new_table->txn_id);
         }
-        items[new_table->n_items] = item;
-        new_table->n_items++;
-        new_table->items = items;
+        items[new_table->value.n_items] = item;
+        new_table->value.n_items++;
+        new_table->value.items = items;
         return new_table;
     }
 }
diff --git a/src/runtime/c/pgf/phrasetable.h b/src/runtime/c/pgf/phrasetable.h
index acf718616..a238935a3 100644
--- a/src/runtime/c/pgf/phrasetable.h
+++ b/src/runtime/c/pgf/phrasetable.h
@@ -38,14 +38,7 @@ struct PGF_INTERNAL_DECL PgfItem {
     ref<PgfConcrRule> rule;
 };
 
-struct PgfPhrasetableNode;
-typedef ref<PgfPhrasetableNode> PgfPhrasetable;
-
-struct PGF_INTERNAL_DECL PgfPhrasetableNode {
-    const static size_t DELTA = 3;
-    const static size_t RATIO = 2;
-
-public:
+struct PGF_INTERNAL_DECL PgfPhrasetableValue {
     PgfSymbol sym;
 
     // Here n_items tells us how many actual items there are in
@@ -53,37 +46,10 @@ public:
     // how big buffer we have allocated.
     size_t n_items;
     vector<ref<PgfItem>> items;
-
-    txn_t txn_id;
-
-    size_t sz;
-    ref<PgfPhrasetableNode> left;
-    ref<PgfPhrasetableNode> right;
-
-    static
-    ref<PgfPhrasetableNode> new_node(PgfSymbol sym, size_t n_items);
-
-    static
-    ref<PgfPhrasetableNode> upd_node(ref<PgfPhrasetableNode> node, ref<PgfPhrasetableNode> left, ref<PgfPhrasetableNode> right);
-
-    static
-    ref<PgfPhrasetableNode> balanceL(ref<PgfPhrasetableNode> node);
-
-    static
-    ref<PgfPhrasetableNode> balanceR(ref<PgfPhrasetableNode> node);
-
-    static
-    size_t size(ref<PgfPhrasetableNode> node)
-    {
-        if (node == 0)
-            return 0;
-        return node->sz;
-    }
-
-    static
-    void release(ref<PgfPhrasetableNode> node);
 };
 
+typedef ref<Node<PgfPhrasetableValue>> PgfPhrasetable;
+
 PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
                                   PgfSymbol sym,
                                   ref<PgfItem> item);

From 696c3705a217931333e2c7b129a68480dbba1a33 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 4 Aug 2026 15:41:57 +0200
Subject: [PATCH 123/144] release the phrasetable when the concrete syntax is
 released

---
 src/runtime/c/pgf/data.cxx        |  1 +
 src/runtime/c/pgf/phrasetable.cxx | 17 +++++++++++++++++
 src/runtime/c/pgf/phrasetable.h   | 11 +++++++++++
 3 files changed, 29 insertions(+)

diff --git a/src/runtime/c/pgf/data.cxx b/src/runtime/c/pgf/data.cxx
index 0b15e9f8b..fda0f80b1 100644
--- a/src/runtime/c/pgf/data.cxx
+++ b/src/runtime/c/pgf/data.cxx
@@ -41,6 +41,7 @@ void PgfConcr::release(ref<PgfConcr> concr)
     namespace_release(concr->lins);
     namespace_release(concr->lincats);
     namespace_release(concr->printnames);
+    phrasetable_release(concr->phrasetable);
     PgfDB::free(concr, concr->name.size+1);
 }
 
diff --git a/src/runtime/c/pgf/phrasetable.cxx b/src/runtime/c/pgf/phrasetable.cxx
index a7d17152d..f1caa5833 100644
--- a/src/runtime/c/pgf/phrasetable.cxx
+++ b/src/runtime/c/pgf/phrasetable.cxx
@@ -394,6 +394,7 @@ int symbol_cmp(PgfSymbol sym1, PgfSymbol sym2)
     }
 }
 
+PGF_INTERNAL
 void phrasetable_iter(PgfPhrasetable table, ref<PgfConcrLincat> lincat, std::function<void(ref<PgfSymbolCCat> arg,size_t,vector<ref<PgfItem>>)> &f)
 {
     if (table == 0)
@@ -420,6 +421,7 @@ void phrasetable_iter(PgfPhrasetable table, ref<PgfConcrLincat> lincat, std::fun
     }
 }
 
+PGF_INTERNAL
 vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable table, PgfSymbol sym, size_t *n_items)
 {
     while (table != 0) {
@@ -438,6 +440,7 @@ vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable table, PgfSymbol sym, siz
     return 0;
 }
 
+PGF_INTERNAL
 vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable phrasetable,
                                         ref<PgfConcrLincat> lincat,
                                         size_t *n_items)
@@ -826,3 +829,17 @@ PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
         return new_table;
     }
 }
+
+PGF_INTERNAL
+void phrasetable_release(PgfPhrasetable 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>::release(table);
+}
diff --git a/src/runtime/c/pgf/phrasetable.h b/src/runtime/c/pgf/phrasetable.h
index a238935a3..a952774ab 100644
--- a/src/runtime/c/pgf/phrasetable.h
+++ b/src/runtime/c/pgf/phrasetable.h
@@ -32,6 +32,14 @@ struct PGF_INTERNAL_DECL PgfItem {
         }
     } args;
 
+    static
+    void release(ref<PgfItem> item) {
+        size_t ex_size =
+            sizeof(ref<PgfSymbolCCat>) * 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;
@@ -91,4 +99,7 @@ void phrasetable_lookup_cohorts(PgfPhrasetable phrasetable,
                                 bool case_sensitive,
                                 PgfPhraseScanner *scanner, PgfExn* err);
 
+PGF_INTERNAL_DECL
+void phrasetable_release(PgfPhrasetable table);
+
 #endif

From edd9fcf904ee710828b0be4ebdee811125f3e201 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 5 Aug 2026 12:14:15 +0200
Subject: [PATCH 124/144] avoid looping with recursive epsilon categories

---
 src/runtime/c/pgf/parser.cxx | 21 ++++++++++++++++++---
 1 file changed, 18 insertions(+), 3 deletions(-)

diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index aeff7c50e..e4b12f036 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -140,6 +140,24 @@ void PgfAbstractParser::symbol(Item *item, State *state, PgfSymbol sym)
                 suspend(cont,item,n_suspended1,suspended.size());
             }
         } else {
+            interval_t value_i   = item->interval(item->rule->args[symcat->d]);
+            interval_t lin_idx_i = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
+
+            bool found = false;
+            CCat *prev_ccat = ccat;
+            while (prev_ccat != NULL && prev_ccat->fid > initial_fid && prev_ccat->cont->state == state) {
+                if (prev_ccat->value == value_i && prev_ccat->lin_idx == lin_idx_i) {
+                    found = true;
+                    break;
+                }
+                prev_ccat = prev_ccat->cont->ccat;
+            }
+            if (found) {
+                item->dot++;
+                state->push_item(item);
+                break;
+            }
+
             Cont *&cont = state->conts2[ccat];
             if (cont == NULL) {
                 cont = new Cont;
@@ -151,9 +169,6 @@ void PgfAbstractParser::symbol(Item *item, State *state, PgfSymbol sym)
                 cont->state = state;
             }
 
-            interval_t value_i   = item->interval(item->rule->args[symcat->d]);
-            interval_t lin_idx_i = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
-
             bool subsumed = false;
             for (auto it1 : cont->suspended.overlaps(value_i)) {
                 if (it1.first.first <= value_i.first && it1.first.second >= value_i.second) {

From abac98531ddbfbbbc81be357e7d23b65bea8c9b8 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 5 Aug 2026 14:28:15 +0200
Subject: [PATCH 125/144] fix lookup morpho after changes related to the parser

---
 src/runtime/c/pgf/phrasetable.cxx | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/runtime/c/pgf/phrasetable.cxx b/src/runtime/c/pgf/phrasetable.cxx
index f1caa5833..d57a714fa 100644
--- a/src/runtime/c/pgf/phrasetable.cxx
+++ b/src/runtime/c/pgf/phrasetable.cxx
@@ -307,7 +307,7 @@ bool text_item_match(PgfTextSpot *spot, const uint8_t *end,
                      bool case_sensitive)
 {
     bool bind = false;
-    size_t dot = item->dot;
+    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]);

From 38fb11e0a38fb7549ba17f79bad65255e954f1f0 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 5 Aug 2026 15:53:25 +0200
Subject: [PATCH 126/144] fix the parsing api

---
 src/compiler/api/GF/Server/PGFService.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/compiler/api/GF/Server/PGFService.hs b/src/compiler/api/GF/Server/PGFService.hs
index 9fe00963c..80ef0dc34 100644
--- a/src/compiler/api/GF/Server/PGFService.hs
+++ b/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 "")

From 979e5c3741501ea0594ab572853f558647aed752 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 5 Aug 2026 19:42:04 +0000
Subject: [PATCH 127/144] adapt the translator to the new Parse grammars and
 remove the CNLs

---
 src/compiler/www/js/gftranslate.js |   2 +-
 src/compiler/www/js/wc.js          | 117 +----------------------------
 src/compiler/www/wc.html           |   1 -
 3 files changed, 2 insertions(+), 118 deletions(-)

diff --git a/src/compiler/www/js/gftranslate.js b/src/compiler/www/js/gftranslate.js
index dc280f6eb..5ddd45a14 100644
--- a/src/compiler/www/js/gftranslate.js
+++ b/src/compiler/www/js/gftranslate.js
@@ -99,7 +99,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)
     }
 }
 
diff --git a/src/compiler/www/js/wc.js b/src/compiler/www/js/wc.js
index 2c938eedb..00b55f5b4 100644
--- a/src/compiler/www/js/wc.js
+++ b/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()
     }
@@ -239,37 +235,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) {
-	    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)
+	step2(so.input)
     }
 
     function change_segment_to(so,to) {
@@ -428,86 +394,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 +405,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()
 }
diff --git a/src/compiler/www/wc.html b/src/compiler/www/wc.html
index f3c836ee8..b3518b6eb 100644
--- a/src/compiler/www/wc.html
+++ b/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>

From 5064ba1ae724f362670fce24c2d846f1fd61f2a0 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 6 Aug 2026 00:13:48 +0200
Subject: [PATCH 128/144] added a few more languages

---
 src/compiler/www/js/langcode.js | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/src/compiler/www/js/langcode.js b/src/compiler/www/js/langcode.js
index 7907d3ce6..46306491e 100644
--- a/src/compiler/www/js/langcode.js
+++ b/src/compiler/www/js/langcode.js
@@ -20,11 +20,12 @@ var languages =
 	    "Chinese:zh","Czech:cs","Danish:da","Dutch:nl","English:en",
 	    "Estonian:et","Finnish:fi","French:fr","German:de","Greek:el",
 	    "Hebrew:he","Hindi:hi","Ina/Interlingua:ia",
-	    "Icelandic:is","Gle/Irish:ga","Italian:it","Jpn/Japanese:ja",
+	    "Icelandic:is","Gle/Irish:ga","Italian:it","Korean:ko","Jpn/Japanese:ja",
 	    "Latin:la","Lav/Latvian:lv","Mlt/Maltese:mt","Mongolian:mn",
 	    "Nepali:ne","Norwegian:nb","Pes/Persian:fa","Polish:pl",
 	    "Portuguese:pt","Pnb/Punjabi:pa",
-	    "Ron/Romanian:ro","Russian:ru","Snd/Sindhi:sd","Spanish:es",
+	    "Ron/Romanian:ro","Russian:ru","Slv/Slovenian:sl","Somali:so",
+	    "Snd/Sindhi:sd","Spanish:es","Swahili:sw",
 	    "Swedish:sv","Thai:th","Turkish:tr","Urdu:ur"]
 	// GF uses nonstd 3-letter codes? Pes/Persian:fa, Pnb/Punjabi:pa
 	return map(lang1,ls)

From a0c44088e816419401ded51726a41f5c3450b095 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 6 Aug 2026 09:09:36 +0200
Subject: [PATCH 129/144] even more languages

---
 src/compiler/www/js/langcode.js | 26 +++++++++++++++-----------
 1 file changed, 15 insertions(+), 11 deletions(-)

diff --git a/src/compiler/www/js/langcode.js b/src/compiler/www/js/langcode.js
index 46306491e..8236c2b21 100644
--- a/src/compiler/www/js/langcode.js
+++ b/src/compiler/www/js/langcode.js
@@ -16,17 +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",
-	    "Chinese:zh","Czech:cs","Danish:da","Dutch:nl","English:en",
-	    "Estonian:et","Finnish:fi","French:fr","German:de","Greek:el",
-	    "Hebrew:he","Hindi:hi","Ina/Interlingua:ia",
-	    "Icelandic:is","Gle/Irish:ga","Italian:it","Korean:ko","Jpn/Japanese:ja",
-	    "Latin:la","Lav/Latvian:lv","Mlt/Maltese:mt","Mongolian:mn",
-	    "Nepali:ne","Norwegian:nb","Pes/Persian:fa","Polish:pl",
-	    "Portuguese:pt","Pnb/Punjabi:pa",
-	    "Ron/Romanian:ro","Russian:ru","Slv/Slovenian:sl","Somali:so",
-	    "Snd/Sindhi:sd","Spanish:es","Swahili:sw",
-	    "Swedish:sv","Thai:th","Turkish:tr","Urdu:ur"]
+    ls=["Afrikaans:af","Sqi/Albanian:sq","Amharic:am","Arabic:ar",
+        "Hye/Armenian:hy","Eus/Basque/eu","Bel/Belarusian:be","Bulgarian:bg",
+        "Catalan:ca","Chinese:zh","Czech:cs","Danish:da",
+        "Dutch:nl","English:en","Estonian:et","Fao/Faroese:fo",
+        "Finnish:fi","French:fr","Gla/Gaelic:gd","German:de",
+        "Greek:el","Hebrew:he","Hindi:hi","Hungarian/hu",
+        "Icelandic:is","Ina/Interlingua:ia","Gle/Irish:ga","Italian:it",
+        "Jpn/Japanese:ja","Kazakh:kk","Korean:ko","Latin:la",
+        "Lav/Latvian:lv","Mkd/Macedonian:mk","Mlt/Maltese:mt","Mongolian:mn",
+        "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)
     }()

From 43322aab7faa23f88f38afe73e3f1f5fba44db52 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 6 Aug 2026 09:48:50 +0200
Subject: [PATCH 130/144] show only language where we know the names

---
 src/compiler/www/js/wc.js | 9 +++++++--
 1 file changed, 7 insertions(+), 2 deletions(-)

diff --git a/src/compiler/www/js/wc.js b/src/compiler/www/js/wc.js
index 00b55f5b4..a30f68edd 100644
--- a/src/compiler/www/js/wc.js
+++ b/src/compiler/www/js/wc.js
@@ -370,8 +370,13 @@ wc.init_languages=function () {
 	function update_menu(m) {
 	    var l=m.value
 	    clear(m)
-	    for(var i=0;i<langs.length;i++)
-		m.appendChild(option(concname(langs[i]),langs[i]))
+	    for(var i=0;i<langs.length;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)

From 57f836c5049c0c63aee17de35b3817a79c7deaf2 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 6 Aug 2026 10:10:05 +0200
Subject: [PATCH 131/144] fix hungarian

---
 src/compiler/www/js/langcode.js | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/compiler/www/js/langcode.js b/src/compiler/www/js/langcode.js
index 8236c2b21..68477c0b4 100644
--- a/src/compiler/www/js/langcode.js
+++ b/src/compiler/www/js/langcode.js
@@ -21,7 +21,7 @@ var languages =
         "Catalan:ca","Chinese:zh","Czech:cs","Danish:da",
         "Dutch:nl","English:en","Estonian:et","Fao/Faroese:fo",
         "Finnish:fi","French:fr","Gla/Gaelic:gd","German:de",
-        "Greek:el","Hebrew:he","Hindi:hi","Hungarian/hu",
+        "Greek:el","Hebrew:he","Hindi:hi","Hungarian:hu",
         "Icelandic:is","Ina/Interlingua:ia","Gle/Irish:ga","Italian:it",
         "Jpn/Japanese:ja","Kazakh:kk","Korean:ko","Latin:la",
         "Lav/Latvian:lv","Mkd/Macedonian:mk","Mlt/Maltese:mt","Mongolian:mn",

From afbb6820ab2da6d29de930bdd2464fed84b26e7c Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 6 Aug 2026 16:59:59 +0200
Subject: [PATCH 132/144] update after removing gfwordnet.languages

---
 src/compiler/www/gfse/editor.js | 21 +++++++--------------
 1 file changed, 7 insertions(+), 14 deletions(-)

diff --git a/src/compiler/www/gfse/editor.js b/src/compiler/www/gfse/editor.js
index 8284096d1..8c20c94fd 100644
--- a/src/compiler/www/gfse/editor.js
+++ b/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) {
-			var b=wordnet_modules[i];
-			add_module(b,b+conc.langcode)
-		}
-	}
+    for(var i in wordnet_modules) {
+        var b=wordnet_modules[i];
+        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_list.push(name);
-			index++;
-		}
+        selection.langs[name] = {name: langname[code], index: index};
+        selection.langs_list.push(name);
+        index++;
 	}
 	selection.isEqual = function(other) {
 		if (other.langs_list.length != this.langs_list.length)

From 4cfeb07af8b5a599f904a80ef8491b0398c70ba5 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 7 Aug 2026 16:04:24 +0200
Subject: [PATCH 133/144] fix the display of an inflection table and add a
 gloss

---
 src/compiler/www/js/wc.js | 14 ++++++++++----
 1 file changed, 10 insertions(+), 4 deletions(-)

diff --git a/src/compiler/www/js/wc.js b/src/compiler/www/js/wc.js
index a30f68edd..a35a54e74 100644
--- a/src/compiler/www/js/wc.js
+++ b/src/compiler/www/js/wc.js
@@ -121,13 +121,19 @@ wc.translate=function(redo) {
 		function show_inflections(lins) {
 		    if(wc.e2) wc.e2.innerHTML=lins[0].text
 		}
-		function get_inflections() {
-		    var tree="MkDocument+%22%22+(Inflection"+wcls+"+"+w+")+%22%22"
+		function get_inflections(glosses) {
+            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) {

From 9ac7ea1df98d3eec992deec90e3e60221133959d Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Mon, 10 Aug 2026 12:10:31 +0200
Subject: [PATCH 134/144] temporary hack for linearize_all

---
 src/runtime/c/pgf/pgf.cxx | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx
index 4b42df273..9a238f030 100644
--- a/src/runtime/c/pgf/pgf.cxx
+++ b/src/runtime/c/pgf/pgf.cxx
@@ -2548,7 +2548,7 @@ PgfText **pgf_linearize_all(PgfDB *db, PgfConcrRevision revision,
         m->match_expr(&linearizer, expr);
         linearizer.reverse_and_label(true);
 
-        while (linearizer.resolve()) {
+        if (linearizer.resolve()) {
             linearizer.linearize(&out, 0);
             PgfText *text = out.get_text();
             if (text != NULL) {

From c41b75a9cb8566f11aaca5b6b42b9694d8a209f9 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 12 Aug 2026 10:31:03 +0200
Subject: [PATCH 135/144] split the phrasetable to five parts and better serve
 the parser

---
 src/runtime/c/pgf/data.cxx        |   6 +-
 src/runtime/c/pgf/data.h          |  20 +-
 src/runtime/c/pgf/parser.cxx      | 532 ++++++++++++++++--------------
 src/runtime/c/pgf/parser.h        |  25 +-
 src/runtime/c/pgf/pgf.cxx         |  16 +-
 src/runtime/c/pgf/phrasetable.cxx | 518 ++++++++++-------------------
 src/runtime/c/pgf/phrasetable.h   |  96 ++++--
 src/runtime/c/pgf/printer.cxx     |  14 -
 src/runtime/c/pgf/reader.cxx      |   6 +-
 9 files changed, 571 insertions(+), 662 deletions(-)

diff --git a/src/runtime/c/pgf/data.cxx b/src/runtime/c/pgf/data.cxx
index fda0f80b1..5c7492bd5 100644
--- a/src/runtime/c/pgf/data.cxx
+++ b/src/runtime/c/pgf/data.cxx
@@ -41,7 +41,11 @@ void PgfConcr::release(ref<PgfConcr> concr)
     namespace_release(concr->lins);
     namespace_release(concr->lincats);
     namespace_release(concr->printnames);
-    phrasetable_release(concr->phrasetable);
+    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);
 }
 
diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h
index cdb6b68d0..f3870fefb 100644
--- a/src/runtime/c/pgf/data.h
+++ b/src/runtime/c/pgf/data.h
@@ -252,20 +252,6 @@ struct PGF_INTERNAL_DECL PgfConcrLin {
     static void release(ref<PgfConcrLin> lin);
 };
 
-struct PGF_INTERNAL_DECL PgfSymbolACat {
-    static const uint8_t tag = 11;
-    PgfText name;
-};
-
-struct PGF_INTERNAL_DECL PgfSymbolCCat {
-    static const uint8_t tag = 12;
-    ref<PgfConcrLincat> lincat;
-    interval_t value;
-    interval_t lin_idx;
-    prob_t viterbi_prob;
-    PgfMetaId fid;
-};
-
 struct PGF_INTERNAL_DECL PgfConcrPrintname {
     ref<PgfText> printname;
     PgfText name;
@@ -281,7 +267,11 @@ 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;
 
diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index e4b12f036..f333b3f3e 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -11,26 +11,44 @@ PgfAbstractParser::PgfAbstractParser(ref<PgfConcr> concr)
     this->concr = concr;
 
     this->current_state = NULL;
-    this->initial_fid = concr->last_fid;
     this->last_fid = concr->last_fid;
 }
 
 void PgfAbstractParser::get_info(CCat *ccat, ref<PgfConcrRule> *prule, size_t **pvalues)
 {
-    if (ccat->fid > initial_fid) {
+    if (ccat->epsilon == 0) {
         Production *prod = ccat->prods[0];
         *prule = prod->rule;
         *pvalues = &prod->vars[0];
     } else {
-        size_t n_items;
-        vector<ref<PgfItem>> items =
-            phrasetable_lookup(concr->phrasetable, ccat->epsilons, &n_items);
-        ref<PgfItem> pitem = items[0];
+        ref<PgfItem> pitem = ccat->epsilon->items[0];
         *prule = pitem->rule;
         *pvalues = &pitem->vars[0];
     }
 }
 
+PgfAbstractParser::CCat *PgfAbstractParser::get_epsilon_ccat(PgfText *name, PgfMetaId fid)
+{
+    if (fid == 0)
+        return NULL;
+
+    CCat *&ccat = epsilons[fid];
+    if (ccat == NULL) {
+        ref<PgfCCat> arg = epsilontable_get(concr->epsilontable,
+                                            name, fid);
+        ccat = new CCat;
+        ccat->fid = arg->fid;
+        ccat->epsilon = arg;
+        ccat->cont = NULL;
+        ccat->state = NULL;
+        ccat->lin_idx = arg->lin_idx;
+        ccat->value = arg->value;
+        ccat->covered = true;
+        ccat->viterbi_prob = arg->viterbi_prob;
+    }
+    return ccat;
+}
+
 PgfAbstractParser::CCat::~CCat()
 {
     for (Production *prod : prods) {
@@ -97,7 +115,7 @@ void PgfAbstractParser::process(Item *item, State *state)
 
 PGF_INTERNAL_DECL
 int text_symbol_cmp(PgfTextSpot *spot, const uint8_t *end,
-                    PgfSymbol sym, bool case_sensitive);
+                    ref<PgfSymbolKS> sym, bool case_sensitive);
 
 void PgfAbstractParser::symbol(Item *item, State *state, PgfSymbol sym)
 {
@@ -137,15 +155,16 @@ void PgfAbstractParser::symbol(Item *item, State *state, PgfSymbol sym)
                 auto &suspended = cont->suspended[value_i][lin_idx_i];
                 suspended.push_back(item);
 
-                suspend(cont,item,n_suspended1,suspended.size());
+                suspend(cont,item,n_suspended1 == 0,suspended.size(),symcat);
             }
         } else {
             interval_t value_i   = item->interval(item->rule->args[symcat->d]);
             interval_t lin_idx_i = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
 
+            // the following prevents infinite loops with epsilons
             bool found = false;
             CCat *prev_ccat = ccat;
-            while (prev_ccat != NULL && prev_ccat->fid > initial_fid && prev_ccat->cont->state == state) {
+            while (prev_ccat != NULL && prev_ccat->epsilon == 0 && prev_ccat->cont->state == state) {
                 if (prev_ccat->value == value_i && prev_ccat->lin_idx == lin_idx_i) {
                     found = true;
                     break;
@@ -162,8 +181,8 @@ void PgfAbstractParser::symbol(Item *item, State *state, PgfSymbol sym)
             if (cont == NULL) {
                 cont = new Cont;
                 cont->ccat = ccat;
-                if (ccat->fid <= initial_fid)
-                    cont->lincat = ref<PgfSymbolCCat>::untagged(ccat->epsilons)->lincat;
+                if (ccat->epsilon != 0)
+                    cont->lincat = ccat->epsilon->lincat;
                 else
                     cont->lincat = ccat->cont->lincat;
                 cont->state = state;
@@ -185,44 +204,13 @@ found:;
             auto &suspended = cont->suspended[value_i][lin_idx_i];
             suspended.push_back(item);
 
-            if (!subsumed && suspended.size() == 1) {
-                if (ccat->fid <= initial_fid) {
-                    size_t n_items = 0;
-                    vector<ref<PgfItem>> items =
-                        phrasetable_lookup(concr->phrasetable, ccat->epsilons, &n_items);
-
-                    for (size_t i = 0; i < n_items; i++) {
-                        ref<PgfItem> pitem = items[i];
-                        td_epsilon(state,cont,pitem,item,symcat);
-                    }
-                } else {
-                    for (Production *prod : ccat->prods) {
-                        td_predict(state,cont,prod,item,symcat);
-                    }
-                }
-            } else {
-                State *next = state;
-                while (next != NULL) {                   
-                    auto it1 = next->completed.find(cont);
-                    if (it1 != next->completed.end()) {
-                        auto *it2 = it1->second.lookup(ccat->value);
-                        if (it2 != NULL) {
-                            auto *it3 = it2->lookup(lin_idx_i);
-                            if (it3 != NULL) {
-                                CCat *arg = *it3;
-                                Item *new_item = new (item) Item;
-                                combine(next, new_item, arg);
-                            }
-                        }
-                    }
-                    next = next->next;
-                }
-            }
+            suspend(cont,item,!subsumed,suspended.size(),symcat);
         }
         break;
     }
     case PgfSymbolKS::tag: {
-        symbol_token(item, state, sym);
+        auto symks = ref<PgfSymbolKS>::untagged(sym);
+        symbol_token(item, state, symks);
         break;
     }
     case PgfSymbolKP::tag: {
@@ -282,6 +270,7 @@ void PgfAbstractParser::complete(Item *item, State *state)
         if (ccat == NULL) {
             ccat = new CCat;
             ccat->fid = (++last_fid);
+            ccat->epsilon = 0;
             ccat->cont  = item->cont;
             ccat->state = state;
             ccat->lin_idx = lin_idx;
@@ -331,8 +320,7 @@ void PgfAbstractParser::complete(Item *item, State *state)
         final_item(state, ccat, item, res, lin_idx);
 
         if (ccat->prods.size() == 1) {
-            if (ccat->cont->ccat == NULL)
-                bu_predict(state, ccat);
+            bu_predict(state, ccat);
 
             for (auto it1 : ccat->cont->suspended.overlaps(ccat->value)) {
                 for (auto it2 : it1.second.overlaps(ccat->lin_idx)) {
@@ -552,22 +540,9 @@ void PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref<PgfItem> pitem,
             }
 
             for (size_t i = 0; i < pitem->args.size(); i++) {
-                ref<PgfSymbolCCat> arg = pitem->args[i];
-
-                if (arg != 0) {
-                    CCat *&arg_ccat = epsilons[arg->lincat][arg->value][arg->lin_idx];
-                    if (arg_ccat == NULL) {
-                        arg_ccat = new CCat;
-                        arg_ccat->fid = arg->fid;
-                        arg_ccat->epsilons = arg.tagged();
-                        arg_ccat->state = NULL;
-                        arg_ccat->lin_idx = arg->lin_idx;
-                        arg_ccat->value = arg->value;
-                        arg_ccat->covered = true;
-                        arg_ccat->viterbi_prob = arg->viterbi_prob;
-                    }
-                    item->args[i] = arg_ccat;
-                    item->inside_prob += arg_ccat->viterbi_prob;
+                if (pitem->args[i] != 0) {
+                    item->args[i] = get_epsilon_ccat(&lin->absfun->type->hypos[i].type->name,pitem->args[i]);
+                    item->inside_prob += item->args[i]->viterbi_prob;
                 }
 
                 if (!item->instantiate(item->rule->args[i], pitem->rule, &pitem->vars[0], pitem->rule->args[i])) {
@@ -676,7 +651,7 @@ void PgfAbstractParser::print_item(Item *item, State *state)
 {
     PgfPrinter printer(NULL,0,NULL);
 
-    printer.nprintf(32, "[%zd-%zd; ", item->cont ? item->cont->state->end.pos : 0, state->start.pos);
+    printer.nprintf(32, "[%zd-%zd; ", (item->cont && item->cont->state) ? item->cont->state->end.pos : 0, state->start.pos);
 
     if (item->vars.size() > 0) {
         printer.lvar_ranges(item->rule->ranges, &item->vars[0]);
@@ -832,7 +807,7 @@ PgfParser::~PgfParser()
         for (auto it1 : state->completed) {
             for (auto it2 : it1.second) {
                 for (auto it3 : it2.second) {
-                    if (it3.second->fid <= initial_fid)
+                    if (it3.second->epsilon != 0)
                         continue;
 
                     for (ExprState *estate : it3.second->pending) {
@@ -850,21 +825,17 @@ PgfParser::~PgfParser()
     }
 
     for (auto it1 : epsilons) {
-        for (auto it2 : it1.second) {
-            for (auto it3 : it2.second) {
-                for (ExprState *estate : it3.second->pending) {
-                    if (estate->expr != 0)
-                        u->free_ref(estate->expr);
-                }
-                for (ExprProb &ep : it3.second->exprs) {
-                    u->free_ref(ep.expr);
-                }
-            }
+        for (ExprState *estate : it1.second->pending) {
+            if (estate->expr != 0)
+                u->free_ref(estate->expr);
+        }
+        for (ExprProb &ep : it1.second->exprs) {
+            u->free_ref(ep.expr);
         }
     }
 }
 
-void PgfParser::bu_predict(PgfPhrasetable phrasetable,
+void PgfParser::bu_predict(PgfPhrasetable<PgfSymbolKS> phrasetable,
                            State *state,
                            ptrdiff_t min, ptrdiff_t max)
 {
@@ -872,7 +843,7 @@ void PgfParser::bu_predict(PgfPhrasetable phrasetable,
         return;
 
     PgfTextSpot current = state->end;
-    int cmp = text_symbol_cmp(&current,end,phrasetable->value.sym,case_sensitive);
+    int cmp = text_symbol_cmp(&current,end,phrasetable->value.key,case_sensitive);
     if (cmp < 0) {
         bu_predict(phrasetable->left,state,min,max);
     } else if (cmp > 0) {
@@ -906,51 +877,51 @@ void PgfParser::bu_predict(PgfPhrasetable phrasetable,
      }
 }
 
-void PgfParser::bu_predict(PgfPhrasetable phrasetable,
+void PgfParser::bu_predict(PgfPhrasetable<PgfSymbolBIND> phrasetable,
                            State *state)
 {
-    if (phrasetable == 0)
-        return;
+    size_t n_items = 0;
+    vector<ref<PgfItem>> items =
+        phrasetable_lookup(concr->phrasetable4,
+                           ref<PgfSymbolBIND>(0),
+                           &n_items);
 
-    PgfTextSpot current = state->end;
-    int cmp;
-    uint8_t tag = ref<PgfSymbol>::get_tag(phrasetable->value.sym);
-    cmp = ((int) PgfSymbolBIND::tag) - ((int) tag);
-    if (cmp < 0) {
-        bu_predict(phrasetable->left,state);
-    } else if (cmp > 0) {
-        bu_predict(phrasetable->right,state);
-    } else {
-        State *next_state = state->next;
-        if (next_state == NULL || state->end.pos != next_state->start.pos) {
-            next_state = new State;
-            next_state->start = state->end;
-            next_state->end   = state->end;
-            next_state->next  = state->next;
-            next_state->needs_bind = false;
-            state->next = next_state;
-        }
+    State *next_state = state->next;
+    if (next_state == NULL || state->end.pos != next_state->start.pos) {
+        next_state = new State;
+        next_state->start = state->end;
+        next_state->end   = state->end;
+        next_state->next  = state->next;
+        next_state->needs_bind = false;
+        state->next = next_state;
+    }
 
-        for (size_t i = 0; i < phrasetable->value.n_items; i++) {
-            std::map<ref<PgfConcrLincat>, bool> visited;
-            //if (!td_reachable(state, phrasetable->items[i], visited))
-            //    continue;
-            Item *item = bu_item(state, phrasetable->value.items[i]);
-            item->dot++;
-            next_state->push_item(item);
-        }
+    for (size_t i = 0; i < n_items; i++) {
+        //std::map<ref<PgfConcrLincat>, bool> visited;
+        //if (!td_reachable(state, phrasetable->items[i], visited))
+        //    continue;
+        Item *item = bu_item(state, items[i]);
+        item->dot++;
+        next_state->push_item(item);
     }
 }
 
 void PgfParser::bu_predict(State *state, CCat *ccat)
 {
     size_t n_items = 0;
-    vector<ref<PgfItem>> items =
-        phrasetable_lookup(concr->phrasetable,
-                           ccat->cont->lincat,
-                           &n_items);
+    vector<ref<PgfItem>> items = 0;
+    if (ccat->cont->ccat == NULL) {
+        items = phrasetable_lookup(concr->phrasetable2,
+                                   ccat->cont->lincat,
+                                   &n_items);
+    } else if (ccat->cont->ccat->epsilon != 0) {
+        items = phrasetable_lookup(concr->phrasetable3,
+                                   ccat->cont->ccat->epsilon,
+                                   &n_items);
+    }
+
     for (size_t i = 0; i < n_items; i++) {
-        std::map<ref<PgfConcrLincat>, bool> visited;
+        //std::map<ref<PgfConcrLincat>, bool> visited;
         //if (!td_reachable(ccat->cont->state, items[i], visited))
         //    continue;
         auto new_item = bu_item(ccat->cont->state, items[i]);
@@ -976,7 +947,7 @@ bool PgfParser::td_reachable(State *state, ref<PgfItem> pitem,
 
         size_t n_items = 0;
         vector<ref<PgfItem>> items =
-            phrasetable_lookup(concr->phrasetable,
+            phrasetable_lookup(concr->phrasetable2,
                                lin->lincat,
                                &n_items);
         for (size_t i = 0; i < n_items; i++) {
@@ -997,12 +968,26 @@ PgfAbstractParser::Item *PgfParser::bu_item(State *state, ref<PgfItem> pitem)
     case PgfConcrLin::tag: {
         auto lin = ref<PgfConcrLin>::untagged(pitem->rule->container);
 
-        Cont *&cont = state->conts1[lin->lincat];
-        if (cont == NULL) {
-            cont = new Cont;
-            cont->ccat = NULL;
-            cont->lincat = lin->lincat;
-            cont->state = state;
+        Cont *cont;
+        if (pitem->res == 0) {
+            Cont *&tmp = state->conts1[lin->lincat];
+            if (tmp == NULL) {
+                tmp = new Cont;
+                tmp->ccat = NULL;
+                tmp->lincat = lin->lincat;
+                tmp->state = state;
+            }
+            cont = tmp;
+        } else {
+            CCat *ccat = get_epsilon_ccat(&lin->lincat->name,pitem->res);
+            Cont *&tmp = state->conts2[ccat];
+            if (tmp == NULL) {
+                tmp = new Cont;
+                tmp->ccat = ccat;
+                tmp->lincat = lin->lincat;
+                tmp->state = state;
+            }
+            cont = tmp;
         }
 
         item = new(pitem->rule) Item;
@@ -1014,6 +999,14 @@ PgfAbstractParser::Item *PgfParser::bu_item(State *state, ref<PgfItem> pitem)
         item->rule    = pitem->rule;
         item->inside_prob = lin->absfun->prob;
         item->outside_prob = 0;
+
+        for (size_t i = 0; i < pitem->args.size(); i++) {
+            item->args[i] = 0;
+            if (pitem->args[i] != 0) {
+                item->args[i] = get_epsilon_ccat(&lin->absfun->type->hypos[i].type->name,pitem->args[i]);
+                item->inside_prob += item->args[i]->viterbi_prob;
+            }
+        }
         break;
     }
     case PgfConcrLincat::tag: {
@@ -1036,6 +1029,7 @@ PgfAbstractParser::Item *PgfParser::bu_item(State *state, ref<PgfItem> pitem)
         item->rule    = pitem->rule;
         item->inside_prob = 0;
         item->outside_prob = 0;
+        item->args[0] = 0;
         break;
     }
     }
@@ -1050,29 +1044,6 @@ PgfAbstractParser::Item *PgfParser::bu_item(State *state, ref<PgfItem> pitem)
     }
 
     memcpy(&item->vars[0], &pitem->vars[0], sizeof(size_t) * item->vars.size());
-
-    for (size_t i = 0; i < pitem->args.size(); i++) {
-        ref<PgfSymbolCCat> arg = pitem->args[i];
-
-        item->args[i] = 0;
-
-        if (arg != 0) {
-            CCat *&arg_ccat = epsilons[arg->lincat][arg->value][arg->lin_idx];
-            if (arg_ccat == NULL) {
-                arg_ccat = new CCat;
-                arg_ccat->fid = arg->fid;
-                arg_ccat->epsilons = arg.tagged();
-                arg_ccat->state = NULL;
-                arg_ccat->lin_idx = arg->lin_idx;
-                arg_ccat->value = arg->value;
-                arg_ccat->covered = true;
-                arg_ccat->viterbi_prob = arg->viterbi_prob;
-            }
-            item->args[i] = arg_ccat;
-            item->inside_prob += arg_ccat->viterbi_prob;
-        }
-    }
-
     return item;
 }
 
@@ -1136,7 +1107,7 @@ PgfExpr PgfParser::fetch(PgfDB *db, prob_t *prob)
 {
     DB_scope scope(db, READER_SCOPE);
 
-    bool first_fetch = (initial_fid == last_fid);
+    bool first_fetch = (concr->last_fid == last_fid);
 
     for (;;) {
         State *state = current_state;
@@ -1225,13 +1196,9 @@ PgfExpr PgfParser::process_expr(ExprState *estate, prob_t *prob)
             ccat->pending.push_back(estate);
 
             if (ccat->pending.size() == 1) {
-                if (ccat->fid <= initial_fid) {
-                    size_t n_items = 0;
-                    vector<ref<PgfItem>> items =
-                        phrasetable_lookup(concr->phrasetable, ccat->epsilons, &n_items);
-
-                    for (size_t i = 0; i < n_items; i++) {
-                        ref<PgfItem> pitem = items[i];
+                if (ccat->epsilon != 0) {
+                    for (size_t i = 0; i < ccat->epsilon->n_items; i++) {
+                        ref<PgfItem> pitem = ccat->epsilon->items[i];
 
                         auto lin = ref<PgfConcrLin>::untagged(pitem->rule->container);
 
@@ -1246,22 +1213,10 @@ PgfExpr PgfParser::process_expr(ExprState *estate, prob_t *prob)
                             new_estate->hash = new_estate->hash * 101 + lin->name.text[i];
                         }
                         for (size_t i = 0; i < new_estate->n_args; i++) {
-                            ref<PgfSymbolCCat> arg = pitem->args[i];
                             new_estate->args[i] = NULL;
-                            if (arg != 0) {
-                                CCat *&arg_ccat = epsilons[arg->lincat][arg->value][arg->lin_idx];
-                                if (arg_ccat == NULL) {
-                                    arg_ccat = new CCat;
-                                    arg_ccat->fid = arg->fid;
-                                    arg_ccat->epsilons = arg.tagged();
-                                    arg_ccat->state = NULL;
-                                    arg_ccat->lin_idx = arg->lin_idx;
-                                    arg_ccat->value = arg->value;
-                                    arg_ccat->covered = true;
-                                    arg_ccat->viterbi_prob = arg->viterbi_prob;
-                                }
-                                new_estate->args[i] = arg_ccat;
-                                new_estate->prob += arg_ccat->viterbi_prob;
+                            if (pitem->args[i] != 0) {
+                                new_estate->args[i] = get_epsilon_ccat(&lin->absfun->type->hypos[i].type->name,pitem->args[i]);
+                                new_estate->prob += new_estate->args[i]->viterbi_prob;
                             }
                         }
                         queue.push_back(new_estate);
@@ -1373,10 +1328,10 @@ PgfAbstractParser::State *PgfParser::new_state(const PgfTextSpot &start)
     return state;
 }
 
-void PgfParser::symbol_token(Item *item, State *state, PgfSymbol sym)
+void PgfParser::symbol_token(Item *item, State *state, ref<PgfSymbolKS> symks)
 {
     PgfTextSpot next = state->end;
-    if (text_symbol_cmp(&next,end,sym,case_sensitive) != 0)
+    if (text_symbol_cmp(&next,end,symks,case_sensitive) != 0)
         return;
 
     State *next_state = new_state(next);
@@ -1409,68 +1364,101 @@ void PgfParser::symbol_bind(Item *item, State *state, PgfSymbol sym)
     }
 }
 
-void PgfParser::suspend(Cont *cont,Item *item,size_t n_suspended1,size_t n_suspended)
+void PgfParser::suspend(Cont *cont,Item *item,bool do_predict,size_t n_suspended,ref<PgfSymbolCat> symcat)
 {
-    if (n_suspended == 1) {
-        std::function<void(ref<PgfSymbolCCat>,size_t,vector<ref<PgfItem>>)> f =
-            [this,item,cont](ref<PgfSymbolCCat> symcf, size_t n_items, vector<ref<PgfItem>> items) {
+    if (cont->ccat == NULL) {
+        if (n_suspended == 1) {
+            std::function<void(ref<PgfCCat>)> f =
+                [this,item,cont](ref<PgfCCat> arg) {
 
-                ref<PgfItem> xitem = items[0];
+                    ref<PgfItem> xitem = arg->items[0];
 
-                Item *new_item = new (item) Item;
-                PgfSymbol sym = new_item->rule->syms[new_item->dot];
-                auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
-                if (!new_item->instantiate(new_item->rule->args[sym_cat->d],xitem->rule,&xitem->vars[0],xitem->rule->res)) {
-                    delete new_item;
-                    return;
-                }
-                if (!new_item->instantiate(ref<PgfLParam>::from_ptr(&sym_cat->r),xitem->rule,&xitem->vars[0],xitem->rule->lin_idx)) {
-                    delete new_item;
-                    return;
-                }
-
-                CCat *&arg_ccat = epsilons[symcf->lincat][symcf->value][symcf->lin_idx];
-                if (arg_ccat == NULL) {
-                    arg_ccat = new CCat;
-                    arg_ccat->fid = symcf->fid;
-                    arg_ccat->epsilons = symcf.tagged();
-                    arg_ccat->state = NULL;
-                    arg_ccat->lin_idx = symcf->lin_idx;
-                    arg_ccat->value = symcf->value;
-                    arg_ccat->covered = true;
-                    arg_ccat->viterbi_prob = symcf->viterbi_prob;
-                }
-
-                cont->state->completed[cont][symcf->value][symcf->lin_idx] = arg_ccat;
-
-                new_item->dot++;
-                new_item->args[sym_cat->d] = arg_ccat;
-                new_item->inside_prob += arg_ccat->viterbi_prob;
-
-                cont->state->push_item(new_item);
-            };
-        phrasetable_iter(concr->phrasetable,cont->lincat,f);
-    }
-
-    State *state = cont->state;
-    while (state != NULL) {
-        auto it1 = state->completed.find(cont);
-        if (it1 != state->completed.end()) {
-            for (auto it2 : it1->second) {
-                for (auto it3 : it2.second) {
                     Item *new_item = new (item) Item;
-                    combine(state, new_item, it3.second);
+                    PgfSymbol sym = new_item->rule->syms[new_item->dot];
+                    auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
+                    if (!new_item->instantiate(new_item->rule->args[sym_cat->d],xitem->rule,&xitem->vars[0],xitem->rule->res)) {
+                        delete new_item;
+                        return;
+                    }
+                    if (!new_item->instantiate(ref<PgfLParam>::from_ptr(&sym_cat->r),xitem->rule,&xitem->vars[0],xitem->rule->lin_idx)) {
+                        delete new_item;
+                        return;
+                    }
+
+                    CCat *&arg_ccat = epsilons[arg->fid];
+                    if (arg_ccat == NULL) {
+                        arg_ccat = new CCat;
+                        arg_ccat->fid = arg->fid;
+                        arg_ccat->epsilon = arg;
+                        arg_ccat->state = NULL;
+                        arg_ccat->lin_idx = arg->lin_idx;
+                        arg_ccat->value = arg->value;
+                        arg_ccat->covered = true;
+                        arg_ccat->viterbi_prob = arg->viterbi_prob;
+                    }
+
+                    cont->state->completed[cont][arg_ccat->value][arg_ccat->lin_idx] = arg_ccat;
+
+                    new_item->dot++;
+                    new_item->args[sym_cat->d] = arg_ccat;
+                    new_item->inside_prob += arg_ccat->viterbi_prob;
+
+                    cont->state->push_item(new_item);
+                };
+            epsilontable_iter(concr->epsilontable,cont->lincat,f);
+        }
+
+        State *state = cont->state;
+        while (state != NULL) {
+            auto it1 = state->completed.find(cont);
+            if (it1 != state->completed.end()) {
+                for (auto it2 : it1->second) {
+                    for (auto it3 : it2.second) {
+                        Item *new_item = new (item) Item;
+                        combine(state, new_item, it3.second);
+                    }
                 }
             }
+            state = state->next;
         }
-        state = state->next;
-    }
 
-    if (n_suspended1 == 0) {
-        if (cont->state->needs_bind) {
-            bu_predict(concr->phrasetable, cont->state);
+        if (do_predict) {
+            if (cont->state->needs_bind) {
+                bu_predict(concr->phrasetable4, cont->state);
+            } else {
+                bu_predict(concr->phrasetable1, cont->state, 1, sentence->size);
+            }
+        }
+    } else {
+        if (do_predict && n_suspended == 1) {
+            if (cont->ccat->epsilon != 0) {
+                for (size_t i = 0; i < cont->ccat->epsilon->n_items; i++) {
+                    ref<PgfItem> pitem = cont->ccat->epsilon->items[i];
+                    td_epsilon(cont->state,cont,pitem,item,symcat);
+                }
+            } else {
+                for (Production *prod : cont->ccat->prods) {
+                    td_predict(cont->state,cont,prod,item,symcat);
+                }
+            }
         } else {
-            bu_predict(concr->phrasetable, cont->state, 1, sentence->size);
+            State *next = cont->state;
+            while (next != NULL) {
+                auto it1 = next->completed.find(cont);
+                if (it1 != next->completed.end()) {
+                    auto *it2 = it1->second.lookup(cont->ccat->value);
+                    if (it2 != NULL) {
+                        interval_t lin_idx_i = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
+                        auto *it3 = it2->lookup(lin_idx_i);
+                        if (it3 != NULL) {
+                            CCat *arg = *it3;
+                            Item *new_item = new (item) Item;
+                            combine(next, new_item, arg);
+                        }
+                    }
+                }
+                next = next->next;
+            }
         }
     }
 }
@@ -1561,9 +1549,10 @@ PgfParseTableMaker::PgfParseTableMaker(ref<PgfConcr> concr)
 ref<PgfItem> PgfParseTableMaker::clone_item(Item *item)
 {
     size_t ex_size =
-        sizeof(ref<PgfSymbolCCat>) * item->args.size() +
-        sizeof(size_t)             * item->vars.size();
+        sizeof(PgfMetaId) * item->args.size() +
+        sizeof(size_t)    * item->vars.size();
     auto pitem = PgfDB::malloc<PgfItem>(ex_size);
+    pitem->res     = (item->cont->ccat == NULL) ? 0 : item->cont->ccat->fid;
     pitem->pre_alt = item->pre_alt;
     pitem->pre_dot = item->pre_dot;
     pitem->dot     = item->dot;
@@ -1571,16 +1560,7 @@ ref<PgfItem> PgfParseTableMaker::clone_item(Item *item)
     memcpy(&pitem->vars[0],&item->vars[0],sizeof(size_t) * item->vars.size());
 
     for (size_t i = 0; i < item->args.size(); i++) {
-        ref<PgfSymbolCCat> symcf = 0;
-        if (item->args[i] != NULL) {
-            symcf = PgfDB::malloc<PgfSymbolCCat>();
-            symcf->lincat  = item->args[i]->cont->lincat;
-            symcf->value   = item->args[i]->value;
-            symcf->lin_idx = item->args[i]->lin_idx;
-            symcf->fid     = item->args[i]->fid;
-            symcf->viterbi_prob = item->args[i]->viterbi_prob;
-        }
-        pitem->args[i] = symcf;
+        pitem->args[i] = (item->args[i] == NULL) ? 0 : item->args[i]->fid;
     }
 
     return pitem;
@@ -1591,19 +1571,19 @@ PgfAbstractParser::State *PgfParseTableMaker::new_state(const PgfTextSpot &start
     return current_state;
 }
 
-void PgfParseTableMaker::symbol_token(Item *item, State *state, PgfSymbol sym)
+void PgfParseTableMaker::symbol_token(Item *item, State *state, ref<PgfSymbolKS> symks)
 {
     auto pitem = clone_item(item);
-    auto phrasetable = phrasetable_insert(concr->phrasetable,sym,pitem);
-    concr->phrasetable = phrasetable;
+    auto phrasetable1 = phrasetable_insert(concr->phrasetable1,symks,pitem);
+    concr->phrasetable1 = phrasetable1;
     delete item;
 }
 
 void PgfParseTableMaker::symbol_bind(Item *item, State *state, PgfSymbol sym)
 {
     auto pitem = clone_item(item);
-    auto phrasetable = phrasetable_insert(concr->phrasetable,ref<PgfSymbolBIND>(0).tagged(),pitem);
-    concr->phrasetable = phrasetable;
+    auto phrasetable4 = phrasetable_insert(concr->phrasetable4,ref<PgfSymbolBIND>(0),pitem);
+    concr->phrasetable4 = phrasetable4;
 
     if (ref<PgfSymbol>::get_tag(sym) == PgfSymbolBIND::tag) {
         delete item;
@@ -1613,33 +1593,77 @@ void PgfParseTableMaker::symbol_bind(Item *item, State *state, PgfSymbol sym)
     }
 }
 
-void PgfParseTableMaker::suspend(Cont *cont,Item *item,size_t n_suspended1,size_t n_suspended)
+void PgfParseTableMaker::suspend(Cont *cont,Item *item,bool do_predict,size_t n_suspended,ref<PgfSymbolCat> symcat)
 {
-    for (auto it1 : cont->state->completed[cont]) {
-        for (auto it2 : it1.second) {
-            CCat *ccat = it2.second;
-            if (ccat != NULL) {
-                Item *new_item = new (item) Item;
-                combine(cont->state,new_item,ccat);
+    if (cont->ccat == NULL) {
+        for (auto it1 : cont->state->completed[cont]) {
+            for (auto it2 : it1.second) {
+                CCat *ccat = it2.second;
+                if (ccat != NULL) {
+                    Item *new_item = new (item) Item;
+                    combine(cont->state,new_item,ccat);
+                }
             }
         }
-    }
 
-    auto pitem = clone_item(item);
-    auto acat  = ref<PgfSymbolACat>::from_ptr((PgfSymbolACat*) &cont->lincat->name);
-    auto phrasetable = phrasetable_insert(concr->phrasetable,acat.tagged(),pitem);
-    concr->phrasetable = phrasetable;
+        auto pitem = clone_item(item);
+        auto phrasetable2 = phrasetable_insert(concr->phrasetable2,cont->lincat,pitem);
+        concr->phrasetable2 = phrasetable2;
+    } else {
+        if (do_predict && n_suspended == 1) {
+            if (cont->ccat->epsilon != 0) {
+                for (size_t i = 0; i < cont->ccat->epsilon->n_items; i++) {
+                    ref<PgfItem> pitem = cont->ccat->epsilon->items[i];
+                    td_epsilon(cont->state,cont,pitem,item,symcat);
+                }
+            } else {
+                for (Production *prod : cont->ccat->prods) {
+                    td_predict(cont->state,cont,prod,item,symcat);
+                }
+            }
+        } else {
+            State *next = cont->state;
+            while (next != NULL) {
+                auto it1 = next->completed.find(cont);
+                if (it1 != next->completed.end()) {
+                    auto *it2 = it1->second.lookup(cont->ccat->value);
+                    if (it2 != NULL) {
+                        interval_t lin_idx_i = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
+                        auto *it3 = it2->lookup(lin_idx_i);
+                        if (it3 != NULL) {
+                            CCat *arg = *it3;
+                            Item *new_item = new (item) Item;
+                            combine(next, new_item, arg);
+                        }
+                    }
+                }
+                next = next->next;
+            }
+        }
+
+        auto pitem = clone_item(item);
+        auto phrasetable3 = phrasetable_insert(concr->phrasetable3,cont->ccat->epsilon,pitem);
+        concr->phrasetable3 = phrasetable3;
+    }
 }
 
 void PgfParseTableMaker::final_item(State *state, CCat *ccat, Item *item, interval_t value, interval_t lin_idx)
 {
     auto pitem = clone_item(item);
-    
-    PgfPhrasetable phrasetable = concr->phrasetable;
-    phrasetable = phrasetable_insert(phrasetable,
-                                     item->cont->lincat, value, lin_idx, ccat->fid, ccat->viterbi_prob,
-                                     pitem);
-    concr->phrasetable = phrasetable;
+
+    if (ccat->epsilon == 0) {
+        PgfEpsilontable epsilontable = concr->epsilontable;
+        epsilontable =
+            epsilontable_insert(epsilontable,
+                                ccat->cont->lincat,
+                                ccat->value, ccat->lin_idx,
+                                ccat->fid, ccat->viterbi_prob,
+                                pitem,
+                                &ccat->epsilon);
+        concr->epsilontable = epsilontable;
+    } else {
+        epsilontable_add(ccat->epsilon, pitem);
+    }
 }
 
 void PgfParseTableMaker::bu_predict(State *state, CCat *ccat)
diff --git a/src/runtime/c/pgf/parser.h b/src/runtime/c/pgf/parser.h
index 72403733a..c9b8c6cef 100644
--- a/src/runtime/c/pgf/parser.h
+++ b/src/runtime/c/pgf/parser.h
@@ -82,10 +82,8 @@ protected:
 
     struct CCat {
         PgfMetaId fid;
-        union {
-            object epsilons;
-            Cont *cont;
-        };
+        ref<PgfCCat> epsilon;
+        Cont *cont;
         State *state;
         interval_t value;
         interval_t lin_idx;
@@ -231,7 +229,7 @@ protected:
     };
 
     State *current_state;
-    std::map<ref<PgfConcrLincat>,interval_map<interval_map<CCat*>>> epsilons;
+    std::map<PgfMetaId,CCat*> epsilons;
     PgfMetaId initial_fid, last_fid;
 
     void process(Item *item, State *state);
@@ -239,9 +237,9 @@ protected:
     void complete(Item *item, State *state);
 
     virtual State *new_state(const PgfTextSpot &start)=0;
-    virtual void symbol_token(Item *item, State *state, PgfSymbol sym)=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, size_t n_suspended1, size_t n_suspended)=0;
+    virtual void suspend(Cont *cont, Item *item, bool do_predict, size_t n_suspended,ref<PgfSymbolCat> symcat)=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, CCat *ccat)=0;
 
@@ -250,6 +248,7 @@ protected:
     void combine(State *state, Item *item, CCat *ccat);
 
     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);
@@ -271,14 +270,14 @@ class PGF_INTERNAL_DECL PgfParser : private PgfAbstractParser, public PgfExprEnu
     bool case_sensitive;
 
     virtual State *new_state(const PgfTextSpot &start);
-    virtual void symbol_token(Item *item, State *state, PgfSymbol sym);
+    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,size_t n_suspended1,size_t n_suspended);
+    virtual void suspend(Cont *cont,Item *item,bool do_predict,size_t n_suspended,ref<PgfSymbolCat> symcat);
     virtual void final_item(State *state,CCat *ccat,Item *item,interval_t value,interval_t lin_idx);
     virtual void bu_predict(State *state, CCat *ccat);
 
-    void bu_predict(PgfPhrasetable phrasetable, State *state);
-    void bu_predict(PgfPhrasetable phrasetable, State *state, ptrdiff_t min, ptrdiff_t max);
+    void bu_predict(PgfPhrasetable<PgfSymbolBIND> phrasetable, State *state);
+    void bu_predict(PgfPhrasetable<PgfSymbolKS> phrasetable, State *state, 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);
 
@@ -313,9 +312,9 @@ class PGF_INTERNAL_DECL PgfParseTableMaker : private PgfAbstractParser
 {
 private:
     virtual State *new_state(const PgfTextSpot &start);
-    virtual void symbol_token(Item *item, State *state, PgfSymbol sym);
+    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, size_t n_suspended1, size_t n_suspended);
+    virtual void suspend(Cont *cont, Item *item, bool do_predict, size_t n_suspended,ref<PgfSymbolCat> symcat);
     virtual void final_item(State *state, CCat *ccat,Item *item,interval_t value,interval_t lin_idx);
     virtual void bu_predict(State *state, CCat *ccat);
 
diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx
index 9a238f030..e71c913eb 100644
--- a/src/runtime/c/pgf/pgf.cxx
+++ b/src/runtime/c/pgf/pgf.cxx
@@ -1022,7 +1022,7 @@ void pgf_lookup_morpho(PgfDB *db, PgfConcrRevision cnc_revision,
         PgfMorphoScanner scanner(callback);
         size_t n_items;
 
-        phrasetable_lookup(concr->phrasetable,
+        phrasetable_lookup(concr->phrasetable1,
                            sentence, case_sensitive,
                            &scanner, err);
     } PGF_API_END
@@ -1072,7 +1072,7 @@ void pgf_lookup_cohorts(PgfDB *db, PgfConcrRevision cnc_revision,
         bool case_sensitive = pgf_is_case_sensitive(concr);
 
         PgfCohortsScanner scanner(callback);
-        phrasetable_lookup_cohorts(concr->phrasetable,
+        phrasetable_lookup_cohorts(concr->phrasetable1,
                                    sentence, case_sensitive,
                                    &scanner, err);
     } PGF_API_END
@@ -1485,7 +1485,11 @@ ref<PgfConcr> clone_concrete(ref<PgfPGF> pgf, ref<PgfConcr> concr)
         clone->cflags = concr->cflags;
         clone->lins = concr->lins;
         clone->lincats = concr->lincats;
-        clone->phrasetable = concr->phrasetable;
+        clone->phrasetable1 = concr->phrasetable1;
+        clone->phrasetable2 = concr->phrasetable2;
+        clone->phrasetable3 = concr->phrasetable3;
+        clone->phrasetable4 = concr->phrasetable4;
+        clone->epsilontable = concr->epsilontable;
         clone->printnames = concr->printnames;
         clone->last_fid = concr->last_fid;
         memcpy(&clone->name, &concr->name, sizeof(PgfText)+concr->name.size+1);
@@ -1664,7 +1668,11 @@ PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision,
         concr->cflags = 0;
         concr->lins = 0;
         concr->lincats = 0;
-        concr->phrasetable = 0;
+        concr->phrasetable1 = 0;
+        concr->phrasetable2 = 0;
+        concr->phrasetable3 = 0;
+        concr->phrasetable4 = 0;
+        concr->epsilontable = 0;
         concr->printnames = 0;
         concr->last_fid = 0;
         memcpy(&concr->name, name, sizeof(PgfText)+name->size+1);
diff --git a/src/runtime/c/pgf/phrasetable.cxx b/src/runtime/c/pgf/phrasetable.cxx
index d57a714fa..76b583d3c 100644
--- a/src/runtime/c/pgf/phrasetable.cxx
+++ b/src/runtime/c/pgf/phrasetable.cxx
@@ -31,169 +31,12 @@ int lparam_cmp(PgfLParam *p1, PgfLParam *p2)
 	return 0;
 }
 
-static
-int sequence_cmp(vector<PgfSymbol> seq1, vector<PgfSymbol> 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;
-    case PgfSymbolACat::tag: {
-        auto sym_acat1 = ref<PgfSymbolACat>::untagged(sym1);
-        auto sym_acat2 = ref<PgfSymbolACat>::untagged(sym2);
-        res[0] = (res[1] = textcmp(&sym_acat1->name,&sym_acat2->name));
-        return;
-    }
-    case PgfSymbolCCat::tag: {
-        auto sym_ccat1 = ref<PgfSymbolCCat>::untagged(sym1);
-        auto sym_ccat2 = ref<PgfSymbolCCat>::untagged(sym2);
-        res[0] = (res[1] = textcmp(&sym_ccat1->lincat->name,&sym_ccat2->lincat->name));
-        if (res[0] != 0)
-            return;
-        if (sym_ccat1->value < sym_ccat2->value)
-			res[0] = (res[1] = -1);
-        else if (sym_ccat1->value > sym_ccat2->value)
-			res[0] = (res[1] = 1);
-        if (sym_ccat1->lin_idx < sym_ccat2->lin_idx)
-			res[0] = (res[1] = -1);
-        else if (sym_ccat1->lin_idx > sym_ccat2->lin_idx)
-			res[0] = (res[1] = 1);
-        else
-            res[0] = (res[1] = 0);
-        return;
-    }
-	default:
-		throw pgf_error("Unknown symbol tag");
-    }
-}
-
-static
-int sequence_cmp(vector<PgfSymbol> seq1, vector<PgfSymbol> seq2)
-{
-	int res[2] = {0,0};
-	for (size_t i = 0; ; i++) {
-        if (i >= seq1.size()) {
-			if (i < seq2.size())
-				return -1;
-            return res[1];
-		}
-        if (i >= seq2.size())
-            return 1;
-
-		symbol_cmp(seq1[i], seq2[i], res);
-		if (res[0] != 0)
-			return res[0];
-    }
-
-	return 0;
-}
-
 PGF_INTERNAL
 int text_symbol_cmp(PgfTextSpot *spot, const uint8_t *end,
-                    PgfSymbol sym, bool case_sensitive)
+                    ref<PgfSymbolKS> sym_ks, bool case_sensitive)
 {
-    uint8_t tag = ref<PgfSymbol>::get_tag(sym);
-    if (PgfSymbolKS::tag != tag)
-        return ((int) PgfSymbolKS::tag) - ((int) tag);
-
     int res1 = 0;
 
-    auto sym_ks = ref<PgfSymbolKS>::untagged(sym);
     const uint8_t *s2 = (uint8_t *) &sym_ks->token.text;
     const uint8_t *e2 = s2+sym_ks->token.size;
 
@@ -326,134 +169,14 @@ bool text_item_match(PgfTextSpot *spot, const uint8_t *end,
 PGF_INTERNAL_DECL
 size_t get_next_padovan(size_t min);
 
-static
-int symbol_cmp(ref<PgfConcrLincat> lincat, interval_t value, interval_t lin_idx, PgfSymbol sym)
-{
-    uint8_t tag = ref<PgfSymbol>::get_tag(sym);
-    if (PgfSymbolCCat::tag != tag)
-        return ((int) PgfSymbolCCat::tag) - ((int) tag);
-
-    auto symcf = ref<PgfSymbolCCat>::untagged(sym);
-    int res = textcmp(&lincat->name, &symcf->lincat->name);
-    if (res != 0)
-        return res;
-    if (value < symcf->value)
-        return -1;
-    else if (value > symcf->value)
-        return 1;
-    else if (lin_idx < symcf->lin_idx)
-        return -1;
-    else if (lin_idx > symcf->lin_idx)
-        return 1;
-    else
-        return 0;
-}
-
-static
-int symbol_cmp(PgfSymbol sym1, PgfSymbol sym2)
-{
-    uint8_t tag1 = ref<PgfSymbol>::get_tag(sym1);
-    uint8_t tag2 = ref<PgfSymbol>::get_tag(sym2);
-    if (tag1 != tag2)
-        return ((int) tag1) - ((int) tag2);
-
-    switch (tag1) {
-    case PgfSymbolKS::tag: {
-        auto symks1 = ref<PgfSymbolKS>::untagged(sym1);
-        auto symks2 = ref<PgfSymbolKS>::untagged(sym2);
-        int res[2] = {0,0};
-        texticmp(&symks1->token, &symks2->token, res);
-        if (res[0] != 0)
-            return res[0];
-        return res[1];
-    }
-    case PgfSymbolACat::tag: {
-        auto symcf1 = ref<PgfSymbolACat>::untagged(sym1);
-        auto symcf2 = ref<PgfSymbolACat>::untagged(sym2);
-        return textcmp(&symcf1->name, &symcf2->name);
-    }
-    case PgfSymbolCCat::tag: {
-        auto symcf1 = ref<PgfSymbolCCat>::untagged(sym1);
-        auto symcf2 = ref<PgfSymbolCCat>::untagged(sym2);
-        int res = textcmp(&symcf1->lincat->name, &symcf2->lincat->name);
-        if (res != 0)
-            return res;
-        if (symcf1->value < symcf2->value)
-            return -1;
-        else if (symcf1->value > symcf2->value)
-            return 1;
-        else if (symcf1->lin_idx < symcf2->lin_idx)
-            return -1;
-        else if (symcf1->lin_idx > symcf2->lin_idx)
-            return 1;
-        else
-            return 0;
-    }
-    default:
-        return 0;
-    }
-}
-
+template<class K>
 PGF_INTERNAL
-void phrasetable_iter(PgfPhrasetable table, ref<PgfConcrLincat> lincat, std::function<void(ref<PgfSymbolCCat> arg,size_t,vector<ref<PgfItem>>)> &f)
-{
-    if (table == 0)
-        return;
-
-    int cmp = 0;
-    ref<PgfSymbolCCat> symcf = 0;
-    uint8_t tag = ref<PgfSymbol>::get_tag(table->value.sym);
-    if (PgfSymbolCCat::tag != tag) {
-        cmp = ((int) PgfSymbolCCat::tag) - ((int) tag);
-    } else {
-        symcf = ref<PgfSymbolCCat>::untagged(table->value.sym);
-        cmp = textcmp(&lincat->name, &symcf->lincat->name);
-    }
-
-    if (cmp < 0)
-        phrasetable_iter(table->left,  lincat, f);
-    else if (cmp > 0)
-        phrasetable_iter(table->right, lincat, f);
-    else {
-        phrasetable_iter(table->left,  lincat, f);
-        f(symcf,table->value.n_items,table->value.items);
-        phrasetable_iter(table->right, lincat, f);
-    }
-}
-
-PGF_INTERNAL
-vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable table, PgfSymbol sym, size_t *n_items)
-{
-    while (table != 0) {
-        int cmp = symbol_cmp(sym,table->value.sym);
-        if (cmp < 0)
-            table = table->left;
-        else if (cmp > 0)
-            table = table->right;
-        else {
-            *n_items = table->value.n_items;
-            return table->value.items;
-        }
-    }
-
-    *n_items = 0;
-    return 0;
-}
-
-PGF_INTERNAL
-vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable phrasetable,
-                                        ref<PgfConcrLincat> lincat,
+vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable<K> phrasetable,
+                                        ref<K> key,
                                         size_t *n_items)
 {
     while (phrasetable != 0) {
-        int cmp;
-        uint8_t tag = ref<PgfSymbol>::get_tag(phrasetable->value.sym);
-        if (PgfSymbolACat::tag != tag) {
-            cmp = ((int) PgfSymbolACat::tag) - ((int) tag);
-        } else {
-            auto symcf = ref<PgfSymbolACat>::untagged(phrasetable->value.sym);
-            cmp = textcmp(&lincat->name, &symcf->name);
-        }
+        int cmp = compare_key(key, phrasetable->value.key);
         if (cmp < 0)
             phrasetable = phrasetable->left;
         else if (cmp > 0)
@@ -469,7 +192,7 @@ vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable phrasetable,
 }
 
 PGF_INTERNAL
-void phrasetable_lookup(PgfPhrasetable table,
+void phrasetable_lookup(PgfPhrasetable<PgfSymbolKS> table,
                         PgfText *sentence,
                         bool case_sensitive,
                         PgfPhraseScanner *scanner, PgfExn* err)
@@ -481,7 +204,7 @@ void phrasetable_lookup(PgfPhrasetable table,
     spot.pos = 0;
     spot.ptr = (uint8_t *) sentence->text;
     const uint8_t *end = spot.ptr+sentence->size;
-    int cmp = text_symbol_cmp(&spot,end,table->value.sym,case_sensitive);
+    int cmp = text_symbol_cmp(&spot,end,table->value.key,case_sensitive);
     if (cmp < 0) {
         phrasetable_lookup(table->left,sentence,case_sensitive,scanner,err);
     } else if (cmp > 0) {
@@ -587,14 +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;
-    int cmp = text_symbol_cmp(&current,state->end,table->value.sym,state->case_sensitive);
+    int cmp = text_symbol_cmp(&current,state->end,table->value.key,state->case_sensitive);
     if (cmp < 0) {
         phrasetable_lookup_prefixes(state,table->left,min,max);
     } else if (cmp > 0) {
@@ -661,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)
@@ -748,29 +471,29 @@ void phrasetable_lookup_cohorts(PgfPhrasetable table,
     }
 }
 
+template<class K>
 PGF_INTERNAL
-PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
-                                  PgfSymbol sym,
-                                  ref<PgfItem> item)
+PgfPhrasetable<K> phrasetable_insert(PgfPhrasetable<K> table,
+                                     ref<K> key, ref<PgfItem> item)
 {
     if (table == 0) {
         auto items = vector<ref<PgfItem>>::alloc(1);
         items[0] = item;
-        return Node<PgfPhrasetableValue>::new_node({.sym=sym,.n_items=1,.items=items});
+        return Node<PgfPhrasetableValue<K>>::new_node({.key=key,.n_items=1,.items=items});
 	}
 
-    int cmp = symbol_cmp(sym,table->value.sym);
+    int cmp = compare_key(key, table->value.key);
     if (cmp < 0) {
-        PgfPhrasetable left = phrasetable_insert(table->left, sym, item);
-        table = Node<PgfPhrasetableValue>::upd_node(table,left,table->right);
-        return Node<PgfPhrasetableValue>::balanceL(table);
+        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 right = phrasetable_insert(table->right, sym, item);
-        table = Node<PgfPhrasetableValue>::upd_node(table, table->left, right);
-        return Node<PgfPhrasetableValue>::balanceR(table);
+        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 new_table =
-            Node<PgfPhrasetableValue>::upd_node(table, table->left, table->right);
+        PgfPhrasetable<K> new_table =
+            Node<PgfPhrasetableValue<K>>::upd_node(table, table->left, table->right);
 
         auto items = new_table->value.items;
         if (new_table->value.n_items >= items.size()) {
@@ -784,62 +507,187 @@ PgfPhrasetable phrasetable_insert(PgfPhrasetable 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 phrasetable_insert(PgfPhrasetable table,
-                                  ref<PgfConcrLincat> lincat,
-                                  interval_t value, interval_t lin_idx,
-                                  PgfMetaId fid, prob_t viterbi_prob,
-                                  ref<PgfItem> item)
+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) {
-        ref<PgfSymbolCCat> symcf = PgfDB::malloc<PgfSymbolCCat>();
-        symcf->lincat = lincat;
-        symcf->value   = value;
-        symcf->lin_idx = lin_idx;
-        symcf->fid = fid;
-        symcf->viterbi_prob = viterbi_prob;
         auto items = vector<ref<PgfItem>>::alloc(1);
         items[0] = item;
-        return Node<PgfPhrasetableValue>::new_node({.sym=symcf.tagged(),.n_items=1,.items=items});
+        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 = symbol_cmp(lincat,value,lin_idx,table->value.sym);
-    if (cmp < 0) {
-        PgfPhrasetable left = phrasetable_insert(table->left,
-                                                lincat, value, lin_idx, fid, viterbi_prob, item);
-        table = Node<PgfPhrasetableValue>::upd_node(table,left,table->right);
-        return Node<PgfPhrasetableValue>::balanceL(table);
-    } else if (cmp > 0) {
-        PgfPhrasetable right = phrasetable_insert(table->right,
-                                                  lincat, value, lin_idx, fid, viterbi_prob, item);
-        table = Node<PgfPhrasetableValue>::upd_node(table, table->left, right);
-        return Node<PgfPhrasetableValue>::balanceR(table);
-    } else {
-        PgfPhrasetable new_table =
-            Node<PgfPhrasetableValue>::upd_node(table, table->left, table->right);
+    int cmp = textcmp(&lincat->name, &table->value.lincat->name);
+    if (cmp == 0) {
+        cmp = ((int)fid) - ((int)table->value.fid);
+    }
 
-        auto items = new_table->value.items;
-        if (new_table->value.n_items >= items.size()) {
-            size_t new_len = get_next_padovan(new_table->value.n_items+1);
-            items = items.realloc(new_len, new_table->txn_id);
+    if (cmp < 0) {
+        PgfEpsilontable left = epsilontable_insert(table->left,
+                                                   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[new_table->value.n_items] = item;
+        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);
+    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<PgfPhrasetableValue>::release(table);
+    Node<PgfCCat>::release(table);
 }
diff --git a/src/runtime/c/pgf/phrasetable.h b/src/runtime/c/pgf/phrasetable.h
index a952774ab..3d8cb4c86 100644
--- a/src/runtime/c/pgf/phrasetable.h
+++ b/src/runtime/c/pgf/phrasetable.h
@@ -10,10 +10,12 @@ struct PGF_INTERNAL_DECL PgfTextSpot {
 };
 
 struct PGF_INTERNAL_DECL PgfItem {
+    PgfMetaId res;
+
     struct {
         size_t &operator[](int i) {
             PgfItem *item = containerof(PgfItem,vars,this);
-            return ((size_t*) (((ref<PgfSymbolCCat>*) (item+1))+item->rule->args.size()))[i];
+            return ((size_t*) (((PgfMetaId*) (item+1))+item->rule->args.size()))[i];
         }
         size_t size() {
             PgfItem *item = containerof(PgfItem,vars,this);
@@ -22,9 +24,9 @@ struct PGF_INTERNAL_DECL PgfItem {
     } vars;
 
     struct {
-        ref<PgfSymbolCCat> &operator[](int i) {
+        PgfMetaId &operator[](int i) {
             PgfItem *item = containerof(PgfItem,args,this);
-            return ((ref<PgfSymbolCCat>*) (item+1))[i];
+            return ((PgfMetaId*) (item+1))[i];
         }
         size_t size() {
             PgfItem *item = containerof(PgfItem,args,this);
@@ -35,8 +37,8 @@ struct PGF_INTERNAL_DECL PgfItem {
     static
     void release(ref<PgfItem> item) {
         size_t ex_size =
-            sizeof(ref<PgfSymbolCCat>) * item->args.size() +
-            sizeof(size_t)             * item->vars.size();
+            sizeof(PgfMetaId) * item->args.size() +
+            sizeof(size_t)    * item->vars.size();
         PgfDB::free(item, ex_size);
     }
 
@@ -46,8 +48,11 @@ struct PGF_INTERNAL_DECL PgfItem {
     ref<PgfConcrRule> rule;
 };
 
-struct PGF_INTERNAL_DECL PgfPhrasetableValue {
-    PgfSymbol sym;
+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
@@ -56,27 +61,29 @@ struct PGF_INTERNAL_DECL PgfPhrasetableValue {
     vector<ref<PgfItem>> items;
 };
 
-typedef ref<Node<PgfPhrasetableValue>> PgfPhrasetable;
+template<class K>
+struct PGF_INTERNAL_DECL PgfPhrasetableValue {
+    ref<K> key;
 
-PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
-                                  PgfSymbol sym,
-                                  ref<PgfItem> item);
+    // 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;
+};
 
-PgfPhrasetable phrasetable_insert(PgfPhrasetable table,
-                                  ref<PgfConcrLincat> lincat,
-                                  interval_t value, interval_t lin_idx,
-                                  PgfMetaId fid, prob_t viterbi_prob,
-                                  ref<PgfItem> item);
+template <class K>
+using PgfPhrasetable = ref<Node<PgfPhrasetableValue<K>>>;
 
+template<class K>
 PGF_INTERNAL_DECL
-void phrasetable_iter(PgfPhrasetable phrasetable,ref<PgfConcrLincat> lincat,std::function<void(ref<PgfSymbolCCat> symcf,size_t,vector<ref<PgfItem>>)> &f);
+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 phrasetable, PgfSymbol sym, size_t *n_items);
-
-PGF_INTERNAL_DECL
-vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable phrasetable,
-                                        ref<PgfConcrLincat> lincat,
+vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable<K> phrasetable,
+                                        ref<K> key,
                                         size_t *n_items);
 
 class PGF_INTERNAL_DECL PgfPhraseScanner {
@@ -88,18 +95,57 @@ public:
 };
 
 PGF_INTERNAL_DECL
-void phrasetable_lookup(PgfPhrasetable phrasetable,
+void phrasetable_lookup(PgfPhrasetable<PgfSymbolKS> phrasetable,
                         PgfText *sentence,
                         bool case_sensitive,
                         PgfPhraseScanner *scanner, PgfExn* err);
 
 PGF_INTERNAL_DECL
-void phrasetable_lookup_cohorts(PgfPhrasetable phrasetable,
+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_release(PgfPhrasetable table);
+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);
+
+// 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
+ref<PgfCCat> epsilontable_get(PgfEpsilontable table,
+                              PgfText *name, PgfMetaId fid);
+
+PGF_INTERNAL
+void epsilontable_iter(PgfEpsilontable table, ref<PgfConcrLincat> lincat, std::function<void(ref<PgfCCat> arg)> &f);
+
+PGF_INTERNAL_DECL
+void epsilontable_release(PgfEpsilontable table);
 
 #endif
diff --git a/src/runtime/c/pgf/printer.cxx b/src/runtime/c/pgf/printer.cxx
index 8b740c5ac..74277a460 100644
--- a/src/runtime/c/pgf/printer.cxx
+++ b/src/runtime/c/pgf/printer.cxx
@@ -578,20 +578,6 @@ void PgfPrinter::symbol(PgfSymbol sym)
 	case PgfSymbolALLCAPIT::tag:
         puts("ALL_CAPIT");
         break;
-	case PgfSymbolACat::tag: {
-        auto symcf = ref<PgfSymbolACat>::untagged(sym);
-        efun(&symcf->name);
-        break;
-    }
-	case PgfSymbolCCat::tag: {
-        auto symcf = ref<PgfSymbolCCat>::untagged(sym);
-        efun(&symcf->lincat->name);
-        nprintf(64,"(%zu-%zu,%zu-%zu)",symcf->value.first
-                                      ,symcf->value.second
-                                      ,symcf->lin_idx.first
-                                      ,symcf->lin_idx.second);
-        break;
-    }
 	}
 }
 
diff --git a/src/runtime/c/pgf/reader.cxx b/src/runtime/c/pgf/reader.cxx
index f8ec65453..2cd4fca59 100644
--- a/src/runtime/c/pgf/reader.cxx
+++ b/src/runtime/c/pgf/reader.cxx
@@ -697,7 +697,11 @@ ref<PgfConcrPrintname> PgfReader::read_printname()
 ref<PgfConcr> PgfReader::read_concrete()
 {
     concrete = read_name(&PgfConcr::name);
-    concrete->phrasetable = 0;
+    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);

From 79dc2594a3c636d1d93f138697edf75aaab9179b Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 12 Aug 2026 11:47:52 +0200
Subject: [PATCH 136/144] fix the loop detection

---
 src/runtime/c/pgf/parser.cxx | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index f333b3f3e..3a18d5c50 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -164,7 +164,7 @@ void PgfAbstractParser::symbol(Item *item, State *state, PgfSymbol sym)
             // the following prevents infinite loops with epsilons
             bool found = false;
             CCat *prev_ccat = ccat;
-            while (prev_ccat != NULL && prev_ccat->epsilon == 0 && prev_ccat->cont->state == state) {
+            while (prev_ccat != NULL && prev_ccat->cont != NULL && prev_ccat->cont->state == state) {
                 if (prev_ccat->value == value_i && prev_ccat->lin_idx == lin_idx_i) {
                     found = true;
                     break;
@@ -1390,6 +1390,7 @@ void PgfParser::suspend(Cont *cont,Item *item,bool do_predict,size_t n_suspended
                         arg_ccat = new CCat;
                         arg_ccat->fid = arg->fid;
                         arg_ccat->epsilon = arg;
+                        arg_ccat->cont = NULL;
                         arg_ccat->state = NULL;
                         arg_ccat->lin_idx = arg->lin_idx;
                         arg_ccat->value = arg->value;

From 5b30a80e3fb1443b0bc7586d9ef59914235df08d Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 12 Aug 2026 12:12:24 +0200
Subject: [PATCH 137/144] more documented categories

---
 src/compiler/www/js/gftranslate.js | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/src/compiler/www/js/gftranslate.js b/src/compiler/www/js/gftranslate.js
index 5ddd45a14..03b063782 100644
--- a/src/compiler/www/js/gftranslate.js
+++ b/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",
-     "V2S", "V2Q", "V2A", "Adv", "Prep"]
+    ["N", "N2", "N3", "PN", "LN", "GN", "SN", "A", "A2",
+     "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)

From 1a0a7f9d09b91e01d6ca652f089480b6b6146986 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 13 Aug 2026 08:11:45 +0200
Subject: [PATCH 138/144] make sure that we don't miss low-prob trees

---
 src/runtime/c/pgf/parser.cxx | 20 +++++++++++++++++++-
 1 file changed, 19 insertions(+), 1 deletion(-)

diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index 3a18d5c50..6c2de6cf1 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -1471,7 +1471,7 @@ void PgfParser::final_item(State *state, CCat *ccat, Item *item, interval_t valu
         estate->expr   = 0;
         estate->prob   = 0;
         estate->hash   = 0;
-        estate->res    = NULL;
+        estate->res    = ccat;
         estate->index  = 0;
         estate->n_args = item->args.size();
         for (size_t i = 0; i < estate->n_args; i++) {
@@ -1480,6 +1480,24 @@ void PgfParser::final_item(State *state, CCat *ccat, Item *item, interval_t valu
         }
         queue.push_back(estate);
         std::push_heap(queue.begin(), queue.end(), estate_comp);
+    } else if (ccat != NULL && ccat->pending.size() > 0) {
+        auto lin = ref<PgfConcrLin>::untagged(item->rule->container);
+        ExprState *estate = new(item->args.size()) ExprState;
+        estate->expr   = u->efun(&lin->name);
+        estate->prob   = ccat->pending[0]->prob-ccat->viterbi_prob+lin->absfun->prob;
+        estate->hash   = 0;
+        estate->res    = ccat;
+        estate->index  = 0;
+        estate->n_args = item->args.size();
+        for (size_t i = 0; i < lin->name.size; i++) {
+            estate->hash = estate->hash * 101 + lin->name.text[i];
+        }
+        for (size_t i = 0; i < estate->n_args; i++) {
+            estate->args[i] = item->args[i];
+            estate->prob += estate->args[i]->viterbi_prob;
+        }
+        queue.push_back(estate);
+        std::push_heap(queue.begin(), queue.end(), estate_comp);
     }
 }
 

From d349c93fb2f6c2f531bdbf952562d49522ca9eec Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 13 Aug 2026 14:21:48 +0200
Subject: [PATCH 139/144] always use overlaps instead of lookup for intervals

---
 src/runtime/c/pgf/intervalmap.h | 28 ----------------------------
 src/runtime/c/pgf/parser.cxx    | 20 ++++++++------------
 2 files changed, 8 insertions(+), 40 deletions(-)

diff --git a/src/runtime/c/pgf/intervalmap.h b/src/runtime/c/pgf/intervalmap.h
index ce8c4cf04..59020fb76 100644
--- a/src/runtime/c/pgf/intervalmap.h
+++ b/src/runtime/c/pgf/intervalmap.h
@@ -66,34 +66,6 @@ class PGF_INTERNAL_DECL interval_map {
         }
     }
 
-    static
-    V *lookup(Node *node, size_t start, size_t end)
-    {
-        if (node == NULL) {
-            return NULL;
-        }
-
-        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) {
-            return lookup(node->left, start, end);
-        } else if (cmp > 0) {
-            return lookup(node->right, start, end);
-        } else {
-            return &node->value;
-        }
-    }
-
     static size_t size(Node *node)
     {
         if (node == 0)
diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index 6c2de6cf1..70244f20d 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -1443,16 +1443,14 @@ void PgfParser::suspend(Cont *cont,Item *item,bool do_predict,size_t n_suspended
                 }
             }
         } else {
+            interval_t lin_idx_i = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
             State *next = cont->state;
             while (next != NULL) {
                 auto it1 = next->completed.find(cont);
                 if (it1 != next->completed.end()) {
-                    auto *it2 = it1->second.lookup(cont->ccat->value);
-                    if (it2 != NULL) {
-                        interval_t lin_idx_i = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
-                        auto *it3 = it2->lookup(lin_idx_i);
-                        if (it3 != NULL) {
-                            CCat *arg = *it3;
+                    for (auto it2 : it1->second.overlaps(cont->ccat->value)) {
+                        for (auto it3 : it2.second.overlaps(lin_idx_i)) {
+                            CCat *arg = it3.second;
                             Item *new_item = new (item) Item;
                             combine(next, new_item, arg);
                         }
@@ -1641,16 +1639,14 @@ void PgfParseTableMaker::suspend(Cont *cont,Item *item,bool do_predict,size_t n_
                 }
             }
         } else {
+            interval_t lin_idx_i = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
             State *next = cont->state;
             while (next != NULL) {
                 auto it1 = next->completed.find(cont);
                 if (it1 != next->completed.end()) {
-                    auto *it2 = it1->second.lookup(cont->ccat->value);
-                    if (it2 != NULL) {
-                        interval_t lin_idx_i = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
-                        auto *it3 = it2->lookup(lin_idx_i);
-                        if (it3 != NULL) {
-                            CCat *arg = *it3;
+                    for (auto it2 : it1->second.overlaps(cont->ccat->value)) {
+                        for (auto it3 : it2.second.overlaps(lin_idx_i)) {
+                            CCat *arg = it3.second;
                             Item *new_item = new (item) Item;
                             combine(next, new_item, arg);
                         }

From 8765c4bd1663e286cd1b171b69e478cc16ff14a5 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sat, 15 Aug 2026 12:44:58 +0200
Subject: [PATCH 140/144] handle empty variants

---
 src/runtime/c/pgf/linearizer.cxx | 60 ++++++++++++++++++--------------
 src/runtime/c/pgf/linearizer.h   | 24 +++++++------
 src/runtime/c/pgf/pgf.cxx        | 12 ++++---
 3 files changed, 55 insertions(+), 41 deletions(-)

diff --git a/src/runtime/c/pgf/linearizer.cxx b/src/runtime/c/pgf/linearizer.cxx
index 9fdc583be..a1090fb0e 100644
--- a/src/runtime/c/pgf/linearizer.cxx
+++ b/src/runtime/c/pgf/linearizer.cxx
@@ -56,7 +56,7 @@ PgfLinearizer::TreeNode::TreeNode(PgfLinearizer *linearizer)
     linearizer->prev = this;
 }
 
-void PgfLinearizer::TreeNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r)
+bool PgfLinearizer::TreeNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r)
 {
     TreeNode *arg = args;
     while (d > 0) {
@@ -67,7 +67,7 @@ void PgfLinearizer::TreeNode::linearize_arg(PgfLinearizationOutputIface *out, Pg
     }
     if (arg == NULL)
         throw pgf_error("Missing argument");
-    arg->linearize(out, linearizer, r);
+    return arg->linearize(out, linearizer, r);
 }
 
 void PgfLinearizer::TreeNode::linearize_var(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r)
@@ -87,7 +87,7 @@ void PgfLinearizer::TreeNode::linearize_var(PgfLinearizationOutputIface *out, Pg
     out->symbol_token(linearizer->printer.get_text());
 }
 
-void PgfLinearizer::TreeNode::linearize_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item, vector<PgfSymbol> syms)
+bool PgfLinearizer::TreeNode::linearize_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item, vector<PgfSymbol> syms)
 {
     for (size_t i = 0; i < syms.size(); i++) {
         PgfSymbol sym = syms[i];
@@ -96,13 +96,15 @@ void PgfLinearizer::TreeNode::linearize_item(PgfLinearizationOutputIface *out, P
         case PgfSymbolCat::tag: {
             auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
             size_t r = item->eval(ref<PgfLParam>::from_ptr(&sym_cat->r));
-            linearize_arg(out, linearizer, sym_cat->d, r);
+            if (!linearize_arg(out, linearizer, sym_cat->d, r))
+                return false;
             break;
         }
         case PgfSymbolLit::tag: {
             auto sym_lit = ref<PgfSymbolLit>::untagged(sym);
             size_t r = item->eval(ref<PgfLParam>::from_ptr(&sym_lit->r));
-            linearize_arg(out, linearizer, sym_lit->d, r);
+            if (!linearize_arg(out, linearizer, sym_lit->d, r))
+                return false;
             break;
         }
         case PgfSymbolVar::tag: {
@@ -205,6 +207,8 @@ void PgfLinearizer::TreeNode::linearize_item(PgfLinearizationOutputIface *out, P
             break;
         }
     }
+
+    return true;
 }
 
 PgfLinearizer::TreeLinNode::TreeLinNode(PgfLinearizer *linearizer, ref<PgfConcrLin> lin)
@@ -261,13 +265,6 @@ bool PgfLinearizer::TreeLinNode::resolve(PgfLinearizer *linearizer)
         rule_index++;
     }
 
-    for (size_t i = 0; i < lin->lincat->fields.size(); i++) {
-        if (items[i] == NULL) {
-            rule_index = 0;
-            return false;
-        }
-    }
-
     return true;
 }
 
@@ -276,8 +273,11 @@ bool PgfLinearizer::TreeLinNode::check_category(PgfLinearizer *linearizer, PgfTe
     return (textcmp(&lin->absfun->type->name, cat) == 0);
 }
 
-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];
 
@@ -294,8 +294,9 @@ void PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, Pgf
         linearizer->pre_stack->bracket_stack = bracket;
     }
 
-    linearize_item(out, linearizer,
-                   items[lindex],items[lindex]->rule->syms.as_vector());
+    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, &lin->name);
@@ -309,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)
@@ -410,23 +413,24 @@ bool PgfLinearizer::TreeLindefNode::check_category(PgfLinearizer *linearizer, Pg
     return true;
 }
 
-void PgfLinearizer::TreeLindefNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t 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) {
-        linearize_arg(out, linearizer, 0, 0);
-        return;
+        return linearize_arg(out, linearizer, 0, 0);
     }
 
     PgfText *cat = &lincat->name;
@@ -445,8 +449,9 @@ void PgfLinearizer::TreeLindefNode::linearize(PgfLinearizationOutputIface *out,
         linearizer->pre_stack->bracket_stack = bracket;
     }
 
-    linearize_item(out, linearizer,
-                   items[lindex],items[lindex]->rule->syms.as_vector());
+    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);
@@ -460,6 +465,7 @@ void PgfLinearizer::TreeLindefNode::linearize(PgfLinearizationOutputIface *out,
         bracket->fun   = linearizer->wild;
         linearizer->pre_stack->bracket_stack = bracket;
     }
+    return true;
 }
 
 ref<PgfConcrLincat> PgfLinearizer::TreeLindefNode::get_lincat(PgfLinearizer *linearizer)
@@ -537,13 +543,13 @@ bool PgfLinearizer::TreeLinrefNode::resolve(PgfLinearizer *linearizer)
     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) {
-        linearize_item(out, linearizer, item, item->rule->syms.as_vector());
+        return linearize_item(out, linearizer, item, item->rule->syms.as_vector());
     } else {
-        args->linearize(out, linearizer, lindex);
+        return args->linearize(out, linearizer, lindex);
     }
 }
 
@@ -569,7 +575,7 @@ bool PgfLinearizer::TreeLitNode::check_category(PgfLinearizer *linearizer, PgfTe
     return (textcmp(&lincat->name, cat) == 0);
 }
 
-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) {
@@ -583,6 +589,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)
diff --git a/src/runtime/c/pgf/linearizer.h b/src/runtime/c/pgf/linearizer.h
index 0976de2fa..7fb99a5ab 100644
--- a/src/runtime/c/pgf/linearizer.h
+++ b/src/runtime/c/pgf/linearizer.h
@@ -83,10 +83,10 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
         TreeNode(PgfLinearizer *linearizer);
         virtual bool resolve(PgfLinearizer *linearizer) { return true; };
         virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat)=0;
-        virtual void linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t 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_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item, vector<PgfSymbol> syms);
-        virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)=0;
+        virtual bool linearize_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item, vector<PgfSymbol> syms);
+        virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)=0;
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer)=0;
         virtual ~TreeNode() { free(hoas_vars); };
     };
@@ -99,7 +99,7 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
         TreeLinNode(PgfLinearizer *linearizer, ref<PgfConcrLin> lin);
         virtual bool resolve(PgfLinearizer *linearizer);
         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();
     };
@@ -114,8 +114,8 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
         TreeLindefNode(PgfLinearizer *linearizer, PgfText *fun, PgfText *lit);
         virtual bool resolve(PgfLinearizer *linearizer);
         virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat);
-        virtual void 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_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r);
+        virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
         ~TreeLindefNode();
     };
@@ -127,7 +127,7 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
         TreeLinrefNode(PgfLinearizer *linearizer, TreeNode *root);
         virtual bool resolve(PgfLinearizer *linearizer);
         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();
     };
@@ -138,7 +138,7 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
 
         TreeLitNode(PgfLinearizer *linearizer, ref<PgfConcrLincat> lincat, PgfText *lit);
         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); };
     };
@@ -147,7 +147,7 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
         TreeChunksNode(PgfLinearizer *linearizer);
         virtual bool resolve(PgfLinearizer *linearizer);
         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);
     };
 
@@ -191,9 +191,11 @@ public:
 
     bool resolve();
     void reverse_and_label(bool add_linref);
-    void linearize(PgfLinearizationOutputIface *out, size_t lindex) {
-        prev->linearize(out, this, lindex);
+    bool linearize(PgfLinearizationOutputIface *out, size_t 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);
diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx
index e71c913eb..2db16e1ef 100644
--- a/src/runtime/c/pgf/pgf.cxx
+++ b/src/runtime/c/pgf/pgf.cxx
@@ -2530,7 +2530,10 @@ PgfText *pgf_linearize(PgfDB *db, PgfConcrRevision revision,
         m->match_expr(&linearizer, expr);
         linearizer.reverse_and_label(true);
         if (linearizer.resolve()) {
-            linearizer.linearize(&out, 0);
+            if (!linearizer.linearize(&out, 0)) {
+                free(out.get_text());
+                return NULL;
+            }
             return out.get_text();
         }
     } PGF_API_END
@@ -2594,12 +2597,13 @@ PgfText **pgf_tabular_linearize(PgfDB *db, PgfConcrRevision revision,
                     throw pgf_systemerror(ENOMEM);
                 size_t pos = 0;
                 for (size_t i = 0; i < lincat->fields.size(); i++) {
-                    linearizer.linearize(&out, i);
-
+                    bool ok = linearizer.linearize(&out, i);
                     PgfText *text = out.get_text();
-                    if (text != NULL) {
+                    if (ok) {
                         res[pos++] = textdup(&*lincat->fields[i]);
                         res[pos++] = text;
+                    } else {
+                        free(text);
                     }
                 }
                 res[pos++] = NULL;

From 488b42462600fb4d04dddbc7fd3854072452a26a Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Sat, 15 Aug 2026 17:54:01 +0200
Subject: [PATCH 141/144] in the destructor make sure that we don't delete NULL
 items

---
 src/runtime/c/pgf/linearizer.cxx | 15 +++++----------
 1 file changed, 5 insertions(+), 10 deletions(-)

diff --git a/src/runtime/c/pgf/linearizer.cxx b/src/runtime/c/pgf/linearizer.cxx
index a1090fb0e..4dfe84201 100644
--- a/src/runtime/c/pgf/linearizer.cxx
+++ b/src/runtime/c/pgf/linearizer.cxx
@@ -323,7 +323,8 @@ PgfLinearizer::TreeLinNode::~TreeLinNode()
 {
     size_t n_fields = lin->lincat->fields.size();
     for (size_t i = 0; i < n_fields; i++) {
-        delete items[i];
+        if (items[i] != NULL)
+            delete items[i];
     }
     delete[] items;
 };
@@ -395,13 +396,6 @@ bool PgfLinearizer::TreeLindefNode::resolve(PgfLinearizer *linearizer)
         rule_index++;
     }
 
-    for (size_t i = 0; i < lincat->fields.size(); i++) {
-        if (items[i] == NULL) {
-            rule_index = 0;
-            return false;
-        }
-    }
-
     return true;
 }
 
@@ -475,10 +469,11 @@ ref<PgfConcrLincat> PgfLinearizer::TreeLindefNode::get_lincat(PgfLinearizer *lin
 
 PgfLinearizer::TreeLindefNode::~TreeLindefNode()
 {
-    if (lincat) {
+    if (lincat && items != NULL) {
         size_t n_fields = lincat->fields.size();
         for (size_t i = 0; i < n_fields; i++) {
-            delete items[i];
+            if (items[i] != NULL)
+                delete items[i];
         }
         delete[] items;
     }

From b7a911faf831ed73116a0e5d1c8f79994cd2f3fe Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Mon, 17 Aug 2026 14:33:14 +0200
Subject: [PATCH 142/144] minimize top-down predictions

---
 src/runtime/c/pgf/parser.cxx | 345 ++++++++++++++++++-----------------
 src/runtime/c/pgf/parser.h   |  18 +-
 2 files changed, 186 insertions(+), 177 deletions(-)

diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index 70244f20d..e70cdae93 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -150,16 +150,14 @@ void PgfAbstractParser::symbol(Item *item, State *state, PgfSymbol sym)
                     cont->state = state;
                 }
 
-                interval_t value_i = item->interval(item->rule->args[symcat->d]);
-                interval_t lin_idx_i = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
-                auto &suspended = cont->suspended[value_i][lin_idx_i];
-                suspended.push_back(item);
+                interval_t value_i   = interval(item->rule, &item->vars[0], item->rule->args[symcat->d]);
+                interval_t lin_idx_i = interval(item->rule, &item->vars[0], ref<PgfLParam>::from_ptr(&symcat->r));
 
-                suspend(cont,item,n_suspended1 == 0,suspended.size(),symcat);
+                suspend(cont,item,n_suspended1 == 0,symcat,value_i,lin_idx_i);
             }
         } else {
-            interval_t value_i   = item->interval(item->rule->args[symcat->d]);
-            interval_t lin_idx_i = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
+            interval_t value_i   = interval(item->rule, &item->vars[0], item->rule->args[symcat->d]);
+            interval_t lin_idx_i = interval(item->rule, &item->vars[0], ref<PgfLParam>::from_ptr(&symcat->r));
 
             // the following prevents infinite loops with epsilons
             bool found = false;
@@ -199,12 +197,8 @@ void PgfAbstractParser::symbol(Item *item, State *state, PgfSymbol sym)
                     }
                 }
             }
-found:;
-
-            auto &suspended = cont->suspended[value_i][lin_idx_i];
-            suspended.push_back(item);
-
-            suspend(cont,item,!subsumed,suspended.size(),symcat);
+found:
+            suspend(cont,item,!subsumed,symcat,value_i,lin_idx_i);
         }
         break;
     }
@@ -264,8 +258,8 @@ void PgfAbstractParser::complete(Item *item, State *state)
     case PgfConcrLin::tag: {
         auto lin = ref<PgfConcrLin>::untagged(item->rule->container);
 
-        interval_t res = item->interval(item->rule->res);
-        interval_t lin_idx = item->interval(item->rule->lin_idx);
+        interval_t res = interval(item->rule, &item->vars[0], item->rule->res);
+        interval_t lin_idx = interval(item->rule, &item->vars[0], item->rule->lin_idx);
         CCat *&ccat = state->completed[item->cont][res][lin_idx];
         if (ccat == NULL) {
             ccat = new CCat;
@@ -360,38 +354,25 @@ void PgfAbstractParser::complete(Item *item, State *state)
     delete item;
 }
 
-interval_t PgfAbstractParser::Item::interval(ref<PgfLParam> lparam) const
-{
-    interval_t interval;
-    interval.first  = lparam->i0;
-    interval.second = interval.first;
-    for (size_t i = 0; i < lparam->n_terms; i++) {
-        size_t var = lparam->terms[i].var;
-        if (vars[var] == 0) {
-            interval.second += lparam->terms[i].factor * (rule->ranges[var]-1);
-        } else {
-            size_t value = lparam->terms[i].factor * (vars[var]-1);
-            interval.first  += value;
-            interval.second += value;
-        }
-    }
-    return interval;
-}
+#define ZERO_VALUES(rule) \
+    ((size_t*) memset(alloca(rule->ranges.size()*sizeof(size_t)), 0, rule->ranges.size()*sizeof(size_t)))
+#define CLONE_VALUES(rule,values) \
+    ((size_t*) memcpy(alloca(rule->ranges.size()*sizeof(size_t)), values, rule->ranges.size()*sizeof(size_t)))
 
-bool PgfAbstractParser::Item::instantiate(ref<PgfLParam> lparam1,
-                                          PgfConcrRule *rule, size_t *values, ref<PgfLParam> lparam2)
+bool PgfAbstractParser::instantiate(ref<PgfConcrRule> rule1, size_t *values1, ref<PgfLParam> lparam1,
+                                    ref<PgfConcrRule> rule2, size_t *values2, ref<PgfLParam> lparam2)
 {
     size_t i01 = lparam1->i0;
     for (size_t i = 0; i < lparam1->n_terms; i++) {
-        if (this->vars[lparam1->terms[i].var] > 0) {
-            i01 += lparam1->terms[i].factor * (this->vars[lparam1->terms[i].var]-1);
+        if (values1[lparam1->terms[i].var] > 0) {
+            i01 += lparam1->terms[i].factor * (values1[lparam1->terms[i].var]-1);
         }
     }
 
     size_t i02 = lparam2->i0;
     for (size_t i = 0; i < lparam2->n_terms; i++) {
-        if (values[lparam2->terms[i].var] > 0) {
-            i02 += lparam2->terms[i].factor * (values[lparam2->terms[i].var]-1);
+        if (values2[lparam2->terms[i].var] > 0) {
+            i02 += lparam2->terms[i].factor * (values2[lparam2->terms[i].var]-1);
         }
     }
 
@@ -409,22 +390,22 @@ bool PgfAbstractParser::Item::instantiate(ref<PgfLParam> lparam1,
         term t1 = {0,0};
         if (i1 < lparam1->n_terms) {
             t1 = lparam1->terms[i1];
-            if (this->vars[t1.var] > 0) {
+            if (values1[t1.var] > 0) {
                 i1++;
                 continue;
             }
-            scale1 = t1.factor * this->rule->ranges[t1.var];
+            scale1 = t1.factor * rule1->ranges[t1.var];
         }
 
         size_t scale2  = 0;
         term t2 = {0,0};
         if (i2 < lparam2->n_terms) {
             t2 = lparam2->terms[i2];
-            if (values[t2.var] > 0) {
+            if (values2[t2.var] > 0) {
                 i2++;
                 continue;
             }
-            scale2 = t2.factor * rule->ranges[t2.var];
+            scale2 = t2.factor * rule2->ranges[t2.var];
         }
 
         if (scale1 > scale2) {
@@ -436,20 +417,20 @@ bool PgfAbstractParser::Item::instantiate(ref<PgfLParam> lparam1,
                 if (f == 0)
                     break;
 
-                if (values[t2.var] == 0) {
-                    max += f * (rule->ranges[t2.var]-1);
+                if (values2[t2.var] == 0) {
+                    max += f * (rule2->ranges[t2.var]-1);
                 }
                 i2++;
             }
             i02 %= t1.factor;
 
-            if (min >= this->rule->ranges[t1.var])
+            if (min >= rule1->ranges[t1.var])
                 return false;
 
             if (min == max) {
-                if (this->vars[t1.var] == 0)
-                    this->vars[t1.var] = min+1;
-                else if (this->vars[t1.var] != min+1)
+                if (values1[t1.var] == 0)
+                    values1[t1.var] = min+1;
+                else if (values1[t1.var] != min+1)
                     return false;
             }
 
@@ -463,30 +444,48 @@ bool PgfAbstractParser::Item::instantiate(ref<PgfLParam> lparam1,
                 if (f == 0)
                     break;
 
-                if (values[t1.var] == 0) {
-                    max += f * (rule->ranges[t1.var]-1);
+                if (values1[t1.var] == 0) {
+                    max += f * (rule1->ranges[t1.var]-1);
                 }
                 i1++;
             }
             i01 %= t2.factor;
 
-            if (min >= rule->ranges[t2.var])
+            if (min >= rule2->ranges[t2.var])
                 return false;
 
             if (min == max) {
-                if (values[t2.var] == 0) {
-                    // we don't update the production;
-                } else if (values[t2.var] != min+1)
+                if (values2[t2.var] == 0) {
+                    values2[t2.var] = min+1;
+                } else if (values2[t2.var] != min+1)
                     return false;
             }
 
             i2++;
         }
     }
-    
+
     return (i01 == i02);
 }
 
+interval_t PgfAbstractParser::interval(ref<PgfConcrRule> rule, size_t *values, ref<PgfLParam> lparam)
+{
+    interval_t interval;
+    interval.first  = lparam->i0;
+    interval.second = interval.first;
+    for (size_t i = 0; i < lparam->n_terms; i++) {
+        size_t var = lparam->terms[i].var;
+        if (values[var] == 0) {
+            interval.second += lparam->terms[i].factor * (rule->ranges[var]-1);
+        } else {
+            size_t value = lparam->terms[i].factor * (values[var]-1);
+            interval.first  += value;
+            interval.second += value;
+        }
+    }
+    return interval;
+}
+
 void PgfAbstractParser::combine(State *state, Item *item, CCat *ccat)
 {
     PgfSymbol sym = item->rule->syms[item->dot];
@@ -495,11 +494,15 @@ void PgfAbstractParser::combine(State *state, Item *item, CCat *ccat)
     ref<PgfConcrRule> rule;
     size_t *values;
     get_info(ccat, &rule,&values);
-    if (!item->instantiate(item->rule->args[sym_cat->d], rule, values, rule->res)) {
+    values = CLONE_VALUES(rule, values);
+
+    if (!instantiate(item->rule, &item->vars[0], item->rule->args[sym_cat->d],
+                     rule,       values,         rule->res)) {
         delete item;
         return;
     }
-    if (!item->instantiate(ref<PgfLParam>::from_ptr(&sym_cat->r), rule, values, rule->lin_idx)) {
+    if (!instantiate(item->rule, &item->vars[0], ref<PgfLParam>::from_ptr(&sym_cat->r),
+                     rule,       values,         rule->lin_idx)) {
         delete item;
         return;
     }
@@ -520,38 +523,52 @@ void PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref<PgfItem> pitem,
         auto lin = ref<PgfConcrLin>::untagged(pitem->rule->container);
 
         for (ref<PgfConcrRule> rule : lin->rules) {
-            Item *item = new (rule) Item;
-            item->cont    = cont;
-            item->dot     = 0;
-            item->pre_alt = 0;
-            item->pre_dot = 0;
-            item->syms    = rule->syms.as_vector();
-            item->rule    = rule;
-            item->inside_prob = lin->absfun->prob;
-            item->outside_prob = xitem->outside_prob+xitem->inside_prob-xitem->args[symcat->d]->viterbi_prob;
-
-            if (!item->instantiate(item->rule->res, xitem->rule, &xitem->vars[0], xitem->rule->args[symcat->d])) {
-                delete item;
+            size_t *values1 = ZERO_VALUES(rule);
+            size_t *values2 = CLONE_VALUES(xitem->rule, &xitem->vars[0]);
+            if (!instantiate(rule,        values1, rule->res,
+                             xitem->rule, values2, xitem->rule->args[symcat->d])) {
                 continue;
             }
-            if (!item->instantiate(item->rule->lin_idx, xitem->rule, &xitem->vars[0], ref<PgfLParam>::from_ptr(&symcat->r))) {
-                delete item;
+            if (!instantiate(rule,        values1, rule->lin_idx,
+                             xitem->rule, values2, ref<PgfLParam>::from_ptr(&symcat->r))) {
                 continue;
             }
 
+            size_t *values3 = CLONE_VALUES(pitem->rule, &pitem->vars[0]);
             for (size_t i = 0; i < pitem->args.size(); i++) {
-                if (pitem->args[i] != 0) {
-                    item->args[i] = get_epsilon_ccat(&lin->absfun->type->hypos[i].type->name,pitem->args[i]);
-                    item->inside_prob += item->args[i]->viterbi_prob;
-                }
-
-                if (!item->instantiate(item->rule->args[i], pitem->rule, &pitem->vars[0], pitem->rule->args[i])) {
-                    delete item;
+                if (!instantiate(rule,        values1, rule->args[i],
+                                 pitem->rule, values3, pitem->rule->args[i])) {
                     goto next;
                 }
             }
 
-            state->push_item(item);
+            {
+                interval_t value_i   = interval(rule, values1, rule->res);
+                interval_t lin_idx_i = interval(rule, values1, rule->lin_idx);
+                Item *&pred = cont->predicted[value_i][lin_idx_i];
+                if (pred != NULL && pred != xitem)
+                    return;
+                pred = xitem;
+
+                Item *item = new (rule) Item;
+                item->cont    = cont;
+                item->dot     = 0;
+                item->pre_alt = 0;
+                item->pre_dot = 0;
+                item->syms    = rule->syms.as_vector();
+                item->rule    = rule;
+                item->inside_prob = lin->absfun->prob;
+                item->outside_prob = xitem->outside_prob+xitem->inside_prob-xitem->args[symcat->d]->viterbi_prob;
+
+                for (size_t i = 0; i < pitem->args.size(); i++) {
+                    if (pitem->args[i] != 0) {
+                        item->args[i] = get_epsilon_ccat(&lin->absfun->type->hypos[i].type->name,pitem->args[i]);
+                        item->inside_prob += item->args[i]->viterbi_prob;
+                    }
+                }
+
+                state->push_item(item);
+            }
 next:;
         }
     }
@@ -567,38 +584,54 @@ void PgfAbstractParser::td_predict(State *state, Cont *cont, Production *prod, I
         auto lin = ref<PgfConcrLin>::untagged(prod->rule->container);
 
         for (ref<PgfConcrRule> rule : lin->rules) {
-            Item *item = new (rule) Item;
-            item->cont    = cont;
-            item->dot     = 0;
-            item->pre_alt = 0;
-            item->pre_dot = 0;
-            item->syms    = rule->syms.as_vector();
-            item->rule    = rule;
-            item->inside_prob = lin->absfun->prob;
-            item->outside_prob = xitem->outside_prob+xitem->inside_prob-xitem->args[symcat->d]->viterbi_prob;
-
-            if (!item->instantiate(item->rule->res, xitem->rule, &xitem->vars[0], xitem->rule->args[symcat->d])) {
-                delete item;
+            size_t *values1 = ZERO_VALUES(rule);
+            size_t *values2 = CLONE_VALUES(xitem->rule, &xitem->vars[0]);
+            if (!instantiate(rule,        values1, rule->res,
+                             xitem->rule, values2, xitem->rule->args[symcat->d])) {
                 continue;
             }
 
-            if (!item->instantiate(item->rule->lin_idx, xitem->rule, &xitem->vars[0], ref<PgfLParam>::from_ptr(&symcat->r))) {
-                delete item;
+            if (!instantiate(rule,        values1, rule->lin_idx,
+                             xitem->rule, values2, ref<PgfLParam>::from_ptr(&symcat->r))) {
                 continue;
             }
 
-            for (size_t i = 0; i < item->args.size(); i++) {
-                if (!item->instantiate(item->rule->args[i], prod->rule, &prod->vars[0], prod->rule->args[i])) {
-                    delete item;
+            size_t *values3 = CLONE_VALUES(prod->rule, &prod->vars[0]);
+            for (size_t i = 0; i < rule->args.size(); i++) {
+                if (!instantiate(rule,       values1, rule->args[i],
+                                 prod->rule, values3, prod->rule->args[i])) {
                     goto next;
                 }
-                item->args[i] = prod->args[i];
-                if (item->args[i] != NULL) {
-                    item->inside_prob += item->args[i]->viterbi_prob;
-                }
             }
 
-            state->push_item(item);
+            {
+                interval_t value_i   = interval(rule, values1, rule->res);
+                interval_t lin_idx_i = interval(rule, values1, rule->lin_idx);
+                Item *&pred = cont->predicted[value_i][lin_idx_i];
+                if (pred != NULL && pred != xitem)
+                    return;
+                pred = xitem;
+
+                Item *item = new (rule) Item;
+                item->cont    = cont;
+                item->dot     = 0;
+                item->pre_alt = 0;
+                item->pre_dot = 0;
+                item->syms    = rule->syms.as_vector();
+                item->rule    = rule;
+                item->inside_prob = lin->absfun->prob;
+                item->outside_prob = xitem->outside_prob+xitem->inside_prob-xitem->args[symcat->d]->viterbi_prob;
+
+                for (size_t i = 0; i < rule->args.size(); i++) {
+                    item->args[i] = prod->args[i];
+                    if (item->args[i] != NULL) {
+                        item->inside_prob += item->args[i]->viterbi_prob;
+                    }
+                }
+
+                state->push_item(item);
+            }
+
 next:;
         }
     }
@@ -1364,24 +1397,29 @@ void PgfParser::symbol_bind(Item *item, State *state, PgfSymbol sym)
     }
 }
 
-void PgfParser::suspend(Cont *cont,Item *item,bool do_predict,size_t n_suspended,ref<PgfSymbolCat> symcat)
+void PgfParser::suspend(Cont *cont,Item *item,bool do_predict,ref<PgfSymbolCat> symcat,interval_t value_i,interval_t lin_idx_i)
 {
+    auto &suspended = cont->suspended[value_i][lin_idx_i];
+    suspended.push_back(item);
+
+    size_t n_suspended = suspended.size();
     if (cont->ccat == NULL) {
         if (n_suspended == 1) {
             std::function<void(ref<PgfCCat>)> f =
                 [this,item,cont](ref<PgfCCat> arg) {
 
-                    ref<PgfItem> xitem = arg->items[0];
+                    ref<PgfItem> pitem = arg->items[0];
 
-                    Item *new_item = new (item) Item;
-                    PgfSymbol sym = new_item->rule->syms[new_item->dot];
+                    PgfSymbol sym = item->rule->syms[item->dot];
                     auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
-                    if (!new_item->instantiate(new_item->rule->args[sym_cat->d],xitem->rule,&xitem->vars[0],xitem->rule->res)) {
-                        delete new_item;
+                    size_t *values1 = CLONE_VALUES(item->rule,  &item->vars[0]);
+                    size_t *values2 = CLONE_VALUES(pitem->rule, &pitem->vars[0]);
+                    if (!instantiate(item->rule,  values1, item->rule->args[sym_cat->d],
+                                     pitem->rule, values2, pitem->rule->res)) {
                         return;
                     }
-                    if (!new_item->instantiate(ref<PgfLParam>::from_ptr(&sym_cat->r),xitem->rule,&xitem->vars[0],xitem->rule->lin_idx)) {
-                        delete new_item;
+                    if (!instantiate(item->rule,  values1, ref<PgfLParam>::from_ptr(&sym_cat->r),
+                                     pitem->rule, values2, pitem->rule->lin_idx)) {
                         return;
                     }
 
@@ -1399,30 +1437,10 @@ void PgfParser::suspend(Cont *cont,Item *item,bool do_predict,size_t n_suspended
                     }
 
                     cont->state->completed[cont][arg_ccat->value][arg_ccat->lin_idx] = arg_ccat;
-
-                    new_item->dot++;
-                    new_item->args[sym_cat->d] = arg_ccat;
-                    new_item->inside_prob += arg_ccat->viterbi_prob;
-
-                    cont->state->push_item(new_item);
                 };
             epsilontable_iter(concr->epsilontable,cont->lincat,f);
         }
 
-        State *state = cont->state;
-        while (state != NULL) {
-            auto it1 = state->completed.find(cont);
-            if (it1 != state->completed.end()) {
-                for (auto it2 : it1->second) {
-                    for (auto it3 : it2.second) {
-                        Item *new_item = new (item) Item;
-                        combine(state, new_item, it3.second);
-                    }
-                }
-            }
-            state = state->next;
-        }
-
         if (do_predict) {
             if (cont->state->needs_bind) {
                 bu_predict(concr->phrasetable4, cont->state);
@@ -1442,23 +1460,21 @@ void PgfParser::suspend(Cont *cont,Item *item,bool do_predict,size_t n_suspended
                     td_predict(cont->state,cont,prod,item,symcat);
                 }
             }
-        } else {
-            interval_t lin_idx_i = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
-            State *next = cont->state;
-            while (next != NULL) {
-                auto it1 = next->completed.find(cont);
-                if (it1 != next->completed.end()) {
-                    for (auto it2 : it1->second.overlaps(cont->ccat->value)) {
-                        for (auto it3 : it2.second.overlaps(lin_idx_i)) {
-                            CCat *arg = it3.second;
-                            Item *new_item = new (item) Item;
-                            combine(next, new_item, arg);
-                        }
-                    }
+        }
+    }
+
+    State *state = cont->state;
+    while (state != NULL) {
+        auto it1 = state->completed.find(cont);
+        if (it1 != state->completed.end()) {
+            for (auto it2 : it1->second.overlaps(value_i)) {
+                for (auto it3 : it2.second.overlaps(lin_idx_i)) {
+                    Item *new_item = new (item) Item;
+                    combine(state, new_item, it3.second);
                 }
-                next = next->next;
             }
         }
+        state = state->next;
     }
 }
 
@@ -1610,19 +1626,13 @@ void PgfParseTableMaker::symbol_bind(Item *item, State *state, PgfSymbol sym)
     }
 }
 
-void PgfParseTableMaker::suspend(Cont *cont,Item *item,bool do_predict,size_t n_suspended,ref<PgfSymbolCat> symcat)
+void PgfParseTableMaker::suspend(Cont *cont,Item *item,bool do_predict,ref<PgfSymbolCat> symcat,interval_t value_i,interval_t lin_idx_i)
 {
-    if (cont->ccat == NULL) {
-        for (auto it1 : cont->state->completed[cont]) {
-            for (auto it2 : it1.second) {
-                CCat *ccat = it2.second;
-                if (ccat != NULL) {
-                    Item *new_item = new (item) Item;
-                    combine(cont->state,new_item,ccat);
-                }
-            }
-        }
+    auto &suspended = cont->suspended[value_i][lin_idx_i];
+    suspended.push_back(item);
 
+    size_t n_suspended = suspended.size();
+    if (cont->ccat == NULL) {
         auto pitem = clone_item(item);
         auto phrasetable2 = phrasetable_insert(concr->phrasetable2,cont->lincat,pitem);
         concr->phrasetable2 = phrasetable2;
@@ -1638,28 +1648,23 @@ void PgfParseTableMaker::suspend(Cont *cont,Item *item,bool do_predict,size_t n_
                     td_predict(cont->state,cont,prod,item,symcat);
                 }
             }
-        } else {
-            interval_t lin_idx_i = item->interval(ref<PgfLParam>::from_ptr(&symcat->r));
-            State *next = cont->state;
-            while (next != NULL) {
-                auto it1 = next->completed.find(cont);
-                if (it1 != next->completed.end()) {
-                    for (auto it2 : it1->second.overlaps(cont->ccat->value)) {
-                        for (auto it3 : it2.second.overlaps(lin_idx_i)) {
-                            CCat *arg = it3.second;
-                            Item *new_item = new (item) Item;
-                            combine(next, new_item, arg);
-                        }
-                    }
-                }
-                next = next->next;
-            }
         }
 
         auto pitem = clone_item(item);
         auto phrasetable3 = phrasetable_insert(concr->phrasetable3,cont->ccat->epsilon,pitem);
         concr->phrasetable3 = phrasetable3;
     }
+
+    auto it1 = cont->state->completed.find(cont);
+    if (it1 != cont->state->completed.end()) {
+        for (auto it2 : it1->second.overlaps(value_i)) {
+            for (auto it3 : it2.second.overlaps(lin_idx_i)) {
+                CCat *arg = it3.second;
+                Item *new_item = new (item) Item;
+                combine(cont->state, new_item, arg);
+            }
+        }
+    }
 }
 
 void PgfParseTableMaker::final_item(State *state, CCat *ccat, Item *item, interval_t value, interval_t lin_idx)
diff --git a/src/runtime/c/pgf/parser.h b/src/runtime/c/pgf/parser.h
index c9b8c6cef..6811a7fa4 100644
--- a/src/runtime/c/pgf/parser.h
+++ b/src/runtime/c/pgf/parser.h
@@ -128,6 +128,7 @@ protected:
         ref<PgfConcrLincat> lincat;
         State *state;
         interval_map<interval_map<std::vector<Item*>>> suspended;
+        interval_map<interval_map<Item*>> predicted;
 
         ~Cont();
     };
@@ -189,10 +190,6 @@ protected:
         
         Item() {
         }
-
-        interval_t interval(ref<PgfLParam> lparam) const;
-        bool instantiate(ref<PgfLParam> lparam1,
-                         PgfConcrRule *rule, size_t *values, ref<PgfLParam> lparam2);
     };
 
     static struct ItemComparator : std::less<Item*> {
@@ -239,7 +236,7 @@ protected:
     virtual State *new_state(const PgfTextSpot &start)=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, size_t n_suspended,ref<PgfSymbolCat> symcat)=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, CCat *ccat)=0;
 
@@ -247,6 +244,13 @@ protected:
     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);
 
@@ -272,7 +276,7 @@ class PGF_INTERNAL_DECL PgfParser : private PgfAbstractParser, public PgfExprEnu
     virtual State *new_state(const PgfTextSpot &start);
     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,size_t n_suspended,ref<PgfSymbolCat> symcat);
+    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, CCat *ccat);
 
@@ -314,7 +318,7 @@ private:
     virtual State *new_state(const PgfTextSpot &start);
     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, size_t n_suspended,ref<PgfSymbolCat> symcat);
+    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, CCat *ccat);
 

From 56026271ff886cf7cc11d3cbdc73208f4f0422fc Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Tue, 18 Aug 2026 15:44:28 +0200
Subject: [PATCH 143/144] more effective filtering for duplicates

---
 src/runtime/c/pgf/parser.cxx | 62 ++++++++++++++++++++++++++----------
 src/runtime/c/pgf/parser.h   | 22 +++++++------
 2 files changed, 59 insertions(+), 25 deletions(-)

diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index e70cdae93..b14754145 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -313,6 +313,9 @@ void PgfAbstractParser::complete(Item *item, State *state)
 #endif
         final_item(state, ccat, item, res, lin_idx);
 
+        if (ccat->cont == NULL)
+            break;
+
         if (ccat->prods.size() == 1) {
             bu_predict(state, ccat);
 
@@ -516,6 +519,23 @@ void PgfAbstractParser::combine(State *state, Item *item, CCat *ccat)
     state->push_item(item);
 }
 
+bool PgfAbstractParser::ItemComparator::operator()(Item *item1, Item *item2)
+{
+    if (item1->rule.as_object() < item2->rule.as_object())
+        return true;
+    else if (item1->rule.as_object() > item2->rule.as_object())
+        return false;
+
+    for (size_t j = 0; j < item1->args.size(); j++) {
+        if (item1->args[j] < item2->args[j])
+            return true;
+        else if (item1->args[j] > item2->args[j])
+            return false;
+    }
+
+    return false;
+}
+
 void PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref<PgfItem> pitem, Item *xitem, ref<PgfSymbolCat> symcat)
 {
     switch (ref<object>::get_tag(pitem->rule->container)) {
@@ -543,13 +563,6 @@ void PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref<PgfItem> pitem,
             }
 
             {
-                interval_t value_i   = interval(rule, values1, rule->res);
-                interval_t lin_idx_i = interval(rule, values1, rule->lin_idx);
-                Item *&pred = cont->predicted[value_i][lin_idx_i];
-                if (pred != NULL && pred != xitem)
-                    return;
-                pred = xitem;
-
                 Item *item = new (rule) Item;
                 item->cont    = cont;
                 item->dot     = 0;
@@ -560,14 +573,26 @@ void PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref<PgfItem> pitem,
                 item->inside_prob = lin->absfun->prob;
                 item->outside_prob = xitem->outside_prob+xitem->inside_prob-xitem->args[symcat->d]->viterbi_prob;
 
+                size_t *values3 = CLONE_VALUES(pitem->rule, &pitem->vars[0]);
                 for (size_t i = 0; i < pitem->args.size(); i++) {
                     if (pitem->args[i] != 0) {
+                        if (!instantiate(rule,        &item->vars[0], rule->args[i],
+                                         pitem->rule, values3,        pitem->rule->args[i])) {
+                            delete item;
+                            goto next;
+                        }
+
                         item->args[i] = get_epsilon_ccat(&lin->absfun->type->hypos[i].type->name,pitem->args[i]);
                         item->inside_prob += item->args[i]->viterbi_prob;
                     }
                 }
 
-                state->push_item(item);
+                auto res = cont->predicted.insert(item);
+                if (res.second) {
+                    state->push_item(item);
+                } else {
+                    delete item;
+                }
             }
 next:;
         }
@@ -605,13 +630,6 @@ void PgfAbstractParser::td_predict(State *state, Cont *cont, Production *prod, I
             }
 
             {
-                interval_t value_i   = interval(rule, values1, rule->res);
-                interval_t lin_idx_i = interval(rule, values1, rule->lin_idx);
-                Item *&pred = cont->predicted[value_i][lin_idx_i];
-                if (pred != NULL && pred != xitem)
-                    return;
-                pred = xitem;
-
                 Item *item = new (rule) Item;
                 item->cont    = cont;
                 item->dot     = 0;
@@ -622,14 +640,26 @@ void PgfAbstractParser::td_predict(State *state, Cont *cont, Production *prod, I
                 item->inside_prob = lin->absfun->prob;
                 item->outside_prob = xitem->outside_prob+xitem->inside_prob-xitem->args[symcat->d]->viterbi_prob;
 
+                size_t *values3 = CLONE_VALUES(prod->rule, &prod->vars[0]);
                 for (size_t i = 0; i < rule->args.size(); i++) {
+                    if (!instantiate(rule,       &item->vars[0], rule->args[i],
+                                     prod->rule, values3,        prod->rule->args[i])) {
+                        delete item;
+                        goto next;
+                    }
+
                     item->args[i] = prod->args[i];
                     if (item->args[i] != NULL) {
                         item->inside_prob += item->args[i]->viterbi_prob;
                     }
                 }
 
-                state->push_item(item);
+                auto res = cont->predicted.insert(item);
+                if (res.second) {
+                    state->push_item(item);
+                } else {
+                    delete item;
+                }
             }
 
 next:;
diff --git a/src/runtime/c/pgf/parser.h b/src/runtime/c/pgf/parser.h
index 6811a7fa4..f5016b8b0 100644
--- a/src/runtime/c/pgf/parser.h
+++ b/src/runtime/c/pgf/parser.h
@@ -112,23 +112,33 @@ protected:
 
         void push_item(Item *item) {
             queue.push_back(item);
-            std::push_heap(queue.begin(), queue.end(), item_comp);
+            std::push_heap(queue.begin(), queue.end(), item_prob_comp);
         }
 
         Item *pop_item() {
             Item *item = queue.front();
-            std::pop_heap(queue.begin(), queue.end(), item_comp);
+            std::pop_heap(queue.begin(), queue.end(), item_prob_comp);
             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;
-        interval_map<interval_map<Item*>> predicted;
+        std::set<Item*,ItemComparator> predicted;
 
         ~Cont();
     };
@@ -192,12 +202,6 @@ protected:
         }
     };
 
-    static struct ItemComparator : std::less<Item*> {
-        bool operator()(Item *item1, Item *item2) {
-            return item1->inside_prob+item1->outside_prob > item2->inside_prob+item2->outside_prob;
-        }
-    } item_comp;
-
     struct ExprState {
         PgfExpr expr;
         prob_t prob;

From 6c2aeb6b950079b6b057052c95acc7ae3fae3b98 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Wed, 19 Aug 2026 11:41:09 +0200
Subject: [PATCH 144/144] implemented A* search

---
 src/runtime/c/pgf/parser.cxx | 55 ++++++++++++++++++++----------------
 src/runtime/c/pgf/parser.h   | 19 +++++++------
 2 files changed, 41 insertions(+), 33 deletions(-)

diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx
index b14754145..f367f7b09 100644
--- a/src/runtime/c/pgf/parser.cxx
+++ b/src/runtime/c/pgf/parser.cxx
@@ -317,7 +317,7 @@ void PgfAbstractParser::complete(Item *item, State *state)
             break;
 
         if (ccat->prods.size() == 1) {
-            bu_predict(state, ccat);
+            bu_predict(state, item->outside_prob, ccat);
 
             for (auto it1 : ccat->cont->suspended.overlaps(ccat->value)) {
                 for (auto it2 : it1.second.overlaps(ccat->lin_idx)) {
@@ -899,7 +899,7 @@ PgfParser::~PgfParser()
 }
 
 void PgfParser::bu_predict(PgfPhrasetable<PgfSymbolKS> phrasetable,
-                           State *state,
+                           State *state, prob_t outside_prob,
                            ptrdiff_t min, ptrdiff_t max)
 {
     if (phrasetable == 0)
@@ -908,40 +908,41 @@ void PgfParser::bu_predict(PgfPhrasetable<PgfSymbolKS> phrasetable,
     PgfTextSpot current = state->end;
     int cmp = text_symbol_cmp(&current,end,phrasetable->value.key,case_sensitive);
     if (cmp < 0) {
-        bu_predict(phrasetable->left,state,min,max);
+        bu_predict(phrasetable->left,state,outside_prob,min,max);
     } else if (cmp > 0) {
         ptrdiff_t len = current.ptr - state->end.ptr;
 
         if (min <= len-1)
-            bu_predict(phrasetable->left,state,min,len-1);
+            bu_predict(phrasetable->left,state,outside_prob,min,len-1);
 
         if (len <= max)
-            bu_predict(phrasetable->right,state,len,max);
+            bu_predict(phrasetable->right,state,outside_prob,len,max);
     } else {
         ptrdiff_t len = current.ptr - state->end.ptr;
 
         if (min <= len)
-            bu_predict(phrasetable->left,state,min,len);
+            bu_predict(phrasetable->left,state,outside_prob,min,len);
 
         if (len > 0) {
-            State *next_state = new_state(current);
             for (size_t i = 0; i < phrasetable->value.n_items; i++) {
-                std::map<ref<PgfConcrLincat>, bool> visited;
+                //std::map<ref<PgfConcrLincat>, bool> visited;
                 //if (!td_reachable(state, phrasetable->items[i], visited))
                 //    continue;
-                Item *item = bu_item(state, phrasetable->value.items[i]);
+                Item *item = bu_item(state, outside_prob, phrasetable->value.items[i]);
                 item->dot++;
+
+                State *next_state = new_state(current,item->outside_prob+item->inside_prob);
                 next_state->push_item(item);
             }
         }
 
         if (len <= max)
-            bu_predict(phrasetable->right,state,len,max);
+            bu_predict(phrasetable->right,state,outside_prob,len,max);
      }
 }
 
 void PgfParser::bu_predict(PgfPhrasetable<PgfSymbolBIND> phrasetable,
-                           State *state)
+                           State *state, prob_t outside_prob)
 {
     size_t n_items = 0;
     vector<ref<PgfItem>> items =
@@ -956,6 +957,7 @@ void PgfParser::bu_predict(PgfPhrasetable<PgfSymbolBIND> phrasetable,
         next_state->end   = state->end;
         next_state->next  = state->next;
         next_state->needs_bind = false;
+        next_state->viterbi_prob = state->viterbi_prob;
         state->next = next_state;
     }
 
@@ -963,13 +965,13 @@ void PgfParser::bu_predict(PgfPhrasetable<PgfSymbolBIND> phrasetable,
         //std::map<ref<PgfConcrLincat>, bool> visited;
         //if (!td_reachable(state, phrasetable->items[i], visited))
         //    continue;
-        Item *item = bu_item(state, items[i]);
+        Item *item = bu_item(state, outside_prob, items[i]);
         item->dot++;
         next_state->push_item(item);
     }
 }
 
-void PgfParser::bu_predict(State *state, CCat *ccat)
+void PgfParser::bu_predict(State *state, prob_t outside_prob, CCat *ccat)
 {
     size_t n_items = 0;
     vector<ref<PgfItem>> items = 0;
@@ -987,7 +989,7 @@ void PgfParser::bu_predict(State *state, CCat *ccat)
         //std::map<ref<PgfConcrLincat>, bool> visited;
         //if (!td_reachable(ccat->cont->state, items[i], visited))
         //    continue;
-        auto new_item = bu_item(ccat->cont->state, items[i]);
+        auto new_item = bu_item(ccat->cont->state, outside_prob, items[i]);
         combine(state,new_item,ccat);
     }
 }
@@ -1023,7 +1025,7 @@ bool PgfParser::td_reachable(State *state, ref<PgfItem> pitem,
     return false;
 }
 
-PgfAbstractParser::Item *PgfParser::bu_item(State *state, ref<PgfItem> pitem)
+PgfAbstractParser::Item *PgfParser::bu_item(State *state, prob_t outside_prob, ref<PgfItem> pitem)
 {
     Item *item = NULL;
 
@@ -1061,7 +1063,7 @@ PgfAbstractParser::Item *PgfParser::bu_item(State *state, ref<PgfItem> pitem)
         item->syms    = pitem->rule->syms.as_vector();
         item->rule    = pitem->rule;
         item->inside_prob = lin->absfun->prob;
-        item->outside_prob = 0;
+        item->outside_prob = outside_prob;
 
         for (size_t i = 0; i < pitem->args.size(); i++) {
             item->args[i] = 0;
@@ -1149,7 +1151,7 @@ void PgfParser::prepare(ref<PgfConcrLincat> start)
 #endif
 
     PgfTextSpot start_spot = {0, (uint8_t *) sentence->text};
-    State *state = new_state(start_spot);
+    State *state = new_state(start_spot, 0);
 
     for (size_t i = start->n_lindefs; i < start->rules.size(); i++) {
         ref<PgfConcrRule> rule = start->rules[i];
@@ -1183,7 +1185,8 @@ PgfExpr PgfParser::fetch(PgfDB *db, prob_t *prob)
         while (state != NULL) {
             if (state->queue.size() > 0) {
                 Item *item = state->queue.front();
-                prob_t prob = item->outside_prob + item->inside_prob;
+                prob_t delta = current_state->viterbi_prob - state->viterbi_prob;
+                prob_t prob = item->outside_prob + item->inside_prob + delta;
                 if (min_prob > prob) {
                     min_prob  = prob;
                     min_state = state;
@@ -1360,7 +1363,7 @@ PgfExpr PgfParser::process_expr(ExprState *estate, prob_t *prob)
     return 0;
 }
 
-PgfAbstractParser::State *PgfParser::new_state(const PgfTextSpot &start)
+PgfAbstractParser::State *PgfParser::new_state(const PgfTextSpot &start, prob_t viterbi_prob)
 {
     State **prev = &current_state;
     State *state = current_state;
@@ -1374,6 +1377,7 @@ PgfAbstractParser::State *PgfParser::new_state(const PgfTextSpot &start)
     state = new State;
     state->start = start;
     state->end   = start;
+    state->viterbi_prob = viterbi_prob;
     state->next  = *prev;
     *prev = state;
 
@@ -1397,7 +1401,7 @@ void PgfParser::symbol_token(Item *item, State *state, ref<PgfSymbolKS> symks)
     if (text_symbol_cmp(&next,end,symks,case_sensitive) != 0)
         return;
 
-    State *next_state = new_state(next);
+    State *next_state = new_state(next, item->inside_prob+item->outside_prob);
 
     item->dot++;
     process(item, next_state);
@@ -1413,6 +1417,7 @@ void PgfParser::symbol_bind(Item *item, State *state, PgfSymbol sym)
             next_state->end   = state->end;
             next_state->next  = state->next;
             next_state->needs_bind = false;
+            next_state->viterbi_prob = state->viterbi_prob;
             state->next = next_state;
         }
         item->dot++;
@@ -1472,10 +1477,11 @@ void PgfParser::suspend(Cont *cont,Item *item,bool do_predict,ref<PgfSymbolCat>
         }
 
         if (do_predict) {
+            prob_t viterbi_prob = item->inside_prob+item->outside_prob;
             if (cont->state->needs_bind) {
-                bu_predict(concr->phrasetable4, cont->state);
+                bu_predict(concr->phrasetable4, cont->state, viterbi_prob);
             } else {
-                bu_predict(concr->phrasetable1, cont->state, 1, sentence->size);
+                bu_predict(concr->phrasetable1, cont->state, viterbi_prob, 1, sentence->size);
             }
         }
     } else {
@@ -1606,6 +1612,7 @@ PgfParseTableMaker::PgfParseTableMaker(ref<PgfConcr> concr)
     current_state->start.pos = 0;
     current_state->start.ptr = NULL;
     current_state->end       = current_state->start;
+    current_state->viterbi_prob = 0;
     current_state->next      = NULL;
 }
 
@@ -1629,7 +1636,7 @@ ref<PgfItem> PgfParseTableMaker::clone_item(Item *item)
     return pitem;
 }
 
-PgfAbstractParser::State *PgfParseTableMaker::new_state(const PgfTextSpot &start)
+PgfAbstractParser::State *PgfParseTableMaker::new_state(const PgfTextSpot &start, prob_t viterbi_prob)
 {
     return current_state;
 }
@@ -1716,7 +1723,7 @@ void PgfParseTableMaker::final_item(State *state, CCat *ccat, Item *item, interv
     }
 }
 
-void PgfParseTableMaker::bu_predict(State *state, CCat *ccat)
+void PgfParseTableMaker::bu_predict(State *state, prob_t outside_prob, CCat *ccat)
 {
 }
 
diff --git a/src/runtime/c/pgf/parser.h b/src/runtime/c/pgf/parser.h
index f5016b8b0..14f8b8e8b 100644
--- a/src/runtime/c/pgf/parser.h
+++ b/src/runtime/c/pgf/parser.h
@@ -103,6 +103,7 @@ protected:
         std::map<CCat*,Cont*> conts2;
         std::map<Cont*,interval_map<interval_map<CCat*>>> completed;
         std::vector<Item*> queue;
+        prob_t viterbi_prob;
 
         State *next;
 
@@ -237,12 +238,12 @@ protected:
     void symbol(Item *item, State *state, PgfSymbol sym);
     void complete(Item *item, State *state);
 
-    virtual State *new_state(const PgfTextSpot &start)=0;
+    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, CCat *ccat)=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);
@@ -277,20 +278,20 @@ class PGF_INTERNAL_DECL PgfParser : private PgfAbstractParser, public PgfExprEnu
     uint8_t *end;
     bool case_sensitive;
 
-    virtual State *new_state(const PgfTextSpot &start);
+    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, CCat *ccat);
+    virtual void bu_predict(State *state, prob_t outside_prob, CCat *ccat);
 
-    void bu_predict(PgfPhrasetable<PgfSymbolBIND> phrasetable, State *state);
-    void bu_predict(PgfPhrasetable<PgfSymbolKS> phrasetable, State *state, ptrdiff_t min, ptrdiff_t max);
+    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, ref<PgfItem> pitem);
+    Item *bu_item(State *state, prob_t outside_prob, ref<PgfItem> pitem);
 
     static
     void print_expr_state_left(PgfPrinter *printer, PgfMarshaller *m, ExprState *estate);
@@ -319,12 +320,12 @@ public:
 class PGF_INTERNAL_DECL PgfParseTableMaker : private PgfAbstractParser
 {
 private:
-    virtual State *new_state(const PgfTextSpot &start);
+    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, CCat *ccat);
+    virtual void bu_predict(State *state, prob_t outside_prob, CCat *ccat);
 
     static
     ref<PgfItem> clone_item(Item *item);