diff --git a/lib/resource/danish/SyntaxDan.gf b/lib/resource/danish/SyntaxDan.gf index 11cd5b696..1cfca0c9b 100644 --- a/lib/resource/danish/SyntaxDan.gf +++ b/lib/resource/danish/SyntaxDan.gf @@ -113,9 +113,7 @@ instance SyntaxDan of SyntaxScand = TypesDan ** progressiveClause : NounPhrase -> VerbPhrase -> Clause = \np,vp -> predVerbGroupClause np (complVerbVerb - (verbVara ** - {isAux = False} ----- {s3 = ["ved at"]} - ) + {s = verbVara.s ; s1 = "ved" ; isAux = False} vp) ; } \ No newline at end of file diff --git a/lib/resource/english/CategoriesEng.gf b/lib/resource/english/CategoriesEng.gf index 923c3159d..4ee8b7d83 100644 --- a/lib/resource/english/CategoriesEng.gf +++ b/lib/resource/english/CategoriesEng.gf @@ -68,6 +68,7 @@ lincat V2S = TransVerb ; V2Q = TransVerb ; V2V = TransVerb ** {s4 : Str} ; +----V2V = {s : VForm => Str ; s1 : Particle ; s3, s4 : Str} ; V2A = TransVerb ; V0 = Verb ; diff --git a/lib/resource/english/RulesEng.gf b/lib/resource/english/RulesEng.gf index 27ecc4881..e6dd04b92 100644 --- a/lib/resource/english/RulesEng.gf +++ b/lib/resource/english/RulesEng.gf @@ -86,7 +86,7 @@ lin AdjPart = adjPastPart ; - UseV2V x = x ** {isAux = False} ; + UseV2V x = verb2aux x ** {isAux = False} ; UseV2S x = x ; UseV2Q x = x ; UseA2S x = x ; diff --git a/lib/resource/french/ParadigmsFre.gf b/lib/resource/french/ParadigmsFre.gf index 86d74cc2e..ca2fd1133 100644 --- a/lib/resource/french/ParadigmsFre.gf +++ b/lib/resource/french/ParadigmsFre.gf @@ -329,7 +329,7 @@ oper mkV0 v = v ** {lock_V0 = <>} ; mkVS v = v ** {mn,mp = Ind ; lock_VS = <>} ; ---- more moods mkV2S v p = mkV2 v p ** {mn,mp = Ind ; lock_V2S = <>} ; - mkVV v = v ** {c = accusative ; lock_VV = <>} ; + mkVV v = v ** {c = accusative.p1 ; lock_VV = <>} ; deVV v = v ** {c = genitive.p1 ; lock_VV = <>} ; aVV v = v ** {c = dative.p1 ; lock_VV = <>} ; mkV2V v p t = mkV2 v p ** {c3 = t.p1 ; s3 = p.p2 ; lock_V2V = <>} ; diff --git a/lib/resource/italian/ParadigmsIta.gf b/lib/resource/italian/ParadigmsIta.gf index 730d7fa72..3bd58fa78 100644 --- a/lib/resource/italian/ParadigmsIta.gf +++ b/lib/resource/italian/ParadigmsIta.gf @@ -347,7 +347,7 @@ oper mkV0 v = v ** {lock_V0 = <>} ; mkVS v = v ** {mn,mp = Ind ; lock_VS = <>} ; ---- more moods mkV2S v p = mkV2 v p ** {mn,mp = Ind ; lock_V2S = <>} ; - mkVV v = v ** {c = accusative ; lock_VV = <>} ; + mkVV v = v ** {c = accusative.p1 ; lock_VV = <>} ; deVV v = v ** {c = genitive.p1 ; lock_VV = <>} ; aVV v = v ** {c = dative.p1 ; lock_VV = <>} ; mkV2V v p t = mkV2 v p ** {c3 = t.p1 ; s3 = p.p2 ; lock_V2V = <>} ; diff --git a/lib/resource/norwegian/SyntaxNor.gf b/lib/resource/norwegian/SyntaxNor.gf index a797ae488..f81f0c47a 100644 --- a/lib/resource/norwegian/SyntaxNor.gf +++ b/lib/resource/norwegian/SyntaxNor.gf @@ -114,8 +114,6 @@ instance SyntaxNor of SyntaxScand = TypesNor ** progressiveClause : NounPhrase -> VerbPhrase -> Clause = \np,vp -> predVerbGroupClause np (complVerbVerb - (verbVara ** - {isAux = False} ----- {s3 = ["ved at"]} - ) + ({s = verbVara.s ; s1 = "ved" ; isAux = False}) vp) ; } diff --git a/lib/resource/scandinavian/SyntaxScand.gf b/lib/resource/scandinavian/SyntaxScand.gf index b67d8c488..128db5356 100644 --- a/lib/resource/scandinavian/SyntaxScand.gf +++ b/lib/resource/scandinavian/SyntaxScand.gf @@ -637,7 +637,7 @@ oper mkVerbGroupCopula : (Gender => Number => Person => Str) -> VerbGroup = \obj -> - mkVerbGroupObject (verbVara ** {s1 = []}) obj ; + mkVerbGroupObject verbVara obj ; ----------------------- @@ -688,7 +688,7 @@ oper -- on semantic grounds. vara : (Gender => Number => Person => Str) -> VerbGroup = - useVerb (verbVara ** {s1 = []}) ; + useVerb verbVara ; predAdjective : Adjective -> VerbGroup = \arg -> vara (\\g,n,_ => arg.s ! predFormAdj g n ! Nom) ; @@ -1016,7 +1016,7 @@ oper insertObject (mkSats subj verb) obj ; mkSatsCopula : NounPhrase -> Str -> Sats = \subj,obj -> - mkSatsObject subj (verbVara ** {s1 = []}) obj ; + mkSatsObject subj verbVara obj ; --3 Sentence-complement verbs diff --git a/lib/resource/spanish/ParadigmsSpa.gf b/lib/resource/spanish/ParadigmsSpa.gf index 908bd760c..c7154ea23 100644 --- a/lib/resource/spanish/ParadigmsSpa.gf +++ b/lib/resource/spanish/ParadigmsSpa.gf @@ -338,7 +338,7 @@ oper mkV0 v = v ** {lock_V0 = <>} ; mkVS v = v ** {mn,mp = Ind ; lock_VS = <>} ; ---- more moods mkV2S v p = mkV2 v p ** {mn,mp = Ind ; lock_V2S = <>} ; - mkVV v = v ** {c = accusative ; lock_VV = <>} ; + mkVV v = v ** {c = accusative.p1 ; lock_VV = <>} ; deVV v = v ** {c = genitive.p1 ; lock_VV = <>} ; aVV v = v ** {c = dative.p1 ; lock_VV = <>} ; mkV2V v p t = mkV2 v p ** {c3 = t.p1 ; s3 = p.p2 ; lock_V2V = <>} ; diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 9a3b706f2..718260f68 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/21 16:21:34 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.23 $ +-- > CVS $Date: 2005/04/25 18:19:32 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.24 $ -- -- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003 -- @@ -429,7 +429,7 @@ inferLType gr trm = case trm of case (rT', sT') of (RecType rs, RecType ss) -> do rt <- checkErr $ plusRecType rT' sT' - return (trm', rt) + check trm' rt ---- return (trm', rt) _ | rT' == typeType && sT' == typeType -> return (trm', typeType) _ -> prtFail "records or record types expected in" trm @@ -543,21 +543,21 @@ checkLType env trm typ0 = do case trm' of RecType _ -> termWith trm $ return typeType _ -> prtFail "invalid record type extension" trm - RecType rr -> checks [ - do (r',ty) <- infer r - case ty of - RecType rr1 -> do - s' <- justCheck s (minusRecType rr rr1) - return $ (ExtR r' s', typ) - _ -> prtFail "record type expected in extension of" r - , - do (s',ty) <- infer s - case ty of - RecType rr2 -> do - r' <- justCheck r (minusRecType rr rr2) - return $ (ExtR r' s', typ) - _ -> prtFail "record type expected in extension with" s - ] + RecType rr -> do + (r',ty,s') <- checks [ + do (r',ty) <- infer r + return (r',ty,s) + , + do (s',ty) <- infer s + return (s',ty,r) + ] + case ty of + RecType rr1 -> do + let (rr0,rr2) = recParts rr rr1 + r2 <- justCheck r' rr0 + s2 <- justCheck s' rr2 + return $ (ExtR r2 s2, typ) + _ -> raise ("record type expected in extension of" +++ prt r +++ "but found" +++ prt ty) _ -> prtFail "record extension not meaningful for" typ FV vs -> do @@ -600,7 +600,8 @@ checkLType env trm typ0 = do checkEq = checkEqLType env - minusRecType rr rr1 = RecType [(l,v) | (l,v) <- rr, notElem l (map fst rr1)] + recParts rr t = (RecType rr1,RecType rr2) where + (rr1,rr2) = partition (flip elem (map fst t) . fst) rr checkM rms (l,ty) = case lookup l rms of Just (Just ty0,t) -> do