Imported Upstream version 8.2~beta3+dfsgupstream/8.2.beta3+dfsg

1 files changed, 27 insertions, 20 deletions

diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml
index 3389cd8a..884dea48 100644
--- a/interp/syntax_def.ml
+++ b/interp/syntax_def.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: syntax_def.ml 7779 2006-01-03 20:33:47Z herbelin $ *)
+(* $Id: syntax_def.ml 10730 2008-03-30 21:42:58Z herbelin $ *)
 
 open Util
 open Pp
@@ -19,7 +19,7 @@ open Nameops
 
 (* Syntactic definitions. *)
 
-let syntax_table = ref (KNmap.empty : aconstr KNmap.t)
+let syntax_table = ref (KNmap.empty : interpretation KNmap.t)
 
 let _ = Summary.declare_summary
 	  "SYNTAXCONSTANT"
@@ -32,28 +32,28 @@ let _ = Summary.declare_summary
 let add_syntax_constant kn c =
   syntax_table := KNmap.add kn c !syntax_table
 
-let load_syntax_constant i ((sp,kn),(local,c,onlyparse)) =
+let load_syntax_constant i ((sp,kn),(local,pat,onlyparse)) =
   if Nametab.exists_cci sp then
     errorlabstrm "cache_syntax_constant"
       (pr_id (basename sp) ++ str " already exists");
-  add_syntax_constant kn c;
+  add_syntax_constant kn pat;
   Nametab.push_syntactic_definition (Nametab.Until i) sp kn;
   if not onlyparse then
     (* Declare it to be used as long name *)
-    Notation.declare_uninterpretation (Notation.SynDefRule kn) ([],c)
+    Notation.declare_uninterpretation (Notation.SynDefRule kn) pat
 
-let open_syntax_constant i ((sp,kn),(_,c,onlyparse)) =
+let open_syntax_constant i ((sp,kn),(_,pat,onlyparse)) =
   Nametab.push_syntactic_definition (Nametab.Exactly i) sp kn;
   if not onlyparse then
     (* Redeclare it to be used as (short) name in case an other (distfix)
        notation was declared inbetween *)
-    Notation.declare_uninterpretation (Notation.SynDefRule kn) ([],c)
+    Notation.declare_uninterpretation (Notation.SynDefRule kn) pat
 
 let cache_syntax_constant d =
   load_syntax_constant 1 d
 
-let subst_syntax_constant ((sp,kn),subst,(local,c,onlyparse)) =
-  (local,subst_aconstr subst [] c,onlyparse)
+let subst_syntax_constant ((sp,kn),subst,(local,pat,onlyparse)) =
+  (local,subst_interpretation subst pat,onlyparse)
 
 let classify_syntax_constant (_,(local,_,_ as o)) =
   if local then Dispose else Substitute o
@@ -70,23 +70,30 @@ let (in_syntax_constant, out_syntax_constant) =
     classify_function = classify_syntax_constant;
     export_function = export_syntax_constant } 
 
-let declare_syntactic_definition local id onlyparse c =
-  let _ = add_leaf id (in_syntax_constant (local,c,onlyparse)) in ()
-
-let rec set_loc loc _ a =
-  rawconstr_of_aconstr_with_binders loc (fun id e -> (id,e)) (set_loc loc) () a
+let declare_syntactic_definition local id onlyparse pat =
+  let _ = add_leaf id (in_syntax_constant (local,pat,onlyparse)) in ()
 
 let search_syntactic_definition loc kn =
-  set_loc loc () (KNmap.find kn !syntax_table)
-
-exception BoundToASyntacticDefThatIsNotARef
+  KNmap.find kn !syntax_table
 
-let locate_global qid =
+let locate_global_with_alias (loc,qid) =
   match Nametab.extended_locate qid with
   | TrueGlobal ref -> ref
   | SyntacticDef kn -> 
   match search_syntactic_definition dummy_loc kn with
-  | Rawterm.RRef (_,ref) -> ref
+  | [],ARef ref -> ref
   | _ -> 
-      errorlabstrm "" (pr_qualid qid ++ 
+      user_err_loc (loc,"",pr_qualid qid ++ 
         str " is bound to a notation that does not denote a reference")
+
+let inductive_of_reference_with_alias r =
+  match locate_global_with_alias (qualid_of_reference r) with
+  | IndRef ind -> ind
+  | ref ->
+      user_err_loc (loc_of_reference r,"global_inductive",
+        pr_reference r ++ spc () ++ str "is not an inductive type")
+
+let global_with_alias r =
+  let (loc,qid as lqid) = qualid_of_reference r in
+  try locate_global_with_alias lqid
+  with Not_found -> Nametab.error_global_not_found_loc loc qid