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

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)
+                         CncCat (Just (L loc (RecType []))) _ _ _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
-                         _                                        -> Bad "no def lin"
+                         _                                          -> 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 (Just _) _ _ _ _) -> return js
-         Ok (CncCat Nothing mt mp mpmcfg) -> do
+         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

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
 

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
+addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) 
-  let pres = protoFCat gr (am,id) lincat
+                                                             mdef@(Just (L loc1 def))
-      parg = protoFCat gr (identW,cVar) typeStr
+                                                             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])
+                          (pcat,[pvar])
-      pmcfg     = getPMCFG pmcfgEnv1
+
-  when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr ("\n+ "++showIdent id++" "++show (catFactor pres))
+  let lincont    = [(Explicit, varStr, lincat)]
-  seqs1 `seq` pmcfg `seq` return (seqs1,GF.Grammar.CncCat mty mdef mprn (Just pmcfg))
+  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

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
+  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
+      (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)
+  in (fid_cnt2,prods,lindefs,linrefs,array (0,funs_cnt2-1) funs2)
   where
-    mkCncCats []                                                        fid_cnt funs_cnt funs lindefs =
+    mkCncCats []                                                        fid_cnt funs_cnt funs lindefs linrefs =
-      (fid_cnt,funs_cnt,funs,lindefs)
+      (fid_cnt,funs_cnt,funs,lindefs,linrefs)
-    mkCncCats (((m,id),CncCat _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs =
+    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'
+      in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs'
-    mkCncCats (_                                                :cdefs) fid_cnt funs_cnt funs lindefs = 
+    mkCncCats (_                                                :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
-      mkCncCats cdefs fid_cnt funs_cnt funs lindefs
+      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 _) =
+    toLinDef res offs lindefs (Production fid0 funid0 args) =
-      IntMap.insertWith (++) fid [offs+funid0] lindefs
+      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 (CncFun _ _   (Just (L _ tr)) _) = [flatten tr]
-    prn (CncCat _ _ (Just (L _ tr)) _) = [flatten tr]
+    prn (CncCat _ _ _ (Just (L _ tr)) _) = [flatten tr]
-    prn _                              = []
+    prn _                                = []
 
     flatten (K s)      = s
     flatten (Alts x _) = flatten x

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

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
+    CncCat mt md mr mn mpmcfg-> do
-      (k',trm') <- refreshTermKN k trm
+      (k,md) <- case md of
-      return $ (k', (c, CncCat mt (Just (L loc trm')) mn mpmcfg):cs)
+                  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)

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

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 ++ 
+    getLocations (CncCat mty md mr mprn _)      = maybe (loc "lincat")       mty ++ 
-                                                  maybe (loc "lindef")       mdef  ++ 
+                                                  maybe (loc "lindef")       md  ++
+                                                  maybe (loc "linref")       mr  ++
                                                   maybe (loc "printname")    mprn
     getLocations (CncFun _ mlin mprn _)         = maybe (loc "lin")          mlin ++
                                                   maybe (loc "printname")    mprn

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) -> 
+  (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) -> 
-    liftM4 CncCat (unifMaybeL mc1 mc2) (unifMaybeL mf1 mf2) (unifMaybeL mp1 mp2)  (unifMaybe mpmcfg1 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)
 

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

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

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]

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, 
+ | 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'
+ | 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

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)
+        !i    = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
-        high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
+        !high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
-        low  = int2Word# (ord# (indexCharOffAddr# arr off'))
+        !low  = int2Word# (ord# (indexCharOffAddr# arr off'))
-        off' = off *# 2#
+        !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#)))
+   !b3   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))
-   b2   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))
+   !b2   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))
-   b1   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
+   !b1   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
-   b0   = int2Word# (ord# (indexCharOffAddr# arr off'))
+   !b0   = int2Word# (ord# (indexCharOffAddr# arr off'))
-   off' = off *# 4#
+   !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
+		(!(base)) = alexIndexInt32OffAddr alex_base s
-		((I# (ord_c))) = ord c
+		(!((I# (ord_c)))) = ord c
-		(offset) = (base +# ord_c)
+		(!(offset)) = (base +# ord_c)
-		(check)  = alexIndexInt16OffAddr alex_check offset
+		(!(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

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 (Just (L l ty)) _ _ _ _ -> fmap (L l) (lock c ty)
-        CncCat _ _ _ _         -> fmap noLoc (lock c defLinType)
+        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
+    CncCat (Just (L _ t)) _ _ _ _ -> return t
-    AnyInd _ n                  -> lookupLincat gr n c
+    AnyInd _ n                    -> lookupLincat gr n c
-    _                           -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
+    _                             -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
 
 -- | this is needed at compile time
 lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type

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]

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] }
+  | 'lincat'          ListTermDef     { Left  [(f, CncCat (Just e) Nothing  Nothing  Nothing Nothing) | (f,e) <- $2] }
-  | 'lindef'          ListTermDef     { Left  [(f, CncCat Nothing    (Just e) 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)

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) =
+ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
-  (case ptype of
+  (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) $$

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

src/compiler/SimpleEditor/Convert.hs

@@ -121,7 +121,7 @@ convCncJment (name,jment) =
     ResParam ops _ ->
       return $ Pa $ Param i (maybe "" (render . ppParams q . unLoc) ops)
     ResValue _ -> return Ignored
-    CncCat (Just (L _ typ)) Nothing pprn _ -> -- ignores printname !!
+    CncCat (Just (L _ typ)) Nothing Nothing pprn _ -> -- ignores printname !!
       return $ LC $ Lincat i (render $ ppTerm q 0 typ)
     ResOper oltyp (Just lterm) -> return $ Op $ Oper lhs rhs
       where
@@ -153,7 +153,7 @@ jmentLocation jment =
     AbsCat ctxt      -> fmap loc ctxt
     AbsFun ty _ _ _  -> fmap loc ty
     ResParam ops _   -> fmap loc ops
-    CncCat ty _ _ _  -> fmap loc ty
+    CncCat ty _ _ _ _ ->fmap loc ty
     ResOper ty rhs   -> fmap loc rhs `mplus` fmap loc ty
     CncFun _ rhs _ _ -> fmap loc rhs
     _ -> Nothing

src/runtime/c/pgf/data.h

@@ -299,6 +299,7 @@ typedef struct {
 struct PgfCCat {
 	PgfCncCat* cnccat;
 	PgfCncFuns* lindefs;
+	PgfCncFuns* linrefs;
 	size_t n_synprods;
 	PgfProductionSeq* prods;
 	float viterbi_prob;

src/runtime/c/pgf/parser.c

@@ -611,6 +611,8 @@ pgf_parsing_create_completed(PgfParsing* ps, PgfParseState* state,
 {
 	PgfCCat* cat = gu_new_flex(ps->pool, PgfCCat, fin, 1);
 	cat->cnccat = conts->ccat->cnccat;
+	cat->lindefs = conts->ccat->lindefs;
+	cat->linrefs = conts->ccat->linrefs;
 	cat->viterbi_prob = viterbi_prob;
 	cat->fid = ps->max_fid++;
 	cat->conts = conts;

src/runtime/c/pgf/printer.c

@@ -164,9 +164,33 @@ pgf_print_lindefs(GuMapItor* fn, const void* key, void* value,
 	}
 }
 
+static void
+pgf_print_linrefs(GuMapItor* fn, const void* key, void* value,
+			GuExn* err)
+{
+	PgfPrintFn* clo = (PgfPrintFn*) fn;
+    int fid = *((int *) key);
+    PgfCCat* ccat = *((PgfCCat**) value);
+    GuOut *out = clo->out;
+    
+    if (ccat->linrefs != NULL) {
+		gu_puts("    ",out,err);
+
+		size_t n_linrefs = gu_seq_length(ccat->linrefs);
+		for (size_t i = 0; i < n_linrefs; i++) {
+			if (i > 0) gu_putc(' ', out, err);
+
+			PgfCncFun* fun = gu_seq_get(ccat->linrefs, PgfCncFun*, i);
+			gu_printf(out,err,"F%d",fun->funid);
+		}
+
+		gu_printf(out,err," -> C%d\n",fid);
+	}
+}
+
 static void
 pgf_print_cncfun(PgfCncFun *cncfun, PgfSequences* sequences, 
-					GuOut *out, GuExn *err)
+                 GuOut *out, GuExn *err)
 {
 	gu_printf(out,err,"    F%d := (", cncfun->funid);
 
@@ -321,6 +345,10 @@ pgf_print_concrete(PgfCId cncname, PgfConcr* concr,
 	PgfPrintFn clo3 = { { pgf_print_lindefs }, out };
 	gu_map_iter(concr->ccats, &clo3.fn, err);
 
+	gu_puts("  linrefs\n", out, err);
+	PgfPrintFn clo4 = { { pgf_print_linrefs }, out };
+	gu_map_iter(concr->ccats, &clo4.fn, err);
+
 	gu_puts("  lin\n", out, err);
 	size_t n_funs = gu_seq_length(concr->cncfuns);
 	for (size_t i = 0; i < n_funs; i++) {
@@ -338,8 +366,8 @@ pgf_print_concrete(PgfCId cncname, PgfConcr* concr,
 	}
 	
 	gu_puts("  categories\n", out, err);
-	PgfPrintFn clo4 = { { pgf_print_cnccat }, out };
+	PgfPrintFn clo5 = { { pgf_print_cnccat }, out };
-	gu_map_iter(concr->cnccats, &clo4.fn, err);
+	gu_map_iter(concr->cnccats, &clo5.fn, err);
 	
 	gu_puts("}\n", out, err);
 }

src/runtime/c/pgf/reader.c

@@ -830,6 +830,7 @@ pgf_read_fid(PgfReader* rdr, PgfConcr* concr)
         ccat = gu_new(PgfCCat, rdr->opool);
         ccat->cnccat = NULL;
         ccat->lindefs = NULL;
+        ccat->linrefs = NULL;
         ccat->n_synprods = 0;
         ccat->prods = NULL;
         ccat->viterbi_prob = 0;
@@ -858,7 +859,7 @@ pgf_read_funid(PgfReader* rdr, PgfConcr* concr)
 }
 
 static void
-pgf_read_lindefs(PgfReader* rdr, PgfConcr* concr)
+pgf_read_lindefs(PgfReader* rdr, PgfAbsFun* abs_lin_fun, PgfConcr* concr)
 {
 	size_t len = pgf_read_len(rdr);
 	gu_return_on_exn(rdr->err, );
@@ -872,11 +873,33 @@ pgf_read_lindefs(PgfReader* rdr, PgfConcr* concr)
 		ccat->lindefs = gu_new_seq(PgfCncFun*, n_funs, rdr->opool);
 		for (size_t j = 0; j < n_funs; j++) {
 			PgfCncFun* fun = pgf_read_funid(rdr, concr);
+			fun->absfun = abs_lin_fun;
 			gu_seq_set(ccat->lindefs, PgfCncFun*, j, fun);
 		}
 	}
 }
 
+static void
+pgf_read_linrefs(PgfReader* rdr, PgfAbsFun* abs_lin_fun, PgfConcr* concr)
+{
+	size_t len = pgf_read_len(rdr);
+	gu_return_on_exn(rdr->err, );
+
+	for (size_t i = 0; i < len; i++) {
+		PgfCCat* ccat = pgf_read_fid(rdr, concr);
+		
+		size_t n_funs = pgf_read_len(rdr);
+		gu_return_on_exn(rdr->err, );
+
+		ccat->linrefs = gu_new_seq(PgfCncFun*, n_funs, rdr->opool);
+		for (size_t j = 0; j < n_funs; j++) {
+			PgfCncFun* fun = pgf_read_funid(rdr, concr);
+			fun->absfun = abs_lin_fun;
+			gu_seq_set(ccat->linrefs, PgfCncFun*, j, fun);
+		}
+	}
+}
+
 static void
 pgf_read_parg(PgfReader* rdr, PgfConcr* concr, PgfPArg* parg)
 {
@@ -1000,6 +1023,7 @@ pgf_read_cnccat(PgfReader* rdr, PgfAbstr* abstr, PgfConcr* concr, PgfCId name)
             ccat = gu_new(PgfCCat, rdr->opool);
             ccat->cnccat = NULL;
             ccat->lindefs = NULL;
+            ccat->linrefs = NULL;
             ccat->n_synprods = 0;
             ccat->prods = NULL;
             ccat->viterbi_prob = 0;
@@ -1123,7 +1147,7 @@ pgf_read_ccat_cb(GuMapItor* fn, const void* key, void* value, GuExn* err)
 }
 
 static PgfConcr*
-pgf_read_concrete(PgfReader* rdr, PgfAbstr* abstr)
+pgf_read_concrete(PgfReader* rdr, PgfAbstr* abstr, PgfAbsFun* abs_lin_fun)
 {
 	PgfConcr* concr = gu_new(PgfConcr, rdr->opool);
 
@@ -1153,7 +1177,8 @@ pgf_read_concrete(PgfReader* rdr, PgfAbstr* abstr)
 		gu_new_int_map(PgfCCat*, &gu_null_struct, rdr->opool);
 	concr->fun_indices = gu_map_type_new(PgfCncFunOverloadMap, rdr->opool);
 	concr->coerce_idx  = gu_map_type_new(PgfCncOverloadMap, rdr->opool);
-	pgf_read_lindefs(rdr, concr);
+	pgf_read_lindefs(rdr, abs_lin_fun, concr);
+	pgf_read_linrefs(rdr, abs_lin_fun, concr);
 	pgf_read_ccats(rdr, concr);
 	concr->cnccats = pgf_read_cnccats(rdr, abstr, concr);
 	concr->callbacks = pgf_new_callbacks_map(concr, rdr->opool); 
@@ -1177,10 +1202,21 @@ pgf_read_concretes(PgfReader* rdr, PgfAbstr* abstr)
 	size_t len = pgf_read_len(rdr);
 	gu_return_on_exn(rdr->err, NULL);
 
+	PgfAbsFun* abs_lin_fun = gu_new(PgfAbsFun, rdr->opool);
+	abs_lin_fun->name = "_";
+	abs_lin_fun->type = gu_new(PgfType, rdr->opool);
+	abs_lin_fun->type->hypos = NULL;
+	abs_lin_fun->type->cid = "_";
+	abs_lin_fun->type->n_exprs = 0;
+	abs_lin_fun->arity = 0;
+	abs_lin_fun->defns = NULL;
+	abs_lin_fun->ep.prob = INFINITY;
+	abs_lin_fun->ep.expr = gu_null_variant;
+
 	for (size_t i = 0; i < len; i++) {
-		PgfConcr* concr = pgf_read_concrete(rdr, abstr);
+		PgfConcr* concr = pgf_read_concrete(rdr, abstr, abs_lin_fun);
 		gu_return_on_exn(rdr->err, NULL);
-		
+
 		gu_map_put(concretes, concr->name, PgfConcr*, concr);
 	}
 

src/runtime/haskell/PGF.hs

@@ -32,7 +32,7 @@ module PGF(
            showType, readType,
            mkType, mkHypo, mkDepHypo, mkImplHypo,
            unType,
-           categories, startCat,
+           categories, categoryContext, startCat,
 
            -- * Functions
            functions, functionsByCat, functionType, missingLins,
@@ -221,6 +221,8 @@ abstractName :: PGF -> Language
 -- with the \'cat\' keyword.
 categories :: PGF -> [CId]
 
+categoryContext :: PGF -> CId -> Maybe [Hypo]
+
 -- | The start category is defined in the grammar with
 -- the \'startcat\' flag. This is usually the sentence category
 -- but it is not necessary. Despite that there is a start category
@@ -279,6 +281,11 @@ languageCode pgf lang =
 
 categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))]
 
+categoryContext pgf cat =
+  case Map.lookup cat (cats (abstract pgf)) of
+    Just (hypos,_,_) -> Just hypos
+    Nothing          -> Nothing
+
 startCat pgf = DTyp [] (lookStartCat pgf) []
 
 functions pgf = Map.keys (funs (abstract pgf))

src/runtime/haskell/PGF/Binary.hs

@@ -14,7 +14,7 @@ import qualified Data.Set as Set
 import Control.Monad
 
 pgfMajorVersion, pgfMinorVersion :: Word16
-(pgfMajorVersion, pgfMinorVersion) = (1,0)
+(pgfMajorVersion, pgfMinorVersion) = (2,0)
 
 instance Binary PGF where
   put pgf = do putWord16be pgfMajorVersion
@@ -56,6 +56,7 @@ instance Binary Concr where
                putArray2 (sequences cnc)
                putArray (cncfuns cnc)
                put (lindefs cnc)
+               put (linrefs cnc)
                put (productions cnc)
                put (cnccats cnc)
                put (totalCats cnc)
@@ -64,11 +65,13 @@ instance Binary Concr where
            sequences   <- getArray2
            cncfuns     <- getArray
            lindefs     <- get
+           linrefs     <- get
            productions <- get
            cnccats     <- get
            totalCats   <- get
            return (Concr{ cflags=cflags, printnames=printnames
-                        , sequences=sequences, cncfuns=cncfuns, lindefs=lindefs
+                        , sequences=sequences, cncfuns=cncfuns
+                        , lindefs=lindefs, linrefs=linrefs
                         , productions=productions
                         , pproductions = IntMap.empty
                         , lproductions = Map.empty

src/runtime/haskell/PGF/Data.hs

@@ -41,6 +41,7 @@ data Concr = Concr {
   printnames   :: Map.Map CId String,                                -- printname of a cat or a fun
   cncfuns      :: Array FunId CncFun,
   lindefs      :: IntMap.IntMap [FunId],
+  linrefs      :: IntMap.IntMap [FunId],
   sequences    :: Array SeqId Sequence,
   productions  :: IntMap.IntMap (Set.Set Production),                -- the original productions loaded from the PGF file
   pproductions :: IntMap.IntMap (Set.Set Production),                -- productions needed for parsing

src/runtime/haskell/PGF/Printer.hs

@@ -47,7 +47,9 @@ ppCnc name cnc =
           text "productions" $$
           nest 2 (vcat [ppProduction (fcat,prod) | (fcat,set) <- IntMap.toList (productions cnc), prod <- Set.toList set]) $$
           text "lindefs" $$
-          nest 2 (vcat (map ppLinDef (IntMap.toList (lindefs cnc)))) $$
+          nest 2 (vcat (map ppFunList (IntMap.toList (lindefs cnc)))) $$
+          text "linrefs" $$
+          nest 2 (vcat (map ppFunList (IntMap.toList (linrefs cnc)))) $$
           text "lin" $$
           nest 2 (vcat (map ppCncFun (assocs (cncfuns cnc)))) $$
           text "sequences" $$
@@ -73,7 +75,7 @@ ppProduction (fid,PConst _ _ ss) =
 ppCncFun (funid,CncFun fun arr) =
   ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun)
 
-ppLinDef (fid,funids) = 
+ppFunList (fid,funids) = 
   ppFId fid <+> text "->" <+> hcat (punctuate comma (map ppFunId funids))
 
 ppSeq (seqid,seq) =