record type extension freshness check

lib/resource/french/MorphoFre.gf

@@ -57,7 +57,15 @@ oper
   mkCNomInvar : Str -> Gender -> CNom = \cas -> 
     mkCNomIrreg cas cas ;
 
-
+  mkNomReg : Str -> Gender -> CNom = \cas -> 
+    let cass = case last cas of {
+      "s" => cas ;
+      "x" => cas ;
+      "z" => cas ;
+      _   => cas + "s"
+      }
+    in mkCNomIrreg cas cass ;
+      
 
 -- The definite article has quite some variation: three parameters and
 -- elision. This is the simples definition we have been able to find.
@@ -111,7 +119,11 @@ oper
 
   adjHeureux : Str -> Adj = \heureux ->
     let {heureu = Predef.tk 1 heureux} in 
-    mkAdj heureux heureu (heureu+"se") (heureu+"sement") ;
+    mkAdj heureux (heureu+"s") (heureu+"se") (heureu+"sement") ;
+
+  adjBanal : Str -> Adj = \banal ->
+    let {bana = Predef.tk 1 banal} in 
+    mkAdj banal (bana + "ux") (banal+"e") (banal+"ement") ;
 
   adjJeune : Str -> Adj = \jeune -> 
     mkAdj jeune (jeune+"s") jeune (jeune+"ment") ;
@@ -126,6 +138,23 @@ oper
     let {ch = Predef.tk 2 cher} in
     mkAdj cher (cher + "s") (ch + "ère") (ch + "èrement") ; 
 
+  mkAdjReg : Str -> Adj = \creux ->
+    case Predef.dp 3 creux of {
+      "eux" => adjHeureux creux ;
+      _ => case Predef.dp 2 creux of {
+        "al" => adjBanal creux ;
+        "en" => adjIndien creux ;
+        "on" => adjIndien creux ;
+        "er" => adjCher creux ;
+        _ => case Predef.dp 1 creux of {
+          "s" => adjFrancais creux ;
+          "e" => adjJeune creux ;
+          "é" => adjJoli creux ;
+          "i" => adjJoli creux ;
+          _ => adjGrand creux
+          }
+        }
+      } ;
 
 
 --2 Personal pronouns

lib/resource/french/SyntaxFre.gf

@@ -1,6 +1,7 @@
 --# -path=.:../romance:../../prelude
 
-instance SyntaxFre of SyntaxRomance = TypesFre ** open Prelude, (CO=Coordination), MorphoFre in {
+instance SyntaxFre of SyntaxRomance = TypesFre ** 
+  open Prelude, (CO=Coordination), MorphoFre in {
 
 flags optimize=parametrize ;
 

lib/resource/romance/CategoriesRomance.gf

@@ -49,7 +49,7 @@ lincat
   AP     = Adjective ;
   AS     = Adjective ** {mp,mn : Mode} ; --- "more difficult for him to come than..."
   A2S    = Adjective ** {s2 : Preposition} ;
-  AV     = Adjective ;
+  AV     = Adjective ** {c : CaseA} ;
   A2V    = Adjective ** {s2 : Preposition} ;
 
   V      = Verb ; 

lib/resource/romance/ClauseRomance.gf

@@ -17,17 +17,15 @@ incomplete concrete ClauseRomance of Clause = CategoriesRomance **
   SPredV2A np v x y = predVerbClause np v (complDitransAdjVerb v x y) ;
   SPredSubjV2V np v x y = predVerbClause np v (complDitransVerbVerb False v x y) ;
   SPredObjV2V np v x y = predVerbClause np v (complDitransVerbVerb True v x y) ;
-{-
+--  SPredV2S np v x y = predVerbClause np v (complDitransSentVerb v x y) ;
-  SPredV2S np v x y = predVerbClause np v (complDitransSentVerb v x y) ;
+--  SPredV2Q np v x y = predVerbClause np v (complDitransQuestVerb v x y) ;
-  SPredV2Q np v x y = predVerbClause np v (complDitransQuestVerb v x y) ;
--}
   SPredAP np v = predCopula np (complAdjective v) ;
   SPredSuperl np a = predCopula np (complAdjective (superlAdjPhrase a)) ;
   SPredCN np v = predCopula np (complCommNoun v) ;
   SPredNP np v = predCopula np (complNounPhrase v) ;
   SPredPP np v = predCopula np (complAdverb v) ;
-{-
   SPredAV np v x = predCopula np (complVerbAdj v x) ;
+{-
   SPredObjA2V np v x y = predCopula np (complVerbAdj2 True v x y) ;
 
   SPredProgVP = progressiveClause ;

lib/resource/romance/SyntaxRomance.gf

@@ -215,7 +215,7 @@ oper
 
 --3 Comparison adjectives
 --
--- The type is defined in $types.Romance.gf$. Syntax adds to lexicon the position
+-- The type is defined in $TypesRomance$. Syntax adds to lexicon the position
 -- information.
 
   AdjDegr = AdjComp  ** {p : Bool} ;
@@ -489,6 +489,11 @@ oper
   complAdverb : Adverb -> Complemnt = \dehors ->
     complCopula (\\_,_,_ => dehors.s) ; 
 
+  complVerbAdj : (Adjective ** {c : CaseA}) -> VerbPhrase -> Complemnt = \facile,ouvrir ->
+    complCopula (\\g,n,p => 
+      facile.s ! AF g n ++ prepCase facile.c ++ 
+      ouvrir.s ! VIInfinit ! g ! n ! p) ;
+
 -- Passivization is like adjectival predication.
 
   passVerb : Verb -> Complemnt = \aimer ->
@@ -531,6 +536,11 @@ oper
 -- More will be needed when we add ditransitive verbs.
 
   complTransVerb : TransVerb -> NounPhrase -> Complemnt = \aime,jean ->
+    complTransVerbGen aime jean (\\_,_,_ => []) ;
+
+  complTransVerbGen : TransVerb -> NounPhrase ->
+    (Gender => Number => Person => Str) -> Complemnt = 
+    \aime,jean,ici ->
       let
         clit  = andB (isNounPhraseClit jean) (isTransVerbClit aime) ;
         Jean  = jean.s ! (case2pformClit aime.c) ; 
@@ -538,9 +548,12 @@ oper
                    (aime.s ! VPart (pgen2gen jean.g) jean.n)
                    (aime.s ! VPart  Masc             Sg)
       in
-        \\_,_,_ => case clit of {
+        \\g,n,p => 
-            True  => {clit = Jean ; part = aimee ; compl = []} ;
+          let Ici = ici ! g ! n ! p 
-            False => {clit = []   ; part = aimee ; compl = Jean}
+          in
+          case clit of {
+            True  => {clit = Jean ; part = aimee ; compl = Ici} ;
+            False => {clit = []   ; part = aimee ; compl = Jean ++ Ici}
             } ;
 
 ----- add auxVerb to Complemnt to switch to $esse$ in refl ?
@@ -625,35 +638,23 @@ oper
 
   complDitransAdjVerb : 
     TransVerb -> NounPhrase -> AdjPhrase -> Complemnt = \rend,toi,sec ->
-      let
+      complTransVerbGen rend toi (\\g,n,_ => sec.s ! AF g n) ;
-        rendtoi = complTransVerb rend toi
-      in
-        \\g,n,p =>
-        let rt = rendtoi ! g ! n ! p in 
-        {clit = rt.clit ; part = rt.part ; 
-         compl = rt.compl ++ sec.s ! AF g n
-        } ;
 
   DitransVerbVerb = TransVerb ** {c3 : CaseA} ;
 
   complDitransVerbVerb : 
     Bool -> DitransVerbVerb -> NounPhrase -> VerbPhrase -> Complemnt = 
      \obj, demander, toi, nager ->
-      let
+        complTransVerbGen demander toi
-        rendtoi = complTransVerb demander toi
+          (\\g,n,p =>
-      in
+           let 
-        \\g,n,p =>
+             agr : Gender * Number * Person = case obj of {
-        let 
+               True  => <pgen2gen toi.g, toi.n, toi.p> ;
-           rt = rendtoi ! g ! n ! p ;
+               False => <g,    n,    p>
-           agr : Gender * Number * Person = case obj of {
+               } 
-             True  => <pgen2gen toi.g, toi.n, toi.p> ;
+           in 
-             False => <g,    n,    p>
+           prepCase demander.c ++ 
-             } 
+           nager.s ! VIInfinit ! agr.p1 ! agr.p2 ! agr.p3) ;
-        in 
-        {clit = rt.clit ; part = rt.part ; 
-         compl = rt.compl ++ prepCase demander.c ++ 
-                 nager.s ! VIInfinit ! agr.p1 ! agr.p2 ! agr.p3
-        } ;
 
 
 --2 Adverbs
@@ -763,27 +764,28 @@ oper
         co   = comp ! pgen2gen np.g ! np.n ! np.p ;
         la   = co.clit ;
         ici  = co.compl ;
+        aimee = co.part ;
         aime  : TMode -> Str = \t -> verb.s ! (VFin t np.n np.p) ;
         avoir : TMode -> Str = \t -> (auxVerb verb).s ! (VFin t np.n np.p) ;
-        aimee = co.part ;
         aimer = verb.s ! VInfin ;
         avoirr = (auxVerb verb).s ! VInfin
       in
       \\b => table {
-        ClPres   Simul m   => <jean, posNeg b (la ++ aime  (VPres m))   ici> ;
+        ClPres   Simul m => <jean, posNeg b (la ++ aime  (VPres m))   ici> ;
-        ClPres   a m       => <jean, posNeg b (la ++ avoir (VPres m))   (aimee ++ ici)> ;
+        ClPres   a m     => <jean, posNeg b (la ++ avoir (VPres m))   (aimee ++ ici)> ;
-        ClImperf Simul m   => <jean, posNeg b (la ++ aime  (VImperf m)) ici> ;
+        ClImperf Simul m => <jean, posNeg b (la ++ aime  (VImperf m)) ici> ;
-        ClImperf a m       => <jean, posNeg b (la ++ avoir (VImperf m)) (aimee ++ ici)> ;
+        ClImperf a m     => <jean, posNeg b (la ++ avoir (VImperf m)) (aimee ++ ici)> ;
-        ClPasse  Simul     => <jean, posNeg b (la ++ aime  VPasse)      ici> ;
+        ClPasse  Simul   => <jean, posNeg b (la ++ aime  VPasse)      ici> ;
-        ClPasse  a         => <jean, posNeg b (la ++ avoir VPasse)      (aimee ++ ici)> ;
+        ClPasse  a       => <jean, posNeg b (la ++ avoir VPasse)      (aimee ++ ici)> ;
-        ClFut    Simul     => <jean, posNeg b (la ++ aime  VFut)      ici> ;
+        ClFut    Simul   => <jean, posNeg b (la ++ aime  VFut)      ici> ;
-        ClFut    a         => <jean, posNeg b (la ++ avoir VFut)      (aimee ++ ici)> ;
+        ClFut    a       => <jean, posNeg b (la ++ avoir VFut)      (aimee ++ ici)> ;
-        ClCondit Simul     => <jean, posNeg b (la ++ aime  VFut)      ici> ;
+        ClCondit Simul   => <jean, posNeg b (la ++ aime  VFut)      ici> ;
-        ClCondit a         => <jean, posNeg b (la ++ avoir VFut)      (aimee ++ ici)> ;
+        ClCondit a       => <jean, posNeg b (la ++ avoir VFut)      (aimee ++ ici)> ;
-        ClInfinit Simul    => <jean, posNeg b (la ++ aimer)           ici> ;
+        ClInfinit Simul  => <jean, posNeg b (la ++ aimer)           ici> ;
-        ClInfinit a        => <jean, posNeg b (la ++ avoirr)          (aimee ++ ici)>
+        ClInfinit a      => <jean, posNeg b (la ++ avoirr)          (aimee ++ ici)>
         } ;
 
+
 --3 Sentence-complement verbs
 --
 -- Sentence-complement verbs take sentences as complements.

src/GF/Compile/CheckGrammar.hs

@@ -276,7 +276,7 @@ computeLType gr t = do
       r' <- comp r
       s' <- comp s
       case (r',s') of
-        (RecType rs, RecType ss) -> return $ RecType (rs ++ ss)
+        (RecType rs, RecType ss) -> checkErr $ plusRecType r' s'
         _ -> return $ ExtR r' s'
 
     _ | isPredefConstant ty -> return ty
@@ -414,9 +414,13 @@ inferLType gr trm = case trm of
      rT'     <- comp rT
      (s',sT) <- infer s
      sT'     <- comp sT
+
      let trm' = ExtR r' s'
+     ---- trm'    <- checkErr $ plusRecord r' s'
      case (rT', sT') of
-       (RecType rs, RecType ss) -> return (trm', RecType (rs ++ ss))
+       (RecType rs, RecType ss) -> do
+         rt <- checkErr $ plusRecType rT' sT'
+         return (trm', rt)
        _ | rT' == typeType && sT' == typeType -> return (trm', typeType)
        _ -> prtFail "records or record types expected in" trm
 

src/GF/Grammar/Compute.hs

@@ -86,17 +86,21 @@ computeTerm gr = comp where
        t' <- comp g t
        case t' of
          FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . FV
-         R r   -> maybe (prtBad "no value for label" l) (comp g . snd) $ lookup l r 
+         R r   -> maybe (prtBad "no value for label" l) (comp g . snd) $ 
+                    lookup l $ reverse r 
 
-         ExtR (R a) b ->                 -- NOT POSSIBLE both a and b records!
-           case comp g (P (R a) l) of
-             Ok v -> return v
-             _ -> comp g (P b l)
          ExtR a (R b) ->                 
            case comp g (P (R b) l) of
              Ok v -> return v
              _ -> comp g (P a l)
 
+--- { - --- this is incorrect, since b can contain the proper value
+         ExtR (R a) b ->                 -- NOT POSSIBLE both a and b records!
+           case comp g (P (R a) l) of
+             Ok v -> return v
+             _ -> comp g (P b l)
+--- - } ---
+
          Alias _ _ r -> comp g (P r l)
 
          S (T i cs) e -> prawitz g i (flip P l) cs e
@@ -207,8 +211,8 @@ computeTerm gr = comp where
          (Alias _ _ d, _)  -> comp g $ ExtR d s'
          (_, Alias _ _ d)  -> comp g $ Glue r' d
 
-         (R rs, R ss) -> return $ R (rs ++ ss)
+         (R rs, R ss) -> plusRecord r' s'
-         (RecType rs, RecType ss) -> return $ RecType (rs ++ ss)
+         (RecType rs, RecType ss) -> plusRecType r' s'
          _ -> return $ ExtR r' s'
 
      -- case-expand tables

src/GF/Grammar/Lockfield.hs

@@ -24,6 +24,11 @@ import Operations
 -- AR 8/2/2005 detached from compile/MkResource
 
 lockRecType :: Ident -> Type -> Err Type
+lockRecType c t@(RecType rs) = 
+  let lab = lockLabel c in
+  return $ if elem lab (map fst rs) 
+    then t --- don't add an extra copy of the lock field
+    else RecType (rs ++ [(lockLabel c,  RecType [])])
 lockRecType c t = plusRecType t $ RecType [(lockLabel c,  RecType [])]
 
 unlockRecord :: Ident -> Term -> Err Term

src/GF/Grammar/Macros.hs

@@ -339,13 +339,17 @@ mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt], t, []) -- nondep prod
 
 plusRecType :: Type -> Type -> Err Type
 plusRecType t1 t2 = case (unComputed t1, unComputed t2) of
-  (RecType r1, RecType r2) -> return (RecType (r1 ++ r2))
+  (RecType r1, RecType r2) -> case
+    filter (`elem` (map fst r1)) (map fst r2) of
+      [] -> return (RecType (r1 ++ r2))
+      ls -> Bad $ "clashing labels" +++ unwords (map prt ls)
   _ -> Bad ("cannot add record types" +++ prt t1 +++ "and" +++ prt t2) 
 
 plusRecord :: Term -> Term -> Err Term
 plusRecord t1 t2 =
  case (t1,t2) of
-   (R r1, R r2 ) -> return (R (r1 ++ r2))
+   (R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields
+                              (l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
    (_,    FV rs) -> mapM (plusRecord t1) rs >>= return . FV
    (FV rs,_    ) -> mapM (`plusRecord` t2) rs >>= return . FV
    _ -> Bad ("cannot add records" +++ prt t1 +++ "and" +++ prt t2)