msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

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

Browse Source
This commit is contained in:
kr.angelov
2013-10-30 12:53:36 +00:00
parent 122c40bb3b
commit 042243f08a
28 changed files with 267 additions and 102 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
src/compiler/GF/Grammar/Analyse.hs
View File

@@ -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

4
src/compiler/GF/Grammar/Binary.hs
View File

@@ -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

2
src/compiler/GF/Grammar/CF.hs
View File

@@ -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]

4
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -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

34
src/compiler/GF/Grammar/Lexer.hs
View File

@@ -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

12
src/compiler/GF/Grammar/Lookup.hs
View File

@@ -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

2
src/compiler/GF/Grammar/Macros.hs
View File

@@ -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]

10
src/compiler/GF/Grammar/Parser.y
View File

@@ -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)

9
src/compiler/GF/Grammar/Printer.hs
View File

@@ -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) $$

2
src/compiler/GF/Grammar/lexer/Lexer.x
View File

@@ -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