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

10 files changed, 46 insertions, 37 deletions

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