summaryrefslogtreecommitdiff
path: root/interp/syntax_def.ml
diff options
context:
space:
mode:
authorGravatar Samuel Mimram <smimram@debian.org>2008-07-25 15:12:53 +0200
committerGravatar Samuel Mimram <smimram@debian.org>2008-07-25 15:12:53 +0200
commita0cfa4f118023d35b767a999d5a2ac4b082857b4 (patch)
treedabcac548e299fee1da464c93b3dba98484f45b1 /interp/syntax_def.ml
parent2281410e38ef99d025ea77194585a9bc019fdaa9 (diff)
Imported Upstream version 8.2~beta3+dfsgupstream/8.2.beta3+dfsg
Diffstat (limited to 'interp/syntax_def.ml')
-rw-r--r--interp/syntax_def.ml47
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