From 12912299be5c93c1829b54619ff4622972bff247 Mon Sep 17 00:00:00 2001 From: krangelov Date: Thu, 19 Sep 2019 22:53:07 +0200 Subject: [PATCH] added extra integer to store the offset of a parameter constructor --- src/compiler/GF/Compile/Rename.hs | 8 ++++---- src/compiler/GF/Compile/Tags.hs | 2 +- src/compiler/GF/Compile/TypeCheck/Primitives.hs | 6 +++--- src/compiler/GF/Compile/Update.hs | 10 +++++----- src/compiler/GF/Grammar/Analyse.hs | 4 ++-- src/compiler/GF/Grammar/Binary.hs | 6 +++--- src/compiler/GF/Grammar/Grammar.hs | 2 +- src/compiler/GF/Grammar/Lookup.hs | 8 ++++---- src/compiler/GF/Grammar/Parser.y | 4 ++-- src/compiler/GF/Grammar/Printer.hs | 2 +- src/compiler/SimpleEditor/Convert.hs | 2 +- 11 files changed, 27 insertions(+), 27 deletions(-) diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index 36f90ef46..2029a3c7b 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -118,7 +118,7 @@ renameIdentTerm' env@(act,imps) t0 = info2status :: Maybe ModuleName -> (Ident,Info) -> StatusInfo info2status mq (c,i) = case i of AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq - ResValue _ -> maybe Con (curry QC) mq + ResValue _ _ -> maybe Con (curry QC) mq ResParam _ _ -> maybe Con (curry QC) mq AnyInd True m -> maybe Con (const (curry QC m)) mq AnyInd False m -> maybe Cn (const (curry Q m)) mq @@ -156,9 +156,9 @@ renameInfo cwd status (m,mi) i info = ResParam (Just pp) m -> do pp' <- renLoc (mapM (renParam status)) pp return (ResParam (Just pp') m) - ResValue t -> do - t <- renLoc (renameTerm status []) t - return (ResValue t) + ResValue offset ty -> do + t <- renLoc (renameTerm status []) ty + return (ResValue offset ty) 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 diff --git a/src/compiler/GF/Compile/Tags.hs b/src/compiler/GF/Compile/Tags.hs index 6452e066f..2cf9d663b 100644 --- a/src/compiler/GF/Compile/Tags.hs +++ b/src/compiler/GF/Compile/Tags.hs @@ -31,7 +31,7 @@ getLocalTags x (m,mi) = getLocations (AbsFun mb_type _ mb_eqs _) = maybe (ltype "fun") mb_type ++ maybe (list (loc "def")) mb_eqs getLocations (ResParam mb_params _) = maybe (loc "param") mb_params - getLocations (ResValue mb_type) = ltype "param-value" mb_type + getLocations (ResValue _ mb_type) = ltype "param-value" mb_type getLocations (ResOper mb_type mb_def) = maybe (ltype "oper-type") mb_type ++ maybe (loc "oper-def") mb_def getLocations (ResOverload _ defs) = list (\(x,y) -> ltype "overload-type" x ++ diff --git a/src/compiler/GF/Compile/TypeCheck/Primitives.hs b/src/compiler/GF/Compile/TypeCheck/Primitives.hs index d82cd1568..e45956cec 100644 --- a/src/compiler/GF/Compile/TypeCheck/Primitives.hs +++ b/src/compiler/GF/Compile/TypeCheck/Primitives.hs @@ -8,7 +8,7 @@ typPredefined :: Ident -> Maybe Type typPredefined f = case Map.lookup f primitives of Just (ResOper (Just (L _ ty)) _) -> Just ty Just (ResParam _ _) -> Just typePType - Just (ResValue (L _ ty)) -> Just ty + Just (ResValue _ (L _ ty)) -> Just ty _ -> Nothing primitives = Map.fromList @@ -17,8 +17,8 @@ primitives = Map.fromList , (cFloat , ResOper (Just (noLoc typePType)) Nothing) , (cInts , fun [typeInt] typePType) , (cPBool , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)])) - , (cPTrue , ResValue (noLoc typePBool)) - , (cPFalse , ResValue (noLoc typePBool)) + , (cPTrue , ResValue 0 (noLoc typePBool)) + , (cPFalse , ResValue 1 (noLoc typePBool)) , (cError , fun [typeStr] typeError) -- non-can. of empty set , (cLength , fun [typeTok] typeInt) , (cDrop , fun [typeInt,typeTok] typeTok) diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 9556b6554..6e40970dd 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -163,7 +163,7 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme indirInfo :: ModuleName -> Info -> Info indirInfo n info = AnyInd b n' where (b,n') = case info of - ResValue _ -> (True,n) + ResValue _ _ -> (True,n) ResParam _ _ -> (True,n) AbsFun _ _ Nothing _ -> (True,n) AnyInd b k -> (b,k) @@ -174,7 +174,7 @@ globalizeLoc fpath i = AbsCat mc -> AbsCat (fmap gl mc) AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper ResParam mt mv -> ResParam (fmap gl mt) mv - ResValue t -> ResValue (gl t) + ResValue offset t -> ResValue offset (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 md mr mp mpmcfg-> CncCat (fmap gl mc) (fmap gl md) (fmap gl mr) (fmap gl mp) mpmcfg @@ -196,9 +196,9 @@ unifyAnyInfo m i j = case (i,j) of (ResParam mt1 mv1, ResParam mt2 mv2) -> liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2) - (ResValue (L l1 t1), ResValue (L l2 t2)) - | t1==t2 -> return (ResValue (L l1 t1)) - | otherwise -> fail "" + (ResValue offset1 (L l1 t1), ResValue offset2 (L l2 t2)) + | offset1 == offset2 && t1==t2 -> return (ResValue offset1 (L l1 t1)) + | otherwise -> fail "" (_, ResOverload ms t) | elem m ms -> return $ ResOverload ms t (ResOper mt1 m1, ResOper mt2 m2) -> diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs index 4c8f2020f..7a86b77a2 100644 --- a/src/compiler/GF/Grammar/Analyse.hs +++ b/src/compiler/GF/Grammar/Analyse.hs @@ -29,7 +29,7 @@ stripInfo i = case i of AbsCat _ -> i AbsFun mt mi me mb -> AbsFun mt mi Nothing mb ResParam mp mt -> ResParam mp Nothing - ResValue lt -> i ---- + 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 Nothing @@ -108,7 +108,7 @@ sizeInfo i = case i of sum [sum (map (sizeTerm . patt2term) 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 lt -> 0 + 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 _ _ _ _ -> 1 + msize mty -- ignoring lindef, linref and printname diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs index 12eef3fbb..545f895e4 100644 --- a/src/compiler/GF/Grammar/Binary.hs +++ b/src/compiler/GF/Grammar/Binary.hs @@ -25,7 +25,7 @@ import GF.Grammar.Grammar import PGF2.Internal(Literal(..),Symbol(..)) -- Please change this every time when the GFO format is changed -gfoVersion = "GF04" +gfoVersion = "GF05" instance Binary Ident where put id = put (ident2utf8 id) @@ -119,7 +119,7 @@ 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 (ResParam x y) = putWord8 2 >> put (x,y) - put (ResValue x) = putWord8 3 >> put x + put (ResValue x y) = putWord8 3 >> put (x,y) put (ResOper x y) = putWord8 4 >> put (x,y) put (ResOverload x y)= putWord8 5 >> put (x,y) put (CncCat v w x y z)=putWord8 6 >> put (v,w,x,y,z) @@ -130,7 +130,7 @@ instance Binary Info where 0 -> get >>= \x -> return (AbsCat x) 1 -> get >>= \(w,x,y,z) -> return (AbsFun w x y z) 2 -> get >>= \(x,y) -> return (ResParam x y) - 3 -> get >>= \x -> return (ResValue x) + 3 -> get >>= \(x,y) -> return (ResValue x y) 4 -> get >>= \(x,y) -> return (ResOper x y) 5 -> get >>= \(x,y) -> return (ResOverload x y) 6 -> get >>= \(v,w,x,y,z)->return (CncCat v w x y z) diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index d79f31775..9291401ae 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -330,7 +330,7 @@ data Info = -- judgements in resource | ResParam (Maybe (L [Param])) (Maybe [Term]) -- ^ (/RES/) the second parameter is list of all possible values - | ResValue (L Type) -- ^ (/RES/) to mark parameter constructors for lookup + | ResValue Int (L Type) -- ^ (/RES/) to mark parameter constructors for lookup | ResOper (Maybe (L Type)) (Maybe (L Term)) -- ^ (/RES/) | ResOverload [ModuleName] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs index 9435d1ec4..687840e24 100644 --- a/src/compiler/GF/Grammar/Lookup.hs +++ b/src/compiler/GF/Grammar/Lookup.hs @@ -83,7 +83,7 @@ lookupResDefLoc gr (m,c) AnyInd _ n -> look n c ResParam _ _ -> return (noLoc (QC (m,c))) - ResValue _ -> return (noLoc (QC (m,c))) + ResValue _ _ -> return (noLoc (QC (m,c))) _ -> raise $ render (c <+> "is not defined in resource" <+> m) lookupResType :: ErrorMonad m => Grammar -> QIdent -> m Type @@ -99,7 +99,7 @@ lookupResType gr (m,c) = do return $ mkProd cont val' [] AnyInd _ n -> lookupResType gr (n,c) ResParam _ _ -> return typePType - ResValue (L _ t) -> return t + ResValue _ (L _ t)-> return t _ -> raise $ render (c <+> "has no type defined in resource" <+> m) lookupOverloadTypes :: ErrorMonad m => Grammar -> QIdent -> m [(Term,Type)] @@ -114,7 +114,7 @@ lookupOverloadTypes gr id@(m,c) = do val' <- lock cat val ret $ mkProd cont val' [] ResParam _ _ -> ret typePType - ResValue (L _ t) -> ret t + ResValue _ (L _ t) -> ret t ResOverload os tysts -> do tss <- mapM (\x -> lookupOverloadTypes gr (x,c)) os return $ [(tr,ty) | (L _ ty,L _ tr) <- tysts] ++ @@ -226,7 +226,7 @@ allOpers gr = typesIn info = case info of AbsFun (Just ltyp) _ _ _ -> [ltyp] ResOper (Just ltyp) _ -> [ltyp] - ResValue ltyp -> [ltyp] + ResValue _ ltyp -> [ltyp] ResOverload _ tytrs -> [ltyp | (ltyp,_) <- tytrs] CncFun (Just (i,ctx,typ)) _ _ _ -> [L NoLoc (mkProdSimple ctx (lock' i typ))] diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y index d347bf74c..64a659bb1 100644 --- a/src/compiler/GF/Grammar/Parser.y +++ b/src/compiler/GF/Grammar/Parser.y @@ -266,7 +266,7 @@ DataDef ParamDef :: { [(Ident,Info)] } ParamDef : Posn LhsIdent '=' ListParConstr Posn { ($2, ResParam (Just (mkL $1 $5 [param | L loc param <- $4])) Nothing) : - [(f, ResValue (L loc (mkProdSimple co (Cn $2)))) | L loc (f,co) <- $4] } + [(f, ResValue 0 (L loc (mkProdSimple co (Cn $2)))) | L loc (f,co) <- $4] } | Posn LhsIdent Posn { [($2, ResParam Nothing Nothing)] } OperDef :: { [(Ident,Info)] } @@ -773,7 +773,7 @@ checkInfoType mt jment@(id,info) = 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) + ResValue _ ty -> ifResource mt (locL ty) ResOper pty pt -> ifOper mt pty pt ResOverload _ xs -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs]) where diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index f7378494c..cafda3aff 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -106,7 +106,7 @@ ppJudgement q (id, ResParam pparams _) = (case pparams of Just (L _ ps) -> '=' <+> ppParams q ps _ -> empty) <+> ';' -ppJudgement q (id, ResValue pvalue) = +ppJudgement q (id, ResValue _ pvalue) = "-- param constructor" <+> id <+> ':' <+> (case pvalue of (L _ ty) -> ppTerm q 0 ty) <+> ';' diff --git a/src/compiler/SimpleEditor/Convert.hs b/src/compiler/SimpleEditor/Convert.hs index 491a7a5b3..80754f411 100644 --- a/src/compiler/SimpleEditor/Convert.hs +++ b/src/compiler/SimpleEditor/Convert.hs @@ -119,7 +119,7 @@ convCncJment (name,jment) = case jment of ResParam ops _ -> return $ Pa $ Param i (maybe "" (render . ppParams q . unLoc) ops) - ResValue _ -> return Ignored + ResValue _ _ -> return Ignored 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