diff options
Diffstat (limited to 'interp/syntax_def.ml')
| -rw-r--r-- | interp/syntax_def.ml | 47 |
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 |