Commit 2da34588 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-09-16 21:30:42 by cvscast] Cleaning in progress... + no more...

[r2003-09-16 21:30:42 by cvscast] Cleaning in progress... + no more uppercase/lowercase distinction for
identifiers

Original author: cvscast
Date: 2003-09-16 21:30:45+00:00
parent 767d0c34
......@@ -8,24 +8,24 @@ misc/pool.cmo: misc/q_symbol.cmo misc/custom.cmo misc/state.cmi misc/pool.cmi
misc/pool.cmx: misc/q_symbol.cmo misc/custom.cmx misc/state.cmx misc/pool.cmi
misc/encodings.cmo: misc/q_symbol.cmo misc/encodings.cmi
misc/encodings.cmx: misc/q_symbol.cmo misc/encodings.cmi
misc/bool.cmo: misc/q_symbol.cmo misc/custom.cmo misc/bool.cmi
misc/bool.cmx: misc/q_symbol.cmo misc/custom.cmx misc/bool.cmi
misc/bool.cmo: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi misc/bool.cmi
misc/bool.cmx: misc/q_symbol.cmo misc/custom.cmx misc/serialize.cmx misc/bool.cmi
misc/pretty.cmo: misc/q_symbol.cmo misc/pretty.cmi
misc/pretty.cmx: misc/q_symbol.cmo misc/pretty.cmi
misc/ns.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/pool.cmi misc/state.cmi misc/ns.cmi
misc/ns.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/pool.cmx misc/state.cmx misc/ns.cmi
types/sortedList.cmo: misc/q_symbol.cmo misc/custom.cmo types/sortedList.cmi
types/sortedList.cmx: misc/q_symbol.cmo misc/custom.cmx types/sortedList.cmi
types/sortedList.cmo: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi types/sortedList.cmi
types/sortedList.cmx: misc/q_symbol.cmo misc/custom.cmx misc/serialize.cmx types/sortedList.cmi
types/boolean.cmo: misc/q_symbol.cmo misc/custom.cmo types/sortedList.cmi types/boolean.cmi
types/boolean.cmx: misc/q_symbol.cmo misc/custom.cmx types/sortedList.cmx types/boolean.cmi
types/ident.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/ns.cmi misc/pool.cmi \
types/sortedList.cmi
types/ident.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/ns.cmx misc/pool.cmx \
types/sortedList.cmx
types/intervals.cmo: misc/q_symbol.cmo types/intervals.cmi
types/intervals.cmx: misc/q_symbol.cmo types/intervals.cmi
types/chars.cmo: misc/q_symbol.cmo types/chars.cmi
types/chars.cmx: misc/q_symbol.cmo types/chars.cmi
types/intervals.cmo: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi types/intervals.cmi
types/intervals.cmx: misc/q_symbol.cmo misc/custom.cmx misc/serialize.cmx types/intervals.cmi
types/chars.cmo: misc/q_symbol.cmo misc/custom.cmo types/chars.cmi
types/chars.cmx: misc/q_symbol.cmo misc/custom.cmx types/chars.cmi
types/atoms.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/ns.cmi misc/pool.cmi \
types/sortedList.cmi types/atoms.cmi
types/atoms.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/ns.cmx misc/pool.cmx \
......@@ -111,13 +111,13 @@ typing/typed.cmx: misc/q_symbol.cmo types/ident.cmx parser/location.cmx types/pa
typing/typer.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \
types/chars.cmi types/ident.cmo parser/location.cmi misc/ns.cmi \
types/patterns.cmi schema/schema_builtin.cmi schema/schema_types.cmi \
schema/schema_validator.cmi types/sequence.cmi misc/state.cmi \
typing/typed.cmo types/types.cmi typing/typer.cmi
schema/schema_validator.cmi types/sequence.cmi misc/serialize.cmi \
misc/state.cmi typing/typed.cmo types/types.cmi typing/typer.cmi
typing/typer.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/builtin_defs.cmx \
types/chars.cmx types/ident.cmx parser/location.cmx misc/ns.cmx \
types/patterns.cmx schema/schema_builtin.cmx schema/schema_types.cmx \
schema/schema_validator.cmx types/sequence.cmx misc/state.cmx \
typing/typed.cmx types/types.cmx typing/typer.cmi
schema/schema_validator.cmx types/sequence.cmx misc/serialize.cmx \
misc/state.cmx typing/typed.cmx types/types.cmx typing/typer.cmi
runtime/load_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi types/ident.cmo \
parser/location.cmi misc/ns.cmi runtime/value.cmi runtime/load_xml.cmi
runtime/load_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx types/ident.cmx \
......@@ -173,6 +173,8 @@ misc/bool.cmi: misc/q_symbol.cmo misc/custom.cmo
misc/ns.cmi: misc/q_symbol.cmo misc/custom.cmo misc/encodings.cmi
types/sortedList.cmi: misc/q_symbol.cmo misc/custom.cmo
types/boolean.cmi: misc/q_symbol.cmo misc/custom.cmo
types/intervals.cmi: misc/q_symbol.cmo misc/custom.cmo
types/chars.cmi: misc/q_symbol.cmo misc/custom.cmo
types/atoms.cmi: misc/q_symbol.cmo misc/encodings.cmi misc/ns.cmi
types/types.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \
types/ident.cmo types/intervals.cmi
......
......@@ -84,8 +84,9 @@ let rec print_exn ppf = function
Format.fprintf ppf "Residual type:@.%a@."
print_norm t;
Format.fprintf ppf "Sample:@.%a@." print_sample (Sample.get t)
| Typer.UnboundId x ->
Format.fprintf ppf "Unbound identifier %a@." U.print (Id.value x)
| Typer.UnboundId (x,tn) ->
Format.fprintf ppf "Unbound identifier %a%s@." U.print (Id.value x)
(if tn then " (it is a type name)" else "")
| Wlexer.Illegal_character c ->
Format.fprintf ppf "Illegal character (%a)@." print_protect (Char.escaped c)
| Wlexer.Unterminated_comment ->
......
......@@ -31,6 +31,7 @@ struct
| True
| False
| Split of int * elem * t * t * t
include Custom.Dummy
let rec equal a b =
......@@ -69,17 +70,28 @@ struct
let compute_hash x p i n =
(X.hash x) + 17 * (hash p) + 257 * (hash i) + 16637 * (hash n)
let rec check = function
| True | False -> ()
| Split (h,x,p,i,n) ->
assert (h = compute_hash x p i n);
(match p with Split (_,y,_,_,_) -> assert (X.compare x y < 0) | _ -> ());
(match i with Split (_,y,_,_,_) -> assert (X.compare x y < 0) | _ -> ());
(match n with Split (_,y,_,_,_) -> assert (X.compare x y < 0) | _ -> ());
check p; check i; check n
let atom x =
let h = X.hash x + 17 in (* partial evaluation of compute_hash... *)
Split (h, x,True,False,False)
let neg_atom x =
let h = X.hash x + 16637 in (* partial evaluation of compute_hash... *)
Split (h, x,False,False,True)
let rec iter f = function
| Split (_, x, p,i,n) -> f x; iter f p; iter f i; iter f n
| _ -> ()
(* TODO: precompute hash value for Split node to have fast equality... *)
let rec dump ppf = function
| True -> Format.fprintf ppf "+"
| False -> Format.fprintf ppf "-"
......@@ -142,6 +154,10 @@ struct
let split x pos ign neg =
Split (compute_hash x pos ign neg, x, pos, ign, neg)
let empty = False
let full = True
......@@ -329,6 +345,41 @@ struct
let cap = ( ** )
let diff = ( // )
let rec serialize t = function
| (True | False) as b ->
Serialize.Put.bool t true; Serialize.Put.bool t (b = True)
| Split (_,x,p,i,n) ->
Serialize.Put.bool t false;
X.serialize t x;
serialize t p;
serialize t i;
serialize t n
let rec cap_atom x pos a = (* Assume that x does not appear in a *)
match a with
| False -> False
| True -> if pos then atom x else neg_atom x
| Split (_,y,p,i,n) ->
let c = X.compare x y in
assert (c <> 0);
if x < y then
if pos then split x a False False
else split x False False a
else split y (cap_atom x pos p) (cap_atom x pos i) (cap_atom x pos n)
let rec deserialize t =
if Serialize.Get.bool t then
if Serialize.Get.bool t then True else False
else
let x = X.deserialize t in
let p = deserialize t in
let i = deserialize t in
let n = deserialize t in
(cap_atom x true p) ++ i ++ (cap_atom x false n)
(* split x p i n is not ok, because order of keys might have changed! *)
(*
let diff x y =
let d = diff x y in
......
......@@ -16,13 +16,13 @@ module type T = sig
end
module Dummy = struct
let dump ppf _ = assert false
let check _ = assert false
let equal t1 t2 = assert false
let hash t = assert false
let compare t1 t2 = assert false
let serialize t = assert false
let deserialize t = assert false
let dump ppf _ = failwith "dump not implemented"
let check _ = failwith "check not implemented"
let equal t1 t2 = failwith "equal not implemented"
let hash t = failwith "hash not implemented"
let compare t1 t2 = failwith "compare not implemented"
let serialize t = failwith "serialize not implemented"
let deserialize t = failwith "deserialize not implemented"
end
let dump_list ?(sep="; ") f ppf l =
......@@ -96,8 +96,8 @@ module List(X : T) = struct
| [],_ -> -1
| _ -> 1
let serialize = Serialize.Put.list X.serialize
let deserialize = Serialize.Get.list X.deserialize
let serialize t x = Serialize.Put.list X.serialize t x
let deserialize t = Serialize.Get.list X.deserialize t
end
......@@ -114,6 +114,6 @@ module Pair(X : T)(Y : T) = struct
let equal (x1,y1) (x2,y2) = (X.equal x1 x2) && (Y.equal y1 y2)
let hash (x,y) = X.hash x + 17 * Y.hash y
let serialize = Serialize.Put.pair X.serialize Y.serialize
let deserialize = Serialize.Get.pair X.deserialize Y.deserialize
let serialize t x = Serialize.Put.pair X.serialize Y.serialize t x
let deserialize t = Serialize.Get.pair X.deserialize Y.deserialize t
end
......@@ -6,9 +6,23 @@ module Put = struct
}
type 'a f = t -> 'a -> unit
type 'b property = (t * 'b) list ref
let properties = ref []
let get_property prop t = List.assq t !prop
let mk_property init =
let prop = ref [] in
properties :=
((fun t -> prop := (t, init t) :: !prop),
(fun t -> prop := List.remove_assq t !prop)) :: !properties;
prop
let run f x =
let t = { buf = Buffer.create 1024; cur_byte = 0; cur_bits = 0 } in
List.iter (fun (f,_) -> f t) !properties;
f t x;
List.iter (fun (_,f) -> f t) !properties;
if t.cur_bits > 0 then Buffer.add_char t.buf (Char.chr t.cur_byte);
Buffer.contents t.buf
......@@ -21,11 +35,11 @@ module Put = struct
) else
t.cur_bits <- succ t.cur_bits
let rec bits t i nb = (* TODO: opt *)
if (nb > 0) then (bool t ((i land 1) <> 0); bits t (i lsr 1) (pred nb))
let rec bits nb t i = (* TODO: opt *)
if (nb > 0) then (bool t ((i land 1) <> 0); bits (pred nb) t (i lsr 1))
let rec int t i =
bits t i 4;
bits 4 t i;
let i = i lsr 4 in
if i <> 0 then (bool t true; int t i) else (bool t false)
......@@ -33,7 +47,7 @@ module Put = struct
let l = String.length s in
int t l;
for i = 0 to l - 1 do
bits t (Char.code (s.[i])) 8
bits 8 t (Char.code (s.[i]))
done
let rec list f t = function
......@@ -41,6 +55,7 @@ module Put = struct
| hd::tl -> bool t true; f t hd; list f t tl
let pair f1 f2 t (x,y) = f1 t x; f2 t y
end
......@@ -57,14 +72,14 @@ module Get = struct
else t.idx_bits <- succ t.idx_bits;
b
let rec bits t nb =
let rec bits nb t =
if nb = 0 then 0
else if bool t
then succ (bits t (pred nb) lsl 1)
else bits t (pred nb) lsl 1
then succ (bits (pred nb) t lsl 1)
else bits (pred nb) t lsl 1
let rec int t =
let i = bits t 4 in
let i = bits 4 t in
if bool t then i + (int t) lsl 4
else i
......@@ -72,7 +87,7 @@ module Get = struct
let l = int t in
let s = String.create l in
for i = 0 to l - 1 do
s.[i] <- Char.chr (bits t 8)
s.[i] <- Char.chr (bits 8 t)
done;
s
......
......@@ -3,12 +3,17 @@ module Put : sig
type 'a f = t -> 'a -> unit
val run: 'a f -> 'a -> string
val bits: int -> int f
val int: int f
val string: string f
val bool: bool f
val list: 'a f -> 'a list f
val pair: 'a f -> 'b f -> ('a * 'b) f
type 'b property
val mk_property: (t -> 'b) -> 'b property
val get_property: 'b property -> t -> 'b
end
module Get : sig
......@@ -16,6 +21,7 @@ module Get : sig
type 'a f = t -> 'a
val run : 'a f -> string -> 'a
val bits: int -> int f
val int : int f
val string: string f
val bool: bool f
......
......@@ -99,7 +99,6 @@ and ppat' =
| Arrow of ppat * ppat
| Optional of ppat
| Record of bool * (label * ppat) list
| Capture of id
| Constant of id * pconst
| Regexp of regexp * ppat
(* regular expression, continuation: [ re ; cont ], e.g: [ re ; nil ] *)
......
......@@ -12,8 +12,8 @@ let error (i,j) s = Location.raise_loc i j (Error s)
let gram = Grammar.gcreate (Wlexer.lexer Wlexer.token Wlexer.latin1_engine)
let true_atom = Atoms.mk_ascii "true"
let false_atom = Atoms.mk_ascii "false"
let true_atom = Atoms.V.mk_ascii "true"
let false_atom = Atoms.V.mk_ascii "false"
let true_type = Types.atom (Atoms.atom true_atom)
let false_type = Types.atom (Atoms.atom false_atom)
......@@ -77,13 +77,11 @@ let is_fun_decl =
Grammar.Entry.of_parser gram "[is_fun_decl]"
(fun strm ->
match Stream.npeek 3 strm with
| [ ("", "fun"); ("LIDENT", _); ("", "(") ]
| [ ("LIDENT", _) ; ("", "(") ; _ ] -> ()
| [ ("", "fun"); ("IDENT", _); ("", "(") ]
| [ ("IDENT", _) ; ("", "(") ; _ ] -> ()
| _ -> raise Stream.Failure
)
let dot_RE = Pcre.regexp "\\."
EXTEND
GLOBAL: top_phrases prog expr pat regexp const;
......@@ -95,7 +93,7 @@ EXTEND
[ l = LIST0 [ p = phrase ; OPT ";;" -> p ]; EOI -> List.flatten l ]
];
uident: [ [ x = UIDENT -> parse_ident x ] ];
uident: [ [ x = IDENT -> parse_ident x ] ];
phrase: [
[ (f,p,e) = let_binding ->
......@@ -104,8 +102,7 @@ EXTEND
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
[ mk loc (EvalStatement (exp loc (Match (e1,[p,e2])))) ]
| "type"; x = uident; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
| "type"; x = LIDENT -> error loc "Type identifiers must be capitalized"
| "schema"; name = UIDENT; "="; uri = STRING2 ->
| "schema"; name = IDENT; "="; uri = STRING2 ->
protect_op "schema";
let schema_doc = Schema_xml.pxp_tree_of uri in
let schema = Schema_parser.parse_schema schema_doc in
......@@ -150,11 +147,11 @@ EXTEND
];
debug_directive: [
[ LIDENT "filter"; t = pat; p = pat -> `Filter(t,p)
| LIDENT "accept"; p = pat -> `Accept p
| LIDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
| LIDENT "sample"; t = pat -> `Sample t
| LIDENT "subtype"; t1 = pat; t2 = pat -> `Subtype (t1,t2)
[ IDENT "filter"; t = pat; p = pat -> `Filter(t,p)
| IDENT "accept"; p = pat -> `Accept p
| IDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
| IDENT "sample"; t = pat -> `Sample t
| IDENT "subtype"; t1 = pat; t2 = pat -> `Subtype (t1,t2)
]
];
......@@ -186,10 +183,11 @@ EXTEND
exp loc (Match (e, [p1,e1; p2,e2]))
| "transform"; e = SELF; "with"; b = branches ->
exp loc (Transform (e,b))
| "validate"; e = SELF; "with"; schema = UIDENT; "#";
typ = [ UIDENT | LIDENT | keyword ] ->
| "validate"; e = SELF; "with"; schema = IDENT; "#";
typ = [ IDENT | keyword ] ->
exp loc (Validate (e, schema, typ))
| "fun"; (f,a,b) = fun_decl ->
let f = match f with Some x -> Some (Ident.ident x) | None -> None in
exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
exp loc (Match (e1,[p,e2]))
......@@ -218,7 +216,7 @@ EXTEND
|
[ e1 = expr; op = ["+" | "-" | "@" ]; e2 = expr ->
exp loc (Op (op,[e1;e2]))
| e = expr; "\\"; l = [LIDENT | UIDENT | keyword ] ->
| e = expr; "\\"; l = [IDENT | keyword ] ->
exp loc (RemoveField (e, label l))
]
|
......@@ -235,28 +233,28 @@ EXTEND
exp loc (Transform (e,[b]))
]
|
[ e = expr; "."; l = [LIDENT | UIDENT | keyword ] ->
[ e = expr; "."; l = [IDENT | keyword ] ->
exp loc (Dot (e, label l))
]
|
[ op = [ LIDENT "flatten"
| LIDENT "load_xml"
| LIDENT "load_file" | LIDENT "load_file_utf8"
| LIDENT "getenv"
| LIDENT "load_html"
| LIDENT "print_xml" | LIDENT "print_xml_utf8"
| LIDENT "print"
| LIDENT "int_of"
| LIDENT "string_of"
| LIDENT "atom_of"
| LIDENT "raise"
[ op = [ IDENT "flatten"
| IDENT "load_xml"
| IDENT "load_file" | IDENT "load_file_utf8"
| IDENT "getenv"
| IDENT "load_html"
| IDENT "print_xml" | IDENT "print_xml_utf8"
| IDENT "print"
| IDENT "int_of"
| IDENT "string_of"
| IDENT "atom_of"
| IDENT "raise"
];
e = expr -> exp loc (Op (op,[e]))
| op = [ LIDENT "dump_to_file" | LIDENT "dump_to_file_utf8" ];
| op = [ IDENT "dump_to_file" | IDENT "dump_to_file_utf8" ];
e1 = expr LEVEL "no_appl"; e2 = expr -> exp loc (Op (op, [e1;e2]))
| e1 = SELF; LIDENT "div"; e2 = expr -> exp loc (Op ("/", [e1;e2]))
| e1 = SELF; LIDENT "mod"; e2 = expr -> exp loc (Op ("mod", [e1;e2]))
| e1 = SELF; IDENT "div"; e2 = expr -> exp loc (Op ("/", [e1;e2]))
| e1 = SELF; IDENT "mod"; e2 = expr -> exp loc (Op ("mod", [e1;e2]))
| e1 = SELF; e2 = expr -> exp loc (Apply (e1,e2))
]
......@@ -287,19 +285,19 @@ EXTEND
| s = STRING2 ->
let s = U.mk s in
exp loc (String (U.start_index s, U.end_index s, s, cst_nil))
| a = LIDENT -> exp loc (Var (ident a))
| a = IDENT -> exp loc (Var (ident a))
| "!"; e = expr ->
exp loc (Apply (Dot (e, U.mk "get"), cst_nil))
]
];
tag: [ [ a = [ LIDENT | UIDENT | keyword ] ->
tag: [ [ a = [ IDENT | keyword ] ->
Const_atom (parse_ident a) ] ];
tag_type: [
[ LIDENT "_" -> mk loc (Internal (Types.atom Atoms.any))
| a = [ LIDENT | UIDENT | keyword ] -> mk loc (AtomT (parse_ident a))
[ IDENT "_" -> mk loc (Internal (Types.atom Atoms.any))
| a = [ IDENT | keyword ] -> mk loc (AtomT (parse_ident a))
| t = ANY_IN_NS -> mk loc (NsT (parse_ident t))
]
];
......@@ -315,7 +313,7 @@ EXTEND
namespace_binding: [
[ "namespace";
name = [ name = [ UIDENT | LIDENT | keyword ]; "=" ->
name = [ name = [ IDENT | keyword ]; "=" ->
parse_ident name
| -> U.mk "" ];
uri = STRING2 ->
......@@ -328,8 +326,8 @@ EXTEND
let_binding: [
[ "let"; is_fun_decl; OPT "fun"; (f,a,b) = fun_decl ->
let f = match f with Some x -> x | None -> assert false in
let p = mk loc (Capture f) in
let abst = { fun_name = Some f; fun_iface = a; fun_body = b } in
let p = mk loc (PatVar f) in
let abst = { fun_name = Some (Ident.ident f); fun_iface = a; fun_body = b } in
let e = exp loc (Abstraction abst) in
(true,p,e)
| "let"; p = pat; "="; e = expr -> (false,p,e)
......@@ -339,7 +337,7 @@ EXTEND
fun_decl_after_lparen: [
(* need an hack to do this, because both productions would
match [ OPT LIDENT; "("; pat ] .... *)
match [ OPT IDENT; "("; pat ] .... *)
[ p1 = pat LEVEL "no_arrow";
res = [ "->"; p2 = pat;
a = [ ";"; a = LIST0 arrow SEP ";" -> a | -> [] ];
......@@ -362,7 +360,7 @@ EXTEND
fun_decl: [
[ f = OPT [ x = LIDENT -> ident x]; "("; (a,b) = fun_decl_after_lparen ->
[ f = OPT uident; "("; (a,b) = fun_decl_after_lparen ->
(f,a,b)
]
];
......@@ -387,7 +385,7 @@ EXTEND
| _ -> Alt (x,y)
]
| [ x = regexp; y = regexp -> Seq (x,y) ]
| [ a = LIDENT; "::"; x = regexp -> SeqCapture (ident a,x) ]
| [ a = IDENT; "::"; x = regexp -> SeqCapture (ident a,x) ]
| [ x = regexp; "*" -> Star x
| x = regexp; "*?" -> WeakStar x
| x = regexp; "+" -> Seq (x, Star x)
......@@ -395,17 +393,17 @@ EXTEND
| x = regexp; "?" -> Alt (x, Epsilon)
| x = regexp; "??" -> Alt (Epsilon, x) ]
| [ "("; x = regexp; ")" -> x
| "("; a = LIDENT; ":="; c = const; ")" ->
| "("; a = IDENT; ":="; c = const; ")" ->
Elem (mk loc (Constant ((ident a,c))))
| UIDENT "PCDATA" -> string_regexp
| IDENT "PCDATA" -> string_regexp
| i = STRING1; "--"; j = STRING1 ->
let i = Chars.mk_int (parse_char loc i)
and j = Chars.mk_int (parse_char loc j) in
let i = Chars.V.mk_int (parse_char loc i)
and j = Chars.V.mk_int (parse_char loc j) in
Elem (mk loc (Internal (Types.char (Chars.char_class i j))))
| s = STRING1 ->
List.fold_right
(fun c accu ->
let c = Chars.mk_int c in
let c = Chars.V.mk_int c in
let c = Chars.atom c in
Seq (Elem (mknoloc (Internal (Types.char c))), accu))
(seq_of_string s)
......@@ -415,10 +413,8 @@ EXTEND
];
pat: [
[ x = pat; LIDENT "where";
b = LIST1 [ a = uident; "="; y = pat -> (a,y)
| LIDENT -> error loc "Type/pattern identifiers must be capitalized"
] SEP "and"
[ x = pat; IDENT "where";
b = LIST1 [ a = uident; "="; y = pat -> (a,y) ] SEP "and"
-> mk loc (Recurs (x,b)) ]
| RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y)) ]
| "no_arrow" [ x = pat; "|"; y = pat -> mk loc (Or (x,y)) ]
......@@ -432,11 +428,10 @@ EXTEND
and set_fun = mk loc (Arrow (p, pat_nil)) in
let fields = [ label "get", get_fun; label "set", set_fun ] in
mk loc (Record (false, fields))
| LIDENT "_" -> mk loc (Internal Types.any)
| a = LIDENT -> mk loc (Capture (ident a))
| "("; a = LIDENT; ":="; c = const; ")" ->
| IDENT "_" -> mk loc (Internal Types.any)
| "("; a = IDENT; ":="; c = const; ")" ->
mk loc (Constant (ident a,c))
| schema = UIDENT; "#"; typ = [ UIDENT | LIDENT | keyword ];
| schema = IDENT; "#"; typ = [ IDENT | keyword ];
k = OPT [ "as"; k = [ "element" | "type" | "attribute" ] -> k ] ->
let kind =
match k with
......@@ -447,19 +442,20 @@ EXTEND
| _ -> assert false
in
mk loc (SchemaVar (kind, schema, typ))
| a = uident -> mk loc (PatVar a)
| a = uident ->
mk loc (PatVar a)
| i = INT ; "--"; j = INT ->
let i = Intervals.mk i
and j = Intervals.mk j in
let i = Intervals.V.mk i
and j = Intervals.V.mk j in
mk loc (Internal (Types.interval (Intervals.bounded i j)))
| i = INT ->
let i = Intervals.mk i in
let i = Intervals.V.mk i in
mk loc (Internal (Types.interval (Intervals.atom i)))
| "*"; "--"; j = INT ->
let j = Intervals.mk j in
let j = Intervals.V.mk j in
mk loc (Internal (Types.interval (Intervals.left j)))
| i = INT; "--"; "*" ->
let i = Intervals.mk i in
let i = Intervals