added the linref construction in GF. The PGF version number is now bumped

19 files changed, 172 insertions, 87 deletions

diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index 6d8e9750e..736046179 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -106,8 +106,8 @@ checkCompleteGrammar opts gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc)
                                                     return info
                                  _            -> return info
                        case info of
-                         CncCat (Just (L loc (RecType []))) _ _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
-                         _                                        -> Bad "no def lin"
+                         CncCat (Just (L loc (RecType []))) _ _ _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
+                         _                                          -> Bad "no def lin"
 
                  case lookupIdent c js of
                    Ok (AnyInd _ _) -> return js
@@ -129,13 +129,13 @@ checkCompleteGrammar opts gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc)
                            checkWarn (text "no linearization of" <+> ppIdent c)
        AbsCat (Just _) -> case lookupIdent c js of
          Ok (AnyInd _ _) -> return js
-         Ok (CncCat (Just _) _ _ _) -> return js
-         Ok (CncCat Nothing mt mp mpmcfg) -> do
+         Ok (CncCat (Just _) _ _ _ _) -> return js
+         Ok (CncCat Nothing md mr mp mpmcfg) -> do
            checkWarn (text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}")
-           return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) mt mp mpmcfg) js
+           return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) md mr mp mpmcfg) js
          _ -> do
            checkWarn (text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}")
-           return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing) js
+           return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js
        _ -> return js
      
    checkCnc js i@(c,info) =
@@ -147,7 +147,7 @@ checkCompleteGrammar opts gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc)
                                            return $ updateTree (c,CncFun (Just linty) d mn mf) js
                              _       -> do checkWarn (text "function" <+> ppIdent c <+> text "is not in abstract")
                                            return js
-       CncCat _ _ _ _   -> case lookupOrigInfo gr (am,c) of
+       CncCat _ _ _ _ _ -> case lookupOrigInfo gr (am,c) of
                              Ok _ -> return $ updateTree i js
                              _    -> do checkWarn (text "category" <+> ppIdent c <+> text "is not in abstract")
                                         return js
@@ -175,7 +175,7 @@ checkInfo opts sgr (m,mo) c info = do
         Nothing  -> return ()
       return (AbsFun (Just (L loc typ)) ma md moper)
 
-    CncCat mty mdef mpr mpmcfg -> do
+    CncCat mty mdef mref mpr mpmcfg -> do
       mty  <- case mty of
                 Just (L loc typ) -> chIn loc "linearization type of" $ 
                                      (if False --flag optNewComp opts
@@ -192,13 +192,19 @@ checkInfo opts sgr (m,mo) c info = do
                        (def,_) <- checkLType gr [] 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)
+                       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
                        return (Just (L loc t))
                 _ -> return Nothing
-      return (CncCat mty mdef mpr mpmcfg)
+      return (CncCat mty mdef mref mpr mpmcfg)
 
     CncFun mty mt mpr mpmcfg -> do
       mt <- case (mty,mt) of
diff --git a/src/compiler/GF/Compile/Coding.hs b/src/compiler/GF/Compile/Coding.hs
index 5dc463d0e..9d7022229 100644
--- a/src/compiler/GF/Compile/Coding.hs
+++ b/src/compiler/GF/Compile/Coding.hs
@@ -22,7 +22,7 @@ codeSourceModule co (id,mo) = (id,mo{jments = mapTree codj (jments mo)})
     codj (c,info) = case info of
       ResOper     pty pt   -> ResOper (codeLTerms co pty) (codeLTerms co pt) 
       ResOverload es tyts  -> ResOverload es [(codeLTerm co ty,codeLTerm co t) | (ty,t) <- tyts]
-      CncCat mty mt mpr mpmcfg -> CncCat mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg
+      CncCat mcat mdef mref mpr mpmcfg -> CncCat mcat (codeLTerms co mdef) (codeLTerms co mref) (codeLTerms co mpr) mpmcfg
       CncFun mty mt mpr mpmcfg -> CncFun mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg
       _ -> info
 
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index 9642110bc..bf4bebdec 100644
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -100,27 +100,47 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
           newArgs  = map getFIds newArgs'
       in addFunction env0 newCat fun newArgs
 
-addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L loc term)) mprn Nothing) = do
-  let pres = protoFCat gr (am,id) lincat
-      parg = protoFCat gr (identW,cVar) typeStr
+addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) 
+                                                             mdef@(Just (L loc1 def))
+                                                             mref@(Just (L loc2 ref))
+                                                             mprn
+                                                             Nothing) = do
+  let pcat = protoFCat gr (am,id) lincat
+      pvar = protoFCat gr (identW,cVar) typeStr
 
       pmcfgEnv0  = emptyPMCFGEnv
-      lincont    = [(Explicit, varStr, typeStr)]
-  b             <- convert opts gr cenv (floc opath loc id) term (lincont,lincat) [parg]
+
+  let lincont    = [(Explicit, varStr, typeStr)]
+  b             <- convert opts gr cenv (floc opath loc1 id) def (lincont,lincat) [pvar]
   let (seqs1,b1) = addSequencesB seqs b
-      pmcfgEnv1  = foldBM addRule
+      pmcfgEnv1  = foldBM addLindef
                           pmcfgEnv0
                           (goB b1 CNil [])
-                          (pres,[parg])
-      pmcfg     = getPMCFG pmcfgEnv1
-  when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr ("\n+ "++showIdent id++" "++show (catFactor pres))
-  seqs1 `seq` pmcfg `seq` return (seqs1,GF.Grammar.CncCat mty mdef mprn (Just pmcfg))
+                          (pcat,[pvar])
+
+  let lincont    = [(Explicit, varStr, lincat)]
+  b             <- convert opts gr cenv (floc opath loc2 id) ref (lincont,typeStr) [pcat]
+  let (seqs2,b2) = addSequencesB seqs1 b
+      pmcfgEnv2  = foldBM addLinref
+                          pmcfgEnv1
+                          (goB b2 CNil [])
+                          (pvar,[pcat])
+
+  let pmcfg     = getPMCFG pmcfgEnv2
+
+  when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr ("\n+ "++showIdent id++" "++show (catFactor pcat))
+  seqs2 `seq` pmcfg `seq` return (seqs2,GF.Grammar.CncCat mty mdef mref mprn (Just pmcfg))
   where
-    addRule lins (newCat', newArgs') env0 =
+    addLindef lins (newCat', newArgs') env0 =
       let [newCat] = getFIds newCat'
           !fun     = mkArray lins
       in addFunction env0 newCat fun [[fidVar]]
 
+    addLinref lins (newCat', [newArg']) env0 =
+      let newArg   = getFIds newArg'
+          !fun     = mkArray lins
+      in addFunction env0 fidVar fun [newArg]
+
 addPMCFG opts gr cenv opath am cm seqs id info = return (seqs, info)
 
 floc opath loc id = maybe (L loc id) (\path->L (External path loc) id) opath
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index aa5c3d163..b8a4f36fa 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -6,7 +6,7 @@ import GF.Compile.GeneratePMCFG
 import GF.Compile.GenerateBC
 
 import PGF.CId
-import PGF.Data(fidInt,fidFloat,fidString)
+import PGF.Data(fidInt,fidFloat,fidString,fidVar)
 import PGF.Optimize(updateProductionIndices)
 import qualified PGF.Macros as CM
 import qualified PGF.Data as C
@@ -67,7 +67,7 @@ mkCanon2pgf opts gr am = do
 
       (ex_seqs,cdefs) <- addMissingPMCFGs
                             Map.empty 
-                            ([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
+                            ([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
                              Look.allOrigInfos gr cm)
 
       let flags = Map.fromList [(mkCId f,if f == "beam_size" then C.LFlt (read x) else C.LStr x) | (f,x) <- optionsPGF cflags]
@@ -78,7 +78,7 @@ mkCanon2pgf opts gr am = do
           ex_seqs_arr = mkMapArray ex_seqs :: Array SeqId Sequence
 
           !(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
-          !(!fid_cnt2,!productions,!lindefs,!cncfuns)
+          !(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns)
                                 = genCncFuns gr am cm ex_seqs_arr seqs cdefs fid_cnt1 cnccats
         
           printnames = genPrintNames cdefs
@@ -86,6 +86,7 @@ mkCanon2pgf opts gr am = do
                               printnames
                               cncfuns
                               lindefs
+                              linrefs
                               seqs
                               productions
                               IntMap.empty
@@ -178,7 +179,7 @@ genCncCats gr am cm cdefs =
   in (index, Map.fromList cats)
   where
     mkCncCats index []                                                = (index,[])
-    mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _):cdefs) 
+    mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _ _):cdefs) 
       | id == cInt    = 
             let cc            = pgfCncCat gr lincat fidInt
                 (index',cats) = mkCncCats index cdefs
@@ -208,22 +209,24 @@ genCncFuns :: SourceGrammar
            -> (FId,
                IntMap.IntMap (Set.Set D.Production),
                IntMap.IntMap [FunId],
+               IntMap.IntMap [FunId],
                Array FunId D.CncFun)
 genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
-  let (fid_cnt1,funs_cnt1,funs1,lindefs) = mkCncCats cdefs fid_cnt  0 [] IntMap.empty
-      (fid_cnt2,funs_cnt2,funs2,prods)   = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
-  in (fid_cnt2,prods,lindefs,array (0,funs_cnt2-1) funs2)
+  let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt  0 [] IntMap.empty IntMap.empty
+      (fid_cnt2,funs_cnt2,funs2,prods)           = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
+  in (fid_cnt2,prods,lindefs,linrefs,array (0,funs_cnt2-1) funs2)
   where
-    mkCncCats []                                                        fid_cnt funs_cnt funs lindefs =
-      (fid_cnt,funs_cnt,funs,lindefs)
-    mkCncCats (((m,id),CncCat _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs =
+    mkCncCats []                                                        fid_cnt funs_cnt funs lindefs linrefs =
+      (fid_cnt,funs_cnt,funs,lindefs,linrefs)
+    mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs linrefs =
       let !funs_cnt' = let (s_funid, e_funid) = bounds funs0
                        in funs_cnt+(e_funid-s_funid+1)
           lindefs'   = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0
+          linrefs'   = foldl' (toLinRef (am,id) funs_cnt) linrefs prods0
           funs'      = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0)
-      in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs'
-    mkCncCats (_                                                :cdefs) fid_cnt funs_cnt funs lindefs = 
-      mkCncCats cdefs fid_cnt funs_cnt funs lindefs
+      in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs'
+    mkCncCats (_                                                :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
+      mkCncCats cdefs fid_cnt funs_cnt funs lindefs linrefs
 
     mkCncFuns []                                                        fid_cnt funs_cnt funs lindefs crc prods =
       (fid_cnt,funs_cnt,funs,prods)
@@ -264,11 +267,20 @@ genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
 
     mkLinDefId id = prefixIdent "lindef " id
 
-    toLinDef res offs lindefs (Production fid0 funid0 _) =
-      IntMap.insertWith (++) fid [offs+funid0] lindefs
+    toLinDef res offs lindefs (Production fid0 funid0 args) =
+      if args == [[fidVar]]
+        then IntMap.insertWith (++) fid [offs+funid0] lindefs
+        else lindefs
       where
         fid = mkFId res fid0
 
+    toLinRef res offs linrefs (Production fid0 funid0 [fargs]) =
+      if fid0 == fidVar
+        then foldr (\fid -> IntMap.insertWith (++) fid [offs+funid0]) linrefs fids
+        else linrefs
+      where
+        fids = map (mkFId res) fargs
+
     mkFId (_,cat) fid0 =
       case Map.lookup (i2i cat) cnccats of
         Just (C.CncCat s e _) -> s+fid0
@@ -299,9 +311,9 @@ genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
 genPrintNames cdefs =
   Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
   where
-    prn (CncFun _ _ (Just (L _ tr)) _) = [flatten tr]
-    prn (CncCat _ _ (Just (L _ tr)) _) = [flatten tr]
-    prn _                              = []
+    prn (CncFun _ _   (Just (L _ tr)) _) = [flatten tr]
+    prn (CncCat _ _ _ (Just (L _ tr)) _) = [flatten tr]
+    prn _                                = []
 
     flatten (K s)      = s
     flatten (Alts x _) = flatten x
diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs
index 9ee50251b..37fe21cc0 100644
--- a/src/compiler/GF/Compile/Optimize.hs
+++ b/src/compiler/GF/Compile/Optimize.hs
@@ -60,7 +60,7 @@ evalInfo opts sgr m c info = do
 
  errIn ("optimizing " ++ showIdent c) $ case info of
 
-  CncCat ptyp pde ppr mpmcfg -> do
+  CncCat ptyp pde pre ppr mpmcfg -> do
     pde' <- case (ptyp,pde) of
       (Just (L _ typ), Just (L loc de)) -> do
         de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
@@ -71,9 +71,19 @@ evalInfo opts sgr m c info = do
         return (Just (L loc (factor param c 0 de)))
       _ -> return pde   -- indirection
 
+    pre' <- case (ptyp,pre) of
+      (Just (L _ typ), Just (L loc re)) -> do
+        re <- partEval opts gr ([(Explicit, varStr, typ)], typeStr) re
+        return (Just (L loc (factor param c 0 re)))
+      (Just (L loc typ), Nothing) -> do
+        re <- mkLinReference gr typ
+        re <- partEval opts gr ([(Explicit, varStr, typ)], typeStr) re
+        return (Just (L loc (factor param c 0 re)))
+      _ -> return pre   -- indirection
+
     ppr' <- evalPrintname gr ppr
 
-    return (CncCat ptyp pde' ppr' mpmcfg)
+    return (CncCat ptyp pde' pre' ppr' mpmcfg)
 
   CncFun (mt@(Just (_,cont,val))) pde ppr mpmcfg -> --trace (prt c) $
        eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do
@@ -166,6 +176,26 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
      _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
      _ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 typ))
 
+mkLinReference :: SourceGrammar -> Type -> Err Term
+mkLinReference gr typ = 
+ liftM (Abs Explicit varStr) $ 
+   case mkDefField typ (Vr varStr) of
+     Bad "no string" -> return Empty
+     x               -> x
+ where
+   mkDefField ty trm = 
+     case ty of
+       Table pty ty -> do ps <- allParamValues gr pty
+                          case ps of
+                            []     -> Bad "no string"
+                            (p:ps) -> mkDefField ty (S trm p)
+       Sort s | s == cStr -> return trm
+       QC p -> Bad "no string"
+       RecType rs  -> do
+         msum (map (\(l,ty) -> mkDefField ty (P trm l)) (sortRec rs))
+       _ | Just _ <- isTypeInts typ -> Bad "no string"
+       _ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 typ))
+
 evalPrintname :: SourceGrammar -> Maybe (L Term) -> Err (Maybe (L Term))
 evalPrintname gr mpr =
   case mpr of
diff --git a/src/compiler/GF/Compile/Refresh.hs b/src/compiler/GF/Compile/Refresh.hs
index 837534afa..999d8b083 100644
--- a/src/compiler/GF/Compile/Refresh.hs
+++ b/src/compiler/GF/Compile/Refresh.hs
@@ -124,9 +124,16 @@ refreshModule (k,sgr) mi@(i,mo)
       (k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $ 
                     appSTM (mapPairsM (\(L loc t) -> liftM (L loc) (refresh t)) tyts) (initIdStateN k)
       return $ (k', (c, ResOverload os tyts'):cs)
-    CncCat mt (Just (L loc trm)) mn mpmcfg-> do   ---- refresh mt, pn
-      (k',trm') <- refreshTermKN k trm
-      return $ (k', (c, CncCat mt (Just (L loc trm')) mn mpmcfg):cs)
+    CncCat mt md mr mn mpmcfg-> do
+      (k,md) <- case md of
+                  Just (L loc trm) -> do (k,trm) <- refreshTermKN k trm
+                                         return (k,Just (L loc trm))
+                  Nothing          -> return (k,Nothing)
+      (k,mr) <- case mr of
+                  Just (L loc trm) -> do (k,trm) <- refreshTermKN k trm
+                                         return (k,Just (L loc trm))
+                  Nothing          -> return (k,Nothing)
+      return (k, (c, CncCat mt md mr mn mpmcfg):cs)
     CncFun mt (Just (L loc trm)) mn mpmcfg -> do   ---- refresh pn
       (k',trm') <- refreshTermKN k trm
       return $ (k', (c, CncFun mt (Just (L loc trm')) mn mpmcfg):cs)
diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index e81582bc9..5c8b7bf20 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -153,7 +153,7 @@ renameInfo status (m,mi) i info =
     ResValue t -> do
       t <- renLoc (renameTerm status []) t
       return (ResValue t)
-    CncCat mty mtr mpr mpmcfg -> liftM4 CncCat (renTerm mty) (renTerm mtr) (renTerm mpr) (return mpmcfg)
+    CncCat mcat mdef mref mpr mpmcfg -> liftM5 CncCat (renTerm mcat) (renTerm mdef) (renTerm mref) (renTerm mpr) (return mpmcfg)
     CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty)         (renTerm mtr) (renTerm mpr) (return mpmcfg)
     _ -> return info
   where
diff --git a/src/compiler/GF/Compile/Tags.hs b/src/compiler/GF/Compile/Tags.hs
index bf4a6e04d..ccb47a219 100644
--- a/src/compiler/GF/Compile/Tags.hs
+++ b/src/compiler/GF/Compile/Tags.hs
@@ -36,8 +36,9 @@ getLocalTags x (m,mi) =
                                                   maybe (loc "oper-def")     mb_def
     getLocations (ResOverload _ defs)           = list (\(x,y) -> ltype "overload-type" x ++ 
                                                                   loc   "overload-def"  y) defs
-    getLocations (CncCat mty mdef mprn _)       = maybe (loc "lincat")       mty ++ 
-                                                  maybe (loc "lindef")       mdef  ++ 
+    getLocations (CncCat mty md mr mprn _)      = maybe (loc "lincat")       mty ++ 
+                                                  maybe (loc "lindef")       md  ++
+                                                  maybe (loc "linref")       mr  ++
                                                   maybe (loc "printname")    mprn
     getLocations (CncFun _ mlin mprn _)         = maybe (loc "lin")          mlin ++
                                                   maybe (loc "printname")    mprn
diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs
index 252563a72..54adcac2c 100644
--- a/src/compiler/GF/Compile/Update.hs
+++ b/src/compiler/GF/Compile/Update.hs
@@ -178,7 +178,7 @@ globalizeLoc fpath i =
     ResValue t            -> ResValue (gl t)
     ResOper mt m          -> ResOper (fmap gl mt) (fmap gl m)
     ResOverload ms os     -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
-    CncCat mc mf mp mpmcfg-> CncCat (fmap gl mc)  (fmap gl mf) (fmap gl mp) mpmcfg
+    CncCat mc md mr mp mpmcfg-> CncCat (fmap gl mc) (fmap gl md) (fmap gl mr) (fmap gl mp) mpmcfg
     CncFun m  mt md mpmcfg-> CncFun m (fmap gl mt) (fmap gl md) mpmcfg
     AnyInd b m            -> AnyInd b m
   where
@@ -205,8 +205,8 @@ unifyAnyInfo m i j = case (i,j) of
   (ResOper mt1 m1, ResOper mt2 m2) -> 
     liftM2 ResOper (unifMaybeL mt1 mt2) (unifMaybeL m1 m2)
 
-  (CncCat mc1 mf1 mp1 mpmcfg1, CncCat mc2 mf2 mp2 mpmcfg2) -> 
-    liftM4 CncCat (unifMaybeL mc1 mc2) (unifMaybeL mf1 mf2) (unifMaybeL mp1 mp2)  (unifMaybe mpmcfg1 mpmcfg2)
+  (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) -> 
+    liftM5 CncCat (unifMaybeL mc1 mc2) (unifMaybeL md1 md2) (unifMaybeL mr1 mr2) (unifMaybeL mp1 mp2)  (unifMaybe mpmcfg1 mpmcfg2)
   (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) -> 
     liftM3 (CncFun m) (unifMaybeL mt1 mt2) (unifMaybeL md1 md2) (unifMaybe mpmcfg1 mpmcfg2)
 
diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs
index 38d3d9bcc..0df678345 100644
--- a/src/compiler/GF/Grammar/Analyse.hs
+++ b/src/compiler/GF/Grammar/Analyse.hs
@@ -31,7 +31,7 @@ stripInfo i = case i of
   ResValue lt -> i ----
   ResOper mt md -> ResOper mt Nothing
   ResOverload is fs -> ResOverload is [(lty, L loc (EInt 0)) | (lty,L loc _) <- fs]
-  CncCat mty mte mtf mpmcfg -> CncCat mty Nothing Nothing Nothing
+  CncCat mty mte _ mtf mpmcfg -> CncCat mty Nothing Nothing Nothing Nothing
   CncFun mict mte mtf mpmcfg -> CncFun mict Nothing Nothing Nothing
   AnyInd b f -> i
 
@@ -110,7 +110,7 @@ sizeInfo i = case i of
   ResValue lt -> 0
   ResOper mt md -> 1 + msize mt + msize md
   ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]
-  CncCat mty mte mtf _ -> 1 + msize mty   -- ignoring lindef and printname
+  CncCat mty _ _ _ _ -> 1 + msize mty   -- ignoring lindef, linref and printname
   CncFun mict mte mtf _ -> 1 + msize mte  -- ignoring type and printname
   AnyInd b f -> -1  -- just to ignore these in the size
   _ -> 0
diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs
index b225a2526..34cb153d2 100644
--- a/src/compiler/GF/Grammar/Binary.hs
+++ b/src/compiler/GF/Grammar/Binary.hs
@@ -116,7 +116,7 @@ instance Binary Info where
   put (ResValue x)     = putWord8 3 >> put x

   put (ResOper x y)    = putWord8 4 >> put (x,y)

   put (ResOverload x y)= putWord8 5 >> put (x,y)

-  put (CncCat w x y z) = putWord8 6 >> put (w,x,y,z)

+  put (CncCat v w x y z)=putWord8 6 >> put (v,w,x,y,z)

   put (CncFun w x y z) = putWord8 7 >> put (w,x,y,z)

   put (AnyInd x y)     = putWord8 8 >> put (x,y)

   get = do tag <- getWord8

@@ -127,7 +127,7 @@ instance Binary Info where
              3 -> get >>= \x         -> return (ResValue x)

              4 -> get >>= \(x,y)     -> return (ResOper x y)

              5 -> get >>= \(x,y)     -> return (ResOverload x y)

-             6 -> get >>= \(w,x,y,z) -> return (CncCat w x y z)

+             6 -> get >>= \(v,w,x,y,z)->return (CncCat v w x y z)

              7 -> get >>= \(w,x,y,z) -> return (CncFun w x y z)

              8 -> get >>= \(x,y)     -> return (AnyInd x y)

              _ -> decodingError

diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs
index cb5c91bde..1daa9a1ea 100644
--- a/src/compiler/GF/Grammar/CF.hs
+++ b/src/compiler/GF/Grammar/CF.hs
@@ -102,7 +102,7 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where
             _ -> error "empty CF" 
   cats  = [(cat, AbsCat (Just (L NoLoc []))) | 
              cat <- nub' (concat (map cf2cat rules))] ----notPredef cat
-  lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
+  lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
   (funs,lins) = unzip (map cf2rule rules)
 
 cf2cat :: CFRule -> [Ident]
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index 8b2e174ee..61c07399c 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -325,8 +325,8 @@ data Info =
  | ResOverload [Ident] [(L Type,L Term)]         -- ^ (/RES/) idents: modules inherited
 
 -- judgements in concrete syntax
- | CncCat  (Maybe (L Type))             (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) lindef ini'zed, 
- | CncFun  (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) type info added at 'TC'
+ | CncCat  (Maybe (L Type))             (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) lindef ini'zed, 
+ | CncFun  (Maybe (Ident,Context,Type)) (Maybe (L Term))                  (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) type info added at 'TC'
 
 -- indirection to module Ident
  | AnyInd Bool Ident                         -- ^ (/INDIR/) the 'Bool' says if canonical
diff --git a/src/compiler/GF/Grammar/Lexer.hs b/src/compiler/GF/Grammar/Lexer.hs
index a9fef2cc4..8e6b05250 100644
--- a/src/compiler/GF/Grammar/Lexer.hs
+++ b/src/compiler/GF/Grammar/Lexer.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP,MagicHash #-}
+{-# LANGUAGE CPP,MagicHash,BangPatterns #-}
 {-# LINE 3 "lexer/Lexer.x" #-}
 
 module GF.Grammar.Lexer
@@ -103,6 +103,7 @@ data Token
  | T_lin
  | T_lincat
  | T_lindef
+ | T_linref
  | T_of
  | T_open
  | T_oper
@@ -187,6 +188,7 @@ resWords = Map.fromList
  , b "lin"        T_lin
  , b "lincat"     T_lincat
  , b "lindef"     T_lindef
+ , b "linref"     T_linref
  , b "of"         T_of
  , b "open"       T_open
  , b "oper"       T_oper
@@ -314,10 +316,10 @@ alexIndexInt16OffAddr (AlexA# arr) off =
 #ifdef WORDS_BIGENDIAN
   narrow16Int# i
   where
-        i    = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
-        high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
-        low  = int2Word# (ord# (indexCharOffAddr# arr off'))
-        off' = off *# 2#
+        !i    = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
+        !high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
+        !low  = int2Word# (ord# (indexCharOffAddr# arr off'))
+        !off' = off *# 2#
 #else
   indexInt16OffAddr# arr off
 #endif
@@ -331,14 +333,14 @@ alexIndexInt32OffAddr (AlexA# arr) off =
 #ifdef WORDS_BIGENDIAN
   narrow32Int# i
   where
-   i    = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`
+   !i    = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`
 		     (b2 `uncheckedShiftL#` 16#) `or#`
 		     (b1 `uncheckedShiftL#` 8#) `or#` b0)
-   b3   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))
-   b2   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))
-   b1   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
-   b0   = int2Word# (ord# (indexCharOffAddr# arr off'))
-   off' = off *# 4#
+   !b3   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))
+   !b2   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))
+   !b1   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
+   !b0   = int2Word# (ord# (indexCharOffAddr# arr off'))
+   !off' = off *# 4#
 #else
   indexInt32OffAddr# arr off
 #endif
@@ -414,12 +416,12 @@ alex_scan_tkn user orig_input len input s last_acc =
 
 
 	let
-		(base) = alexIndexInt32OffAddr alex_base s
-		((I# (ord_c))) = ord c
-		(offset) = (base +# ord_c)
-		(check)  = alexIndexInt16OffAddr alex_check offset
+		(!(base)) = alexIndexInt32OffAddr alex_base s
+		(!((I# (ord_c)))) = ord c
+		(!(offset)) = (base +# ord_c)
+		(!(check))  = alexIndexInt16OffAddr alex_check offset
 		
-		(new_s) = if (offset >=# 0#) && (check ==# ord_c)
+		(!(new_s)) = if (offset >=# 0#) && (check ==# ord_c)
 			  then alexIndexInt16OffAddr alex_table offset
 			  else alexIndexInt16OffAddr alex_deflt s
 	in
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index b4f1de2b0..d85c7c48b 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -74,8 +74,8 @@ lookupResDefLoc gr (m,c)
       case info of
         ResOper _ (Just lt) -> return lt
         ResOper _ Nothing  -> return (noLoc (Q (m,c)))
-        CncCat (Just (L l ty)) _ _ _ -> fmap (L l) (lock c ty)
-        CncCat _ _ _ _         -> fmap noLoc (lock c defLinType)
+        CncCat (Just (L l ty)) _ _ _ _ -> fmap (L l) (lock c ty)
+        CncCat _ _ _ _ _         -> fmap noLoc (lock c defLinType)
       
         CncFun (Just (cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr)
         CncFun _                (Just ltr) _ _ -> return ltr
@@ -92,7 +92,7 @@ lookupResType gr (m,c) = do
     ResOper (Just (L _ t)) _ -> return t
 
     -- used in reused concrete
-    CncCat _ _ _ _ -> return typeType
+    CncCat _ _ _ _ _ -> return typeType
     CncFun (Just (cat,cont,val)) _ _ _ -> do
           val' <- lock cat val 
           return $ mkProd cont val' []
@@ -166,9 +166,9 @@ lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
 lookupLincat gr m c = do
   info <- lookupQIdentInfo gr (m,c)
   case info of
-    CncCat (Just (L _ t)) _ _ _ -> return t
-    AnyInd _ n                  -> lookupLincat gr n c
-    _                           -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
+    CncCat (Just (L _ t)) _ _ _ _ -> return t
+    AnyInd _ n                    -> lookupLincat gr n c
+    _                             -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
 
 -- | this is needed at compile time
 lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index bd7de5db4..f6d5c7572 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -593,7 +593,7 @@ allDependencies ism b =
       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]
+      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]
diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y
index e5a7f359c..14d4328dc 100644
--- a/src/compiler/GF/Grammar/Parser.y
+++ b/src/compiler/GF/Grammar/Parser.y
@@ -85,6 +85,7 @@ import Data.Char(toLower)
  'lin'        { T_lin       }
  'lincat'     { T_lincat    }
  'lindef'     { T_lindef    }
+ 'linref'     { T_linref    }
  'of'         { T_of        }
  'open'       { T_open      }
  'oper'       { T_oper      }
@@ -221,10 +222,11 @@ TopDef
   | 'data'            ListDataDef     { Left  $2 }
   | 'param'           ListParamDef    { Left  $2 }
   | 'oper'            ListOperDef     { Left  $2 }
-  | 'lincat'          ListTermDef     { Left  [(f, CncCat (Just e) Nothing    Nothing Nothing) | (f,e) <- $2] }
-  | 'lindef'          ListTermDef     { Left  [(f, CncCat Nothing    (Just e) Nothing Nothing) | (f,e) <- $2] }
+  | 'lincat'          ListTermDef     { Left  [(f, CncCat (Just e) Nothing  Nothing  Nothing Nothing) | (f,e) <- $2] }
+  | 'lindef'          ListTermDef     { Left  [(f, CncCat Nothing  (Just e) Nothing  Nothing Nothing) | (f,e) <- $2] }
+  | 'linref'          ListTermDef     { Left  [(f, CncCat Nothing  Nothing  (Just e) Nothing Nothing) | (f,e) <- $2] }
   | 'lin'             ListLinDef      { Left  $2 }
-  | 'printname' 'cat' ListTermDef     { Left  [(f, CncCat Nothing    Nothing (Just e) Nothing) | (f,e) <- $3] }
+  | 'printname' 'cat' ListTermDef     { Left  [(f, CncCat Nothing Nothing Nothing (Just e) Nothing) | (f,e) <- $3] }
   | 'printname' 'fun' ListTermDef     { Left  [(f, CncFun Nothing Nothing (Just e) Nothing) | (f,e) <- $3] }
   | 'flags'           ListFlagDef     { Right $2 }
 
@@ -688,7 +690,7 @@ checkInfoType mt jment@(id,info) =
   case info of
     AbsCat pcont         -> ifAbstract mt (locPerh pcont)
     AbsFun pty _ pde _   -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
-    CncCat pty pd ppn _  -> ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh ppn)
+    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)
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index 0d9d41b7b..5d8751736 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -124,13 +124,16 @@ ppJudgement q (id, ResOverload ids defs) =
   (text "overload" <+> lbrace $$

    nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e <+> semi) | (L _ ty,L _ e) <- defs]) $$

    rbrace) <+> semi

-ppJudgement q (id, CncCat  ptype pexp pprn mpmcfg) =

-  (case ptype of

+ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =

+  (case pcat of

      Just (L _ typ) -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi

      Nothing        -> empty) $$

-  (case pexp of

+  (case pdef of

      Just (L _ exp) -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi

      Nothing        -> empty) $$

+  (case pref of

+     Just (L _ exp) -> text "linref" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi

+     Nothing        -> empty) $$

   (case pprn of

      Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi

      Nothing        -> empty) $$

diff --git a/src/compiler/GF/Grammar/lexer/Lexer.x b/src/compiler/GF/Grammar/lexer/Lexer.x
index 4050f4854..727e9e69c 100644
--- a/src/compiler/GF/Grammar/lexer/Lexer.x
+++ b/src/compiler/GF/Grammar/lexer/Lexer.x
@@ -97,6 +97,7 @@ data Token
  | T_lin
  | T_lincat
  | T_lindef
+ | T_linref
  | T_of
  | T_open
  | T_oper
@@ -181,6 +182,7 @@ resWords = Map.fromList
  , b "lin"        T_lin
  , b "lincat"     T_lincat
  , b "lindef"     T_lindef
+ , b "linref"     T_linref
  , b "of"         T_of
  , b "open"       T_open
  , b "oper"       T_oper