record extension typs checking fixed

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) ;
 
 }

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 ;
 

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 ;

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 = <>} ;

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 = <>} ;

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) ;
 }

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

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 = <>} ;

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