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

Merge branch 'majestic' of github.com:GrammaticalFramework/gf-core into majestic

Browse Source
This commit is contained in:
Krasimir Angelov
2023-12-05 15:03:27 +01:00
parent 85f3aa3eca d0e3c30ea6
commit ad57f73298
10 changed files with 1213 additions and 845 deletions
Download Patch File Download Diff File Expand all files Collapse all files

51
src/compiler/GF/Command/SourceCommands.hs
View File

@@ -1,5 +1,6 @@
-- | Commands requiring source grammar in env
module GF.Command.SourceCommands(HasGrammar(..),sourceCommands) where
import Prelude hiding (putStrLn)
import qualified Prelude as P(putStrLn)
import Data.List(nub,isInfixOf,isPrefixOf)
@@ -21,6 +22,7 @@ import GF.Grammar.Lookup (allOpers,allOpersTo)
import GF.Compile.Rename(renameSourceTerm)
import GF.Compile.Compute.Concrete(normalForm)
import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
import GF.Compile.TypeCheck.Primitives(predefMod)
import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
import GF.Command.CommandInfo
@@ -37,8 +39,8 @@ sourceCommands = Map.fromList [
explanation = unlines [
"Compute TERM by concrete syntax definitions. Uses the topmost",
"module (the last one imported) to resolve constant names.",
"N.B.1 You need the flag -retain when importing the grammar, if you want",
"the definitions to be retained after compilation.",
"N.B.1 You need the flag -retain or -resource when importing the grammar,",
"if you want the definitions to be available after compilation.",
"N.B.2 The resulting term is not a tree in the sense of abstract syntax",
"and hence not a valid input to a Tree-expecting command.",
"This command must be a line of its own, and thus cannot be a part",
@@ -109,8 +111,9 @@ sourceCommands = Map.fromList [
synopsis = "show all operations in scope, possibly restricted to a value type",
explanation = unlines [
"Show the names and type signatures of all operations available in the current resource.",
"This command requires a source grammar to be in scope, imported with 'import -retain'.",
"The operations include the parameter constructors that are in scope.",
"If no grammar is loaded with 'import -retain' or 'import -resource',",
"then only the predefined operations are in scope.",
"The operations include also the parameter constructors that are in scope.",
"The optional TYPE filters according to the value type.",
"The grep STRINGs filter according to other substrings of the type signatures."{-,
"This command must be a line of its own, and thus cannot be a part",
@@ -198,24 +201,21 @@ sourceCommands = Map.fromList [
| otherwise = unwords $ map prTerm ops
return $ fromString printed
show_operations os ts sgr = fmap fst $ runCheck $
case greatestResource sgr of
Nothing -> checkError (pp "no source grammar in scope; did you import with -retain?")
Just mo -> do
let greps = map valueString (listFlags "grep" os)
let isRaw = isOpt "raw" os
ops <- case ts of
_:_ -> do
let Right t = runP pExp (UTF8.fromString (unwords ts))
ty <- checkComputeTerm os sgr t
return $ allOpersTo sgr ty
_ -> return $ allOpers sgr
let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
let printer = if isRaw
then showTerm sgr TermPrintDefault Qualified
else (render . TC.ppType)
let printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
return . fromString $ unlines [l | l <- printed, all (`isInfixOf` l) greps]
show_operations os ts sgr0 = fmap fst $ runCheck $ do
let (sgr,mo) = case greatestResource sgr0 of
Nothing -> (mGrammar [predefMod], fst predefMod)
Just mo -> (sgr0,mo)
greps = map valueString (listFlags "grep" os)
ops <- case ts of
_:_ -> do let Right t = runP pExp (UTF8.fromString (unwords ts))
ty <- checkComputeTerm os sgr t
return $ allOpersTo sgr ty
_ -> return $ allOpers sgr
let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
printer = showTerm sgr TermPrintDefault
(if isOpt "raw" os then Qualified else Unqualified)
printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
return . fromString $ unlines [l | l <- printed, all (`isInfixOf` l) greps]
show_source os ts sgr = do
let strip = if isOpt "strip" os then stripSourceGrammar else id
@@ -251,9 +251,10 @@ sourceCommands = Map.fromList [
P.putStrLn "wrote graph in file _gfdepgraph.dot"
return void
checkComputeTerm os sgr t =
do mo <- maybe (checkError (pp "no source grammar in scope")) return $
greatestResource sgr
checkComputeTerm os sgr0 t =
do let (sgr,mo) = case greatestResource sgr0 of
Nothing -> (mGrammar [predefMod], fst predefMod)
Just mo -> (sgr0,mo)
t <- renameSourceTerm sgr mo t
(t,_) <- inferLType sgr [] t
fmap evalStr (normalForm sgr t)

367
src/compiler/GF/Compile/Compute/Concrete.hs
View File

@@ -1,22 +1,26 @@
{-# LANGUAGE RankNTypes, CPP #-}
{-# LANGUAGE RankNTypes, BangPatterns, CPP #-}
-- | Functions for computing the values of terms in the concrete syntax, in
-- | preparation for PMCFG generation.
module GF.Compile.Compute.Concrete
( normalForm
, Value(..), Thunk, ThunkState(..), Env, showValue
, EvalM, runEvalM, evalError
, Value(..), Thunk, ThunkState(..), Env, Scope, showValue
, MetaThunks, Constraint
, EvalM(..), runEvalM, runEvalOneM, evalError, evalWarn
, eval, apply, force, value2term, patternMatch
, newThunk, newEvaluatedThunk
, newResiduation, newNarrowing, getVariables
, getRef
, getResDef, getInfo, getAllParamValues
, getRef, setRef
, getResDef, getInfo, getResType, getOverload
, getAllParamValues
) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import GF.Grammar hiding (Env, VGen, VApp, VRecType)
import GF.Grammar.Lookup(lookupResDef,lookupOrigInfo,allParamValues)
import GF.Grammar.Lookup(lookupResDef,lookupResType,
lookupOrigInfo,lookupOverloadTypes,
allParamValues)
import GF.Grammar.Predef
import GF.Grammar.Lockfield(lockLabel)
import GF.Grammar.Printer
@@ -44,20 +48,24 @@ normalForm gr t =
mkFV [t] = t
mkFV ts = FV ts
type Sigma s = Value s
type Constraint s = Value s
data ThunkState s
= Unevaluated (Env s) Term
| Evaluated (Value s)
| Residuation {-# UNPACK #-} !MetaId
| Evaluated {-# UNPACK #-} !Int (Value s)
| Hole {-# UNPACK #-} !MetaId
| Narrowing {-# UNPACK #-} !MetaId Type
| Residuation {-# UNPACK #-} !MetaId (Scope s) (Maybe (Constraint s))
type Thunk s = STRef s (ThunkState s)
type Env s = [(Ident,Thunk s)]
type Scope s = [(Ident,Value s)]
data Value s
= VApp QIdent [Thunk s]
| VMeta (Thunk s) (Env s) [Thunk s]
| VSusp (Thunk s) (Env s) (Value s -> EvalM s (Value s)) [Thunk s]
| VMeta (Thunk s) [Thunk s]
| VSusp (Thunk s) (Value s -> EvalM s (Value s)) [Thunk s]
| VGen {-# UNPACK #-} !Int [Thunk s]
| VClosure (Env s) Term
| VProd BindType Ident (Value s) (Value s)
@@ -80,27 +88,31 @@ data Value s
| VPattType (Value s)
| VAlts (Value s) [(Value s, Value s)]
| VStrs [Value s]
-- These last constructors are only generated internally
-- These two constructors are only used internally
-- in the PMCFG generator.
| VSymCat Int LIndex [(LIndex, (Thunk s, Type))]
| VSymVar Int Int
-- These two constructors are only used internally
-- in the type checker.
| VCRecType [(Label, Bool, Constraint s)]
| VCInts (Maybe Integer) (Maybe Integer)
showValue (VApp q tnks) = "(VApp "++unwords (show q : map (const "_") tnks) ++ ")"
showValue (VMeta _ _ _) = "VMeta"
showValue (VSusp _ _ _ _) = "VSusp"
showValue (VGen _ _) = "VGen"
showValue (VMeta _ _) = "VMeta"
showValue (VSusp _ _ _) = "VSusp"
showValue (VGen i _) = "(VGen "++show i++")"
showValue (VClosure _ _) = "VClosure"
showValue (VProd _ _ _ _) = "VProd"
showValue (VProd _ x v1 v2) = "VProd ("++show x++") ("++showValue v1++") ("++showValue v2++")"
showValue (VRecType _) = "VRecType"
showValue (VR lbls) = "(VR {"++unwords (map (\(lbl,_) -> show lbl) lbls)++"})"
showValue (VP v l _) = "(VP "++showValue v++" "++show l++")"
showValue (VExtR _ _) = "VExtR"
showValue (VTable _ _) = "VTable"
showValue (VTable v1 v2) = "VTable ("++showValue v1++") ("++showValue v2++")"
showValue (VT _ _ cs) = "(VT "++show cs++")"
showValue (VV _ _) = "VV"
showValue (VS v _ _) = "(VS "++showValue v++")"
showValue (VSort _) = "VSort"
showValue (VSort s) = "(VSort "++show s++")"
showValue (VInt _) = "VInt"
showValue (VFlt _) = "VFlt"
showValue (VStr s) = "(VStr "++show s++")"
@@ -113,11 +125,18 @@ showValue (VAlts _ _) = "VAlts"
showValue (VStrs _) = "VStrs"
showValue (VSymCat _ _ _) = "VSymCat"
eval env (Vr x) vs = case lookup x env of
Just tnk -> do v <- force tnk
apply v vs
Nothing -> evalError ("Variable" <+> pp x <+> "is not in scope")
eval env (Sort s) [] = return (VSort s)
eval env (Vr x) vs = do (tnk,depth) <- lookup x env
withVar depth $ do
v <- force tnk
apply v vs
where
lookup x [] = evalError ("Variable" <+> pp x <+> "is not in scope")
lookup x ((y,tnk):env)
| x == y = return (tnk,length env)
| otherwise = lookup x env
eval env (Sort s) []
| s == cTok = return (VSort cStr)
| otherwise = return (VSort s)
eval env (EInt n) [] = return (VInt n)
eval env (EFloat d) [] = return (VFlt d)
eval env (K t) [] = return (VStr t)
@@ -126,8 +145,8 @@ eval env (App t1 t2) vs = do tnk <- newThunk env t2
eval env t1 (tnk : vs)
eval env (Abs b x t) [] = return (VClosure env (Abs b x t))
eval env (Abs b x t) (v:vs) = eval ((x,v):env) t vs
eval env (Meta i) vs = do tnk <- newResiduation i
return (VMeta tnk env vs)
eval env (Meta i) vs = do tnk <- newHole i
return (VMeta tnk vs)
eval env (ImplArg t) [] = eval env t []
eval env (Prod b x t1 t2)[] = do v1 <- eval env t1 []
return (VProd b x v1 (VClosure env t2))
@@ -241,8 +260,8 @@ eval env (TSymCat d r rs) []= do rs <- forM rs $ \(i,(pv,ty)) ->
eval env (TSymVar d r) [] = do return (VSymVar d r)
eval env t vs = evalError ("Cannot reduce term" <+> pp t)
apply (VMeta m env vs0) vs = return (VMeta m env (vs0++vs))
apply (VSusp m env k vs0) vs = return (VSusp m env k (vs0++vs))
apply (VMeta m vs0) vs = return (VMeta m (vs0++vs))
apply (VSusp m k vs0) vs = return (VSusp m k (vs0++vs))
apply (VApp f vs0) vs = return (VApp f (vs0++vs))
apply (VGen i vs0) vs = return (VGen i (vs0++vs))
apply (VClosure env (Abs b x t)) (v:vs) = eval ((x,v):env) t vs
@@ -330,9 +349,9 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
match' env p ps eqs arg v args = do
case (p,v) of
(p, VMeta i envi vs) -> susp i envi (\v -> apply v vs >>= \v -> match' env p ps eqs arg v args)
(p, VGen i vs ) -> return v0
(p, VSusp i envi k vs) -> susp i envi (\v -> k v >>= \v -> apply v vs >>= \v -> match' env p ps eqs arg v args)
(p, VMeta i vs) -> susp i (\v -> apply v vs >>= \v -> match' env p ps eqs arg v args)
(p, VGen i vs) -> return v0
(p, VSusp i k vs) -> susp i (\v -> k v >>= \v -> apply v vs >>= \v -> match' env p ps eqs arg v args)
(PP q qs, VApp r tnks)
| q == r -> match env (qs++ps) eqs (tnks++args)
(PR pas, VR as) -> matchRec env (reverse pas) as ps eqs args
@@ -428,41 +447,41 @@ vtableSelect v0 ty tnks tnk2 vs = do
return (r*cnt'+r',cnt*cnt')
value2index (VInt n) ty
| Just max <- isTypeInts ty = return (fromIntegral n,fromIntegral max+1)
value2index (VMeta i envi vs) ty = do
v <- susp i envi (\v -> apply v vs)
value2index (VMeta i vs) ty = do
v <- susp i (\v -> apply v vs)
value2index v ty
value2index (VSusp i envi k vs) ty = do
v <- susp i envi (\v -> k v >>= \v -> apply v vs)
value2index (VSusp i k vs) ty = do
v <- susp i (\v -> k v >>= \v -> apply v vs)
value2index v ty
value2index v ty = do t <- value2term [] v
evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
"cannot be evaluated at compile time.")
susp i env ki = EvalM $ \gr k mt r -> do
susp i ki = EvalM $ \gr k mt d r msgs -> do
s <- readSTRef i
case s of
Narrowing id (QC q) -> case lookupOrigInfo gr q of
Ok (m,ResParam (Just (L _ ps)) _) -> bindParam gr k mt r s m ps
Bad msg -> return (Fail (pp msg))
Ok (m,ResParam (Just (L _ ps)) _) -> bindParam gr k mt d r msgs s m ps
Bad msg -> return (Fail (pp msg) msgs)
Narrowing id ty
| Just max <- isTypeInts ty
-> bindInt gr k mt r s 0 max
Evaluated v -> case ki v of
EvalM f -> f gr k mt r
_ -> k (VSusp i env ki []) mt r
-> bindInt gr k mt d r msgs s 0 max
Evaluated _ v -> case ki v of
EvalM f -> f gr k mt d r msgs
_ -> k (VSusp i ki []) mt d r msgs
where
bindParam gr k mt r s m [] = return (Success r)
bindParam gr k mt r s m ((p, ctxt):ps) = do
bindParam gr k mt d r msgs s m [] = return (Success r msgs)
bindParam gr k mt d r msgs s m ((p, ctxt):ps) = do
(mt',tnks) <- mkArgs mt ctxt
let v = VApp (m,p) tnks
writeSTRef i (Evaluated v)
writeSTRef i (Evaluated 0 v)
res <- case ki v of
EvalM f -> f gr k mt' r
EvalM f -> f gr k mt' d r msgs
writeSTRef i s
case res of
Fail msg -> return (Fail msg)
Success r -> bindParam gr k mt r s m ps
Fail msg msgs -> return (Fail msg msgs)
Success r msgs -> bindParam gr k mt d r msgs s m ps
mkArgs mt [] = return (mt,[])
mkArgs mt ((_,_,ty):ctxt) = do
@@ -473,56 +492,67 @@ susp i env ki = EvalM $ \gr k mt r -> do
(mt,tnks) <- mkArgs (Map.insert i tnk mt) ctxt
return (mt,tnk:tnks)
bindInt gr k mt r s iv max
bindInt gr k mt d r msgs s iv max
| iv <= max = do
let v = VInt iv
writeSTRef i (Evaluated v)
writeSTRef i (Evaluated 0 v)
res <- case ki v of
EvalM f -> f gr k mt r
EvalM f -> f gr k mt d r msgs
writeSTRef i s
case res of
Fail msg -> return (Fail msg)
Success r -> bindInt gr k mt r s (iv+1) max
| otherwise = return (Success r)
Fail msg msgs -> return (Fail msg msgs)
Success r msgs -> bindInt gr k mt d r msgs s (iv+1) max
| otherwise = return (Success r msgs)
value2term xs (VApp q tnks) =
foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (if fst q == cPredef then Q q else QC q) tnks
value2term xs (VMeta m env tnks) = do
res <- zonk m tnks
case res of
Right i -> foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (Meta i) tnks
Left v -> value2term xs v
value2term xs (VSusp j env k vs) = do
foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (if fst q == cPredef then Q q else QC q) tnks
value2term xs (VMeta m vs) = do
s <- getRef m
case s of
Evaluated _ v -> do v <- apply v vs
value2term xs v
Unevaluated env t -> do v <- eval env t vs
value2term xs v
Hole i -> foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (Meta i) vs
Residuation i _ ctr -> case ctr of
Just ctr -> value2term xs ctr
Nothing -> foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (Meta i) vs
Narrowing i _ -> foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (Meta i) vs
value2term xs (VSusp j k vs) = do
v <- k (VGen maxBound vs)
value2term xs v
value2term xs (VGen j tnks) =
foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (Vr (reverse xs !! j)) tnks
foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (Vr (reverse xs !! j)) tnks
value2term xs (VClosure env (Abs b x t)) = do
tnk <- newEvaluatedThunk (VGen (length xs) [])
v <- eval ((x,tnk):env) t []
let x' = mkFreshVar xs x
t <- value2term (x':xs) v
return (Abs b x' t)
value2term xs (VProd b x v1 (VClosure env t2))
value2term xs (VProd b x v1 v2)
| x == identW = do t1 <- value2term xs v1
v2 <- eval env t2 []
v2 <- case v2 of
VClosure env t2 -> eval env t2 []
v2 -> return v2
t2 <- value2term xs v2
return (Prod b x t1 t2)
| otherwise = do t1 <- value2term xs v1
tnk <- newEvaluatedThunk (VGen (length xs) [])
v2 <- eval ((x,tnk):env) t2 []
v2 <- case v2 of
VClosure env t2 -> eval ((x,tnk):env) t2 []
v2 -> return v2
t2 <- value2term (x:xs) v2
return (Prod b (mkFreshVar xs x) t1 t2)
value2term xs (VRecType lbls) = do
lbls <- mapM (\(lbl,v) -> fmap ((,) lbl) (value2term xs v)) lbls
return (RecType lbls)
value2term xs (VR as) = do
as <- mapM (\(lbl,tnk) -> fmap (\t -> (lbl,(Nothing,t))) (force tnk >>= value2term xs)) as
as <- mapM (\(lbl,tnk) -> fmap (\t -> (lbl,(Nothing,t))) (tnk2term xs tnk)) as
return (R as)
value2term xs (VP v lbl tnks) = do
t <- value2term xs v
foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (P t lbl) tnks
foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (P t lbl) tnks
value2term xs (VExtR v1 v2) = do
t1 <- value2term xs v1
t2 <- value2term xs v2
@@ -540,11 +570,11 @@ value2term xs (VT vty env cs)= do
return (p,t)
return (T (TTyped ty) cs)
value2term xs (VV vty tnks)= do ty <- value2term xs vty
ts <- mapM (\tnk -> force tnk >>= value2term xs) tnks
ts <- mapM (tnk2term xs) tnks
return (V ty ts)
value2term xs (VS v1 tnk2 tnks) = do t1 <- value2term xs v1
t2 <- force tnk2 >>= value2term xs
foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (S t1 t2) tnks
t2 <- tnk2term xs tnk2
foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (S t1 t2) tnks
value2term xs (VSort s) = return (Sort s)
value2term xs (VStr tok) = return (K tok)
value2term xs (VInt n) = return (EInt n)
@@ -571,6 +601,12 @@ value2term xs (VAlts vd vas) = do
value2term xs (VStrs vs) = do
ts <- mapM (value2term xs) vs
return (Strs ts)
value2term xs (VCInts (Just i) Nothing) = return (App (Q (cPredef,cInts)) (EInt i))
value2term xs (VCInts Nothing (Just j)) = return (App (Q (cPredef,cInts)) (EInt j))
value2term xs (VCRecType lctrs) = do
ltys <- mapM (\(l,o,ctr) -> value2term xs ctr >>= \ty -> return (l,ty)) lctrs
return (RecType ltys)
value2term xs v = error (showValue v)
pattVars st (PP _ ps) = foldM pattVars st ps
pattVars st (PV x) = case st of
@@ -675,7 +711,7 @@ value2int _ = RunTime
-- * Evaluation monad
type MetaThunks s = Map.Map MetaId (Thunk s)
type Cont s r = MetaThunks s -> r -> ST s (CheckResult r)
type Cont s r = MetaThunks s -> Int -> r -> [Message] -> ST s (CheckResult r [Message])
newtype EvalM s a = EvalM (forall r . Grammar -> (a -> Cont s r) -> Cont s r)
instance Functor (EvalM s) where
@@ -694,76 +730,114 @@ instance Monad (EvalM s) where
#endif
instance Fail.MonadFail (EvalM s) where
fail msg = EvalM (\gr k _ r -> return (Fail (pp msg)))
fail msg = EvalM (\gr k _ _ r msgs -> return (Fail (pp msg) msgs))
instance Alternative (EvalM s) where
empty = EvalM (\gr k _ r -> return (Success r))
(EvalM f) <|> (EvalM g) = EvalM $ \gr k mt r -> do
res <- f gr k mt r
empty = EvalM (\gr k _ _ r msgs -> return (Success r msgs))
(EvalM f) <|> (EvalM g) = EvalM $ \gr k mt b r msgs -> do
res <- f gr k mt b r msgs
case res of
Fail msg -> return (Fail msg)
Success r -> g gr k mt r
Fail msg msgs -> return (Fail msg msgs)
Success r msgs -> g gr k mt b r msgs
instance MonadPlus (EvalM s) where
runEvalM :: Grammar -> (forall s . EvalM s a) -> Check [a]
runEvalM gr f =
runEvalM gr f = Check $ \(es,ws) ->
case runST (case f of
EvalM f -> f gr (\x mt xs -> return (Success (x:xs))) Map.empty []) of
Fail msg -> checkError msg
Success xs -> return (reverse xs)
EvalM f -> f gr (\x mt _ xs ws -> return (Success (x:xs) ws)) Map.empty maxBound [] ws) of
Fail msg ws -> Fail msg (es,ws)
Success xs ws -> Success (reverse xs) (es,ws)
evalError :: Doc -> EvalM s a
evalError msg = EvalM (\gr k _ r -> return (Fail msg))
runEvalOneM :: Grammar -> (forall s . EvalM s a) -> Check a
runEvalOneM gr f = Check $ \(es,ws) ->
case runST (case f of
EvalM f -> f gr (\x mt _ xs ws -> return (Success (x:xs) ws)) Map.empty maxBound [] ws) of
Fail msg ws -> Fail msg (es,ws)
Success [] ws -> Fail (pp "The evaluation produced no results") (es,ws)
Success (x:_) ws -> Success x (es,ws)
evalError :: Message -> EvalM s a
evalError msg = EvalM (\gr k _ _ r msgs -> return (Fail msg msgs))
evalWarn :: Message -> EvalM s ()
evalWarn msg = EvalM (\gr k mt d r msgs -> k () mt d r (msg:msgs))
getResDef :: QIdent -> EvalM s Term
getResDef q = EvalM $ \gr k mt r -> do
getResDef q = EvalM $ \gr k mt d r msgs -> do
case lookupResDef gr q of
Ok t -> k t mt r
Bad msg -> return (Fail (pp msg))
Ok t -> k t mt d r msgs
Bad msg -> return (Fail (pp msg) msgs)
getInfo :: QIdent -> EvalM s (ModuleName,Info)
getInfo q = EvalM $ \gr k mt r -> do
getInfo q = EvalM $ \gr k mt d r msgs -> do
case lookupOrigInfo gr q of
Ok res -> k res mt r
Bad msg -> return (Fail (pp msg))
Ok res -> k res mt d r msgs
Bad msg -> return (Fail (pp msg) msgs)
getResType :: QIdent -> EvalM s Type
getResType q = EvalM $ \gr k mt d r msgs -> do
case lookupResType gr q of
Ok t -> k t mt d r msgs
Bad msg -> return (Fail (pp msg) msgs)
getOverload :: Term -> QIdent -> EvalM s (Term,Type)
getOverload t q = EvalM $ \gr k mt d r msgs -> do
case lookupOverloadTypes gr q of
Ok ttys -> let err = "Overload resolution failed" $$
"of term " <+> pp t $$
"with types" <+> vcat [ppTerm Terse 0 ty | (_,ty) <- ttys]
go [] = return (Fail err msgs)
go (tty:ttys) = do res <- k tty mt d r msgs
case res of
Fail _ _ -> return res -- go ttys
Success r msgs -> return (Success r msgs)
in go ttys
Bad msg -> return (Fail (pp msg) msgs)
getAllParamValues :: Type -> EvalM s [Term]
getAllParamValues ty = EvalM $ \gr k mt r ->
getAllParamValues ty = EvalM $ \gr k mt d r msgs ->
case allParamValues gr ty of
Ok ts -> k ts mt r
Bad msg -> return (Fail (pp msg))
Ok ts -> k ts mt d r msgs
Bad msg -> return (Fail (pp msg) msgs)
newThunk env t = EvalM $ \gr k mt r -> do
newThunk env t = EvalM $ \gr k mt d r msgs -> do
tnk <- newSTRef (Unevaluated env t)
k tnk mt r
k tnk mt d r msgs
newEvaluatedThunk v = EvalM $ \gr k mt r -> do
tnk <- newSTRef (Evaluated v)
k tnk mt r
newEvaluatedThunk v = EvalM $ \gr k mt d r msgs -> do
tnk <- newSTRef (Evaluated maxBound v)
k tnk mt d r msgs
newResiduation i = EvalM $ \gr k mt r ->
newHole i = EvalM $ \gr k mt d r msgs ->
if i == 0
then do tnk <- newSTRef (Residuation i)
k tnk mt r
then do tnk <- newSTRef (Hole i)
k tnk mt d r msgs
else case Map.lookup i mt of
Just tnk -> k tnk mt r
Nothing -> do tnk <- newSTRef (Residuation i)
k tnk (Map.insert i tnk mt) r
Just tnk -> k tnk mt d r msgs
Nothing -> do tnk <- newSTRef (Hole i)
k tnk (Map.insert i tnk mt) d r msgs
newNarrowing i ty = EvalM $ \gr k mt r ->
if i == 0
then do tnk <- newSTRef (Narrowing i ty)
k tnk mt r
else case Map.lookup i mt of
Just tnk -> k tnk mt r
Nothing -> do tnk <- newSTRef (Narrowing i ty)
k tnk (Map.insert i tnk mt) r
newResiduation scope = EvalM $ \gr k mt d r msgs -> do
let i = Map.size mt + 1
tnk <- newSTRef (Residuation i scope Nothing)
k (i,tnk) (Map.insert i tnk mt) d r msgs
newNarrowing ty = EvalM $ \gr k mt d r msgs -> do
let i = Map.size mt + 1
tnk <- newSTRef (Narrowing i ty)
k (i,tnk) (Map.insert i tnk mt) d r msgs
withVar d0 (EvalM f) = EvalM $ \gr k mt d1 r msgs ->
let !d = min d0 d1
in f gr k mt d r msgs
getVariables :: EvalM s [(LVar,LIndex)]
getVariables = EvalM $ \gr k mt r -> do
getVariables = EvalM $ \gr k mt d ws r -> do
ps <- metas2params gr (Map.elems mt)
k ps mt r
k ps mt d ws r
where
metas2params gr [] = return []
metas2params gr (tnk:tnks) = do
@@ -778,24 +852,63 @@ getVariables = EvalM $ \gr k mt r -> do
else return params
_ -> metas2params gr tnks
getRef tnk = EvalM $ \gr k mt r -> readSTRef tnk >>= \st -> k st mt r
getRef tnk = EvalM $ \gr k mt d r msgs -> readSTRef tnk >>= \st -> k st mt d r msgs
setRef tnk st = EvalM $ \gr k mt d r msgs -> do
old <- readSTRef tnk
writeSTRef tnk st
res <- k () mt d r msgs
writeSTRef tnk old
return res
force tnk = EvalM $ \gr k mt r -> do
force tnk = EvalM $ \gr k mt d r msgs -> do
s <- readSTRef tnk
case s of
Unevaluated env t -> case eval env t [] of
EvalM f -> f gr (\v mt r -> do writeSTRef tnk (Evaluated v)
r <- k v mt r
writeSTRef tnk s
return r) mt r
Evaluated v -> k v mt r
Residuation _ -> k (VMeta tnk [] []) mt r
Narrowing _ _ -> k (VMeta tnk [] []) mt r
EvalM f -> f gr (\v mt b r msgs -> do let d = length env
writeSTRef tnk (Evaluated d v)
r <- k v mt d r msgs
writeSTRef tnk s
return r) mt d r msgs
Evaluated d v -> k v mt d r msgs
Hole _ -> k (VMeta tnk []) mt d r msgs
Residuation _ _ _ -> k (VMeta tnk []) mt d r msgs
Narrowing _ _ -> k (VMeta tnk []) mt d r msgs
zonk tnk vs = EvalM $ \gr k mt r -> do
s <- readSTRef tnk
case s of
Evaluated v -> case apply v vs of
EvalM f -> f gr (k . Left) mt r
Residuation i -> k (Right i) mt r
Narrowing i _ -> k (Right i) mt r
tnk2term xs tnk = EvalM $ \gr k mt d r msgs ->
let join f g = do res <- f
case res of
Fail msg msgs -> return (Fail msg msgs)
Success r msgs -> g r msgs
flush [] k1 mt r msgs = k1 mt r msgs
flush [x] k1 mt r msgs = join (k x mt d r msgs) (k1 mt)
flush xs k1 mt r msgs = join (k (FV (reverse xs)) mt d r msgs) (k1 mt)
acc d0 x mt d (r,!c,xs) msgs
| d < d0 = flush xs (\mt r msgs -> join (k x mt d r msgs) (\r msgs -> return (Success (r,c+1,[]) msgs))) mt r msgs
| otherwise = return (Success (r,c+1,x:xs) msgs)
in do s <- readSTRef tnk
case s of
Unevaluated env t -> do let d0 = length env
res <- case eval env t [] of
EvalM f -> f gr (\v mt d msgs r -> do writeSTRef tnk (Evaluated d0 v)
r <- case value2term xs v of
EvalM f -> f gr (acc d0) mt d msgs r
writeSTRef tnk s
return r) mt maxBound (r,0,[]) msgs
case res of
Fail msg msgs -> return (Fail msg msgs)
Success (r,0,xs) msgs -> k (FV []) mt d r msgs
Success (r,c,xs) msgs -> flush xs (\mt msgs r -> return (Success msgs r)) mt r msgs
Evaluated d0 v -> do res <- case value2term xs v of
EvalM f -> f gr (acc d0) mt maxBound (r,0,[]) msgs
case res of
Fail msg msgs -> return (Fail msg msgs)
Success (r,0,xs) msgs -> k (FV []) mt d r msgs
Success (r,c,xs) msgs -> flush xs (\mt r msgs -> return (Success r msgs)) mt r msgs
Hole i -> k (Meta i) mt d r msgs
Residuation i _ _ -> k (Meta i) mt d r msgs
Narrowing i _ -> k (Meta i) mt d r msgs
scopeEnv scope = zipWithM (\x i -> newEvaluatedThunk (VGen i []) >>= \tnk -> return (x,tnk)) (reverse scope) [0..]

56
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -24,10 +24,12 @@ import GF.Data.Operations(Err(..))
import PGF2.Transactions
import Control.Monad
import Control.Monad.State
import Control.Monad.ST
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import Data.List(mapAccumL,sortOn,sortBy)
import Data.Maybe(fromMaybe,isNothing)
import Data.STRef
generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
generatePMCFG opts cwd gr cmo@(cm,cmi)
@@ -77,12 +79,12 @@ addPMCFG opts cwd gr cmi id info seqs = return (info,seqs)
pmcfgForm :: Grammar -> Term -> Context -> Type -> SequenceSet -> Check ([Production],SequenceSet)
pmcfgForm gr t ctxt ty seqs = do
res <- runEvalM gr $ do
((_,ms),args) <- mapAccumM (\(d,ms) (_,_,ty) -> do
let (ms',_,t) = type2metaTerm gr d ms 0 [] ty
(_,args) <- mapAccumM (\arg_no (_,_,ty) -> do
t <- EvalM (\gr k mt d r msgs -> do (mt,_,t) <- type2metaTerm gr arg_no mt 0 [] ty
k t mt d r msgs)
tnk <- newThunk [] t
return ((d+1,ms'),tnk))
(0,Map.empty) ctxt
sequence_ [newNarrowing i ty | (i,ty) <- Map.toList ms]
return (arg_no+1,tnk))
0 ctxt
v <- eval [] t args
(lins,params) <- flatten v ty ([],[])
lins <- fmap reverse $ mapM str2lin lins
@@ -116,34 +118,38 @@ pmcfgForm gr t ctxt ty seqs = do
Nothing -> let seqid = Map.size m
in (seqid,Map.insert lin seqid m)
type2metaTerm :: SourceGrammar -> Int -> Map.Map MetaId Type -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> (Map.Map MetaId Type,Int,Term)
type2metaTerm :: SourceGrammar -> Int -> MetaThunks s -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> ST s (MetaThunks s,Int,Term)
type2metaTerm gr d ms r rs (Sort s) | s == cStr =
(ms,r+1,TSymCat d r rs)
type2metaTerm gr d ms r rs (RecType lbls) =
let ((ms',r'),ass) = mapAccumL (\(ms,r) (lbl,ty) -> case lbl of
LVar j -> ((ms,r),(lbl,(Just ty,TSymVar d j)))
lbl -> let (ms',r',t) = type2metaTerm gr d ms r rs ty
in ((ms',r'),(lbl,(Just ty,t))))
return (ms,r+1,TSymCat d r rs)
type2metaTerm gr d ms r rs (RecType lbls) = do
((ms',r'),ass) <- mapAccumM (\(ms,r) (lbl,ty) -> case lbl of
LVar j -> return ((ms,r),(lbl,(Just ty,TSymVar d j)))
lbl -> do (ms',r',t) <- type2metaTerm gr d ms r rs ty
return ((ms',r'),(lbl,(Just ty,t))))
(ms,r) lbls
in (ms',r',R ass)
return (ms',r',R ass)
type2metaTerm gr d ms r rs (Table p q)
| count == 1 = let (ms',r',t) = type2metaTerm gr d ms r rs q
in (ms',r+(r'-r),T (TTyped p) [(PW,t)])
| otherwise = let pv = varX (length rs+1)
delta = r'-r
(ms',r',t) = type2metaTerm gr d ms r ((delta,(pv,p)):rs) q
in (ms',r+delta*count,T (TTyped p) [(PV pv,t)])
| count == 1 = do (ms',r',t) <- type2metaTerm gr d ms r rs q
return (ms',r+(r'-r),T (TTyped p) [(PW,t)])
| otherwise = do let pv = varX (length rs+1)
(ms',delta,t) <-
fixST $ \(~(_,delta,_)) ->
do (ms',r',t) <- type2metaTerm gr d ms r ((delta,(pv,p)):rs) q
return (ms',r'-r,t)
return (ms',r+delta*count,T (TTyped p) [(PV pv,t)])
where
count = case allParamValues gr p of
Ok ts -> length ts
Bad msg -> error msg
type2metaTerm gr d ms r rs ty@(QC q) =
type2metaTerm gr d ms r rs ty@(QC q) = do
let i = Map.size ms + 1
in (Map.insert i ty ms,r,Meta i)
tnk <- newSTRef (Narrowing i ty)
return (Map.insert i tnk ms,r,Meta i)
type2metaTerm gr d ms r rs ty
| Just n <- isTypeInts ty =
| Just n <- isTypeInts ty = do
let i = Map.size ms + 1
in (Map.insert i ty ms,r,Meta i)
tnk <- newSTRef (Narrowing i ty)
return (Map.insert i tnk ms,r,Meta i)
flatten (VR as) (RecType lbls) st = do
foldM collect st lbls
@@ -247,10 +253,10 @@ param2int (VApp q tnks) ty = do
return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
param2int (VInt n) ty
| Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1)
param2int (VMeta tnk _ _) ty = do
param2int (VMeta tnk _) ty = do
tnk_st <- getRef tnk
case tnk_st of
Evaluated v -> param2int v ty
Evaluated _ v -> param2int v ty
Narrowing j ty -> do ts <- getAllParamValues ty
return (0,[(1,j-1)],length ts)
param2int v ty = do t <- value2term [] v

1430
src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
View File

File diff suppressed because it is too large Load Diff

18
src/compiler/GF/Compile/TypeCheck/Primitives.hs
View File

@@ -1,5 +1,6 @@
module GF.Compile.TypeCheck.Primitives where
module GF.Compile.TypeCheck.Primitives(typPredefined,predefMod) where
import GF.Infra.Option
import GF.Grammar
import GF.Grammar.Predef
import qualified Data.Map as Map
@@ -11,6 +12,21 @@ typPredefined f = case Map.lookup f primitives of
Just (ResValue (L _ ty) _) -> Just ty
_ -> Nothing
predefMod = (cPredef, modInfo)
where
modInfo = ModInfo {
mtype = MTResource,
mstatus = MSComplete,
mflags = noOptions,
mextend = [],
mwith = Nothing,
mopens = [],
mexdeps = [],
msrc = "Predef.gfo",
mseqs = Nothing,
jments = primitives
}
primitives = Map.fromList
[ (cErrorType, ResOper (Just (noLoc typeType)) Nothing)
, (cInt , ResOper (Just (noLoc typePType)) Nothing)

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

@@ -31,7 +31,7 @@ import qualified Data.Map as Map
%name pModDef ModDef
%name pTopDef TopDef
%partial pModHeader ModHeader
%partial pTerm Exp1
%partial pTerm Exp
%name pExp Exp
%name pBNFCRules ListCFRule
%name pEBNFRules ListEBNFRule

60
src/compiler/GF/Infra/CheckM.hs
View File

@@ -13,7 +13,7 @@
-----------------------------------------------------------------------------
module GF.Infra.CheckM
(Check, CheckResult(..), Message, runCheck, runCheck',
(Check(..), CheckResult(..), Message, runCheck, runCheck',
checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
checkIn, checkInModule, checkMap, checkMapRecover,
accumulateError, commitCheck,
@@ -37,22 +37,19 @@ import qualified Control.Monad.Fail as Fail
type Message = Doc
type Error = Message
type Warning = Message
--data Severity = Warning | Error
--type NonFatal = ([Severity,Message]) -- preserves order
type NonFatal = ([Error],[Warning])
type Accumulate acc ans = acc -> (acc,ans)
data CheckResult a = Fail Error | Success a
data CheckResult a b = Fail Error b | Success a b
newtype Check a
= Check {unCheck :: {-Context ->-} Accumulate NonFatal (CheckResult a)}
= Check {unCheck :: NonFatal -> CheckResult a NonFatal}
instance Functor Check where fmap = liftM
instance Monad Check where
return x = Check $ \{-ctxt-} ws -> (ws,Success x)
f >>= g = Check $ \{-ctxt-} ws ->
case unCheck f {-ctxt-} ws of
(ws,Success x) -> unCheck (g x) {-ctxt-} ws
(ws,Fail msg) -> (ws,Fail msg)
return x = Check $ \msgs -> Success x msgs
f >>= g = Check $ \ws ->
case unCheck f ws of
Success x msgs -> unCheck (g x) msgs
Fail msg msgs -> Fail msg msgs
instance Fail.MonadFail Check where
fail = raise
@@ -65,26 +62,26 @@ instance ErrorMonad Check where
raise s = checkError (pp s)
handle f h = handle' f (h . render)
handle' f h = Check (\{-ctxt-} msgs -> case unCheck f {-ctxt-} msgs of
(ws,Success x) -> (ws,Success x)
(ws,Fail msg) -> unCheck (h msg) {-ctxt-} ws)
handle' f h = Check (\msgs -> case unCheck f {-ctxt-} msgs of
Success x msgs -> Success x msgs
Fail msg msgs -> unCheck (h msg) msgs)
-- | Report a fatal error
checkError :: Message -> Check a
checkError msg = Check (\{-ctxt-} ws -> (ws,Fail msg))
checkError msg = Check (\msgs -> Fail msg msgs)
checkCond :: Message -> Bool -> Check ()
checkCond s b = if b then return () else checkError s
-- | warnings should be reversed in the end
checkWarn :: Message -> Check ()
checkWarn msg = Check $ \{-ctxt-} (es,ws) -> ((es,("Warning:" <+> msg) : ws),Success ())
checkWarn msg = Check $ \(es,ws) -> Success () (es,("Warning:" <+> msg) : ws)
checkWarnings ms = mapM_ checkWarn ms
-- | Report a nonfatal (accumulated) error
checkAccumError :: Message -> Check ()
checkAccumError msg = Check $ \{-ctxt-} (es,ws) -> ((msg:es,ws),Success ())
checkAccumError msg = Check $ \(es,ws) -> Success () (msg:es,ws)
-- | Turn a fatal error into a nonfatal (accumulated) error
accumulateError :: (a -> Check a) -> a -> Check a
@@ -94,13 +91,13 @@ accumulateError chk a =
-- | Turn accumulated errors into a fatal error
commitCheck :: Check a -> Check a
commitCheck c =
Check $ \ {-ctxt-} msgs0@(es0,ws0) ->
case unCheck c {-ctxt-} ([],[]) of
(([],ws),Success v) -> ((es0,ws++ws0),Success v)
(msgs ,Success _) -> bad msgs0 msgs
((es,ws),Fail e) -> bad msgs0 ((e:es),ws)
Check $ \msgs0@(es0,ws0) ->
case unCheck c ([],[]) of
(Success v ([],ws)) -> Success v (es0,ws++ws0)
(Success _ msgs) -> bad msgs0 msgs
(Fail e (es,ws)) -> bad msgs0 ((e:es),ws)
where
bad (es0,ws0) (es,ws) = ((es0,ws++ws0),Fail (list es))
bad (es0,ws0) (es,ws) = (Fail (list es) (es0,ws++ws0))
list = vcat . reverse
-- | Run an error check, report errors and warnings
@@ -109,10 +106,10 @@ runCheck c = runCheck' noOptions c
-- | Run an error check, report errors and (optionally) warnings
runCheck' :: ErrorMonad m => Options -> Check a -> m (a,String)
runCheck' opts c =
case unCheck c {-[]-} ([],[]) of
(([],ws),Success v) -> return (v,render (wlist ws))
(msgs ,Success v) -> bad msgs
((es,ws),Fail e) -> bad ((e:es),ws)
case unCheck c ([],[]) of
Success v ([],ws) -> return (v,render (wlist ws))
Success v msgs -> bad msgs
Fail e (es,ws) -> bad ((e:es),ws)
where
bad (es,ws) = raise (render $ wlist ws $$ list es)
list = vcat . reverse
@@ -128,12 +125,13 @@ checkMapRecover f = fmap Map.fromList . mapM f' . Map.toList
where f' (k,v) = fmap ((,)k) (f k v)
checkIn :: Doc -> Check a -> Check a
checkIn msg c = Check $ \{-ctxt-} msgs0 ->
case unCheck c {-ctxt-} ([],[]) of
(msgs,Fail msg) -> (augment msgs0 msgs,Fail (augment1 msg))
(msgs,Success v) -> (augment msgs0 msgs,Success v)
checkIn msg c = Check $ \msgs0 ->
case unCheck c ([],[]) of
Fail msg msgs -> Fail (augment1 msg) (augment msgs0 msgs)
Success v msgs -> Success v (augment msgs0 msgs)
where
augment (es0,ws0) (es,ws) = (augment' es0 es,augment' ws0 ws)
augment' msgs0 [] = msgs0
augment' msgs0 msgs' = (msg $$ nest 3 (vcat (reverse msgs'))):msgs0

15
src/compiler/GF/Interactive.hs
View File

@@ -14,6 +14,7 @@ import GF.Command.Abstract
import GF.Command.Parse(readCommandLine,pCommand,readTransactionCommand)
import GF.Compile.Rename(renameSourceTerm)
import GF.Compile.TypeCheck.Concrete(inferLType)
import GF.Compile.TypeCheck.Primitives(predefMod)
import GF.Compile.GeneratePMCFG(pmcfgForm,type2fields)
import GF.Data.Operations (Err(..))
import GF.Data.Utilities(whenM,repeatM)
@@ -283,10 +284,11 @@ transactionCommand (CreateConcrete opts name) pgf mb_txnid = do
lift $ updatePGF pgf mb_txnid (createConcrete name (return ()))
return ()
transactionCommand (CreateLin opts f t is_alter) pgf mb_txnid = do
sgr <- getGrammar
sgr0 <- getGrammar
let (sgr,mo) = case greatestResource sgr0 of
Nothing -> (mGrammar [predefMod], fst predefMod)
Just mo -> (sgr0,mo)
lang <- optLang pgf opts
mo <- maybe (fail "no source grammar in scope") return $
greatestResource sgr
lift $ updatePGF pgf mb_txnid $ do
mb_ty <- getFunctionType f
case mb_ty of
@@ -319,10 +321,11 @@ transactionCommand (CreateLin opts f t is_alter) pgf mb_txnid = do
mapToSequence m = Seq.fromList (map (Left . fst) (sortOn snd (Map.toList m)))
transactionCommand (CreateLincat opts c t) pgf mb_txnid = do
sgr <- getGrammar
sgr0 <- getGrammar
let (sgr,mo) = case greatestResource sgr0 of
Nothing -> (mGrammar [predefMod], fst predefMod)
Just mo -> (sgr0,mo)
lang <- optLang pgf opts
mo <- maybe (fail "no source grammar in scope") return $
greatestResource sgr
case runCheck (compileLincatTerm sgr mo t) of
Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] Seq.empty >> return ()))
return ()

54
src/runtime/c/pgf/phrasetable.cxx
View File

@@ -474,16 +474,12 @@ PgfPhrasetable phrasetable_delete(PgfPhrasetable table,
PgfPhrasetable left = phrasetable_delete(table->left,
container, seq_index,
seq);
if (left == table->left)
return table;
table = Node<PgfPhrasetableEntry>::upd_node(table,left,table->right);
return Node<PgfPhrasetableEntry>::balanceR(table);
} else if (cmp > 0) {
PgfPhrasetable right = phrasetable_delete(table->right,
container, seq_index,
seq);
if (right == table->right)
return table;
table = Node<PgfPhrasetableEntry>::upd_node(table,table->left,right);
return Node<PgfPhrasetableEntry>::balanceL(table);
} else {
@@ -821,56 +817,6 @@ void phrasetable_lookup_cohorts(PgfPhrasetable table,
}
}
PGF_INTERNAL
void phrasetable_lookup_epsilons(PgfPhrasetable table,
ref<PgfConcrLincat> lincat, size_t r,
std::function<void(ref<PgfConcrLin>,size_t)> &f)
{
while (table->left != 0) {
table = table->left;
}
if (table->value.seq->syms.len > 0)
return;
size_t len = (table->value.backrefs != 0)
? table->value.backrefs->len
: 0;
ssize_t i = 0;
ssize_t j = len-1;
while (i <= j) {
ssize_t k = (i + j) / 2;
ref<PgfSequenceBackref> backref = vector_elem(table->value.backrefs, k);
int cmp = backref_cmp(backref, lincat, r);
if (cmp < 0) {
j = k-1;
} else if (cmp > 0) {
i = k+1;
} else {
i = k;
while (i > 0) {
ref<PgfSequenceBackref> backref = vector_elem(table->value.backrefs, i-1);
if (backref_cmp(backref, lincat, r) != 0)
break;
f(ref<PgfConcrLin>::untagged(backref->container),backref->seq_index);
i--;
}
f(ref<PgfConcrLin>::untagged(backref->container),backref->seq_index);
j = k;
while (j < len-1) {
ref<PgfSequenceBackref> backref = vector_elem(table->value.backrefs, j+1);
if (backref_cmp(backref, lincat, r) != 0)
break;
f(ref<PgfConcrLin>::untagged(backref->container),backref->seq_index);
j++;
}
break;
}
}
}
PGF_INTERNAL
void phrasetable_iter(PgfConcr *concr,
PgfPhrasetable table,

5
src/runtime/c/pgf/phrasetable.h
View File

@@ -105,11 +105,6 @@ void phrasetable_lookup_cohorts(PgfPhrasetable table,
bool case_sensitive,
PgfPhraseScanner *scanner, PgfExn* err);
PGF_INTERNAL_DECL
void phrasetable_lookup_epsilons(PgfPhrasetable table,
ref<PgfConcrLincat> lincat, size_t r,
std::function<void(ref<PgfConcrLin>, size_t)> &f);
PGF_INTERNAL_DECL
void phrasetable_iter(PgfConcr *concr,
PgfPhrasetable table,