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 ...@@ -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/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.cmo: misc/q_symbol.cmo misc/encodings.cmi
misc/encodings.cmx: 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.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/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.cmo: misc/q_symbol.cmo misc/pretty.cmi
misc/pretty.cmx: 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.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 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.cmo: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi types/sortedList.cmi
types/sortedList.cmx: misc/q_symbol.cmo misc/custom.cmx 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.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/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/ident.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/ns.cmi misc/pool.cmi \
types/sortedList.cmi types/sortedList.cmi
types/ident.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/ns.cmx misc/pool.cmx \ types/ident.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/ns.cmx misc/pool.cmx \
types/sortedList.cmx types/sortedList.cmx
types/intervals.cmo: misc/q_symbol.cmo types/intervals.cmi types/intervals.cmo: misc/q_symbol.cmo misc/custom.cmo misc/serialize.cmi types/intervals.cmi
types/intervals.cmx: misc/q_symbol.cmo 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 types/chars.cmi types/chars.cmo: misc/q_symbol.cmo misc/custom.cmo types/chars.cmi
types/chars.cmx: misc/q_symbol.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/atoms.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/ns.cmi misc/pool.cmi \
types/sortedList.cmi types/atoms.cmi types/sortedList.cmi types/atoms.cmi
types/atoms.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/ns.cmx misc/pool.cmx \ 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 ...@@ -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 \ 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/chars.cmi types/ident.cmo parser/location.cmi misc/ns.cmi \
types/patterns.cmi schema/schema_builtin.cmi schema/schema_types.cmi \ types/patterns.cmi schema/schema_builtin.cmi schema/schema_types.cmi \
schema/schema_validator.cmi types/sequence.cmi misc/state.cmi \ schema/schema_validator.cmi types/sequence.cmi misc/serialize.cmi \
typing/typed.cmo types/types.cmi typing/typer.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 \ 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/chars.cmx types/ident.cmx parser/location.cmx misc/ns.cmx \
types/patterns.cmx schema/schema_builtin.cmx schema/schema_types.cmx \ types/patterns.cmx schema/schema_builtin.cmx schema/schema_types.cmx \
schema/schema_validator.cmx types/sequence.cmx misc/state.cmx \ schema/schema_validator.cmx types/sequence.cmx misc/serialize.cmx \
typing/typed.cmx types/types.cmx typing/typer.cmi 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 \ 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 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 \ 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 ...@@ -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 misc/ns.cmi: misc/q_symbol.cmo misc/custom.cmo misc/encodings.cmi
types/sortedList.cmi: misc/q_symbol.cmo misc/custom.cmo types/sortedList.cmi: misc/q_symbol.cmo misc/custom.cmo
types/boolean.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/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/types.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \
types/ident.cmo types/intervals.cmi types/ident.cmo types/intervals.cmi
......
...@@ -84,8 +84,9 @@ let rec print_exn ppf = function ...@@ -84,8 +84,9 @@ let rec print_exn ppf = function
Format.fprintf ppf "Residual type:@.%a@." Format.fprintf ppf "Residual type:@.%a@."
print_norm t; print_norm t;
Format.fprintf ppf "Sample:@.%a@." print_sample (Sample.get t) Format.fprintf ppf "Sample:@.%a@." print_sample (Sample.get t)
| Typer.UnboundId x -> | Typer.UnboundId (x,tn) ->
Format.fprintf ppf "Unbound identifier %a@." U.print (Id.value x) 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 -> | Wlexer.Illegal_character c ->
Format.fprintf ppf "Illegal character (%a)@." print_protect (Char.escaped c) Format.fprintf ppf "Illegal character (%a)@." print_protect (Char.escaped c)
| Wlexer.Unterminated_comment -> | Wlexer.Unterminated_comment ->
......
...@@ -31,6 +31,7 @@ struct ...@@ -31,6 +31,7 @@ struct
| True | True
| False | False
| Split of int * elem * t * t * t | Split of int * elem * t * t * t
include Custom.Dummy include Custom.Dummy
let rec equal a b = let rec equal a b =
...@@ -69,17 +70,28 @@ struct ...@@ -69,17 +70,28 @@ struct
let compute_hash x p i n = let compute_hash x p i n =
(X.hash x) + 17 * (hash p) + 257 * (hash i) + 16637 * (hash 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 atom x =
let h = X.hash x + 17 in (* partial evaluation of compute_hash... *) let h = X.hash x + 17 in (* partial evaluation of compute_hash... *)
Split (h, x,True,False,False) 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 let rec iter f = function
| Split (_, x, p,i,n) -> f x; iter f p; iter f i; iter f n | 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 let rec dump ppf = function
| True -> Format.fprintf ppf "+" | True -> Format.fprintf ppf "+"
| False -> Format.fprintf ppf "-" | False -> Format.fprintf ppf "-"
...@@ -142,6 +154,10 @@ struct ...@@ -142,6 +154,10 @@ struct
let split x pos ign neg = let split x pos ign neg =
Split (compute_hash x pos ign neg, x, pos, ign, neg) Split (compute_hash x pos ign neg, x, pos, ign, neg)
let empty = False let empty = False
let full = True let full = True
...@@ -329,6 +345,41 @@ struct ...@@ -329,6 +345,41 @@ struct
let cap = ( ** ) let cap = ( ** )
let diff = ( // ) 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 diff x y =
let d = diff x y in let d = diff x y in
......
...@@ -16,13 +16,13 @@ module type T = sig ...@@ -16,13 +16,13 @@ module type T = sig
end end
module Dummy = struct module Dummy = struct
let dump ppf _ = assert false let dump ppf _ = failwith "dump not implemented"
let check _ = assert false let check _ = failwith "check not implemented"
let equal t1 t2 = assert false let equal t1 t2 = failwith "equal not implemented"
let hash t = assert false let hash t = failwith "hash not implemented"
let compare t1 t2 = assert false let compare t1 t2 = failwith "compare not implemented"
let serialize t = assert false let serialize t = failwith "serialize not implemented"
let deserialize t = assert false let deserialize t = failwith "deserialize not implemented"
end end
let dump_list ?(sep="; ") f ppf l = let dump_list ?(sep="; ") f ppf l =
...@@ -96,8 +96,8 @@ module List(X : T) = struct ...@@ -96,8 +96,8 @@ module List(X : T) = struct
| [],_ -> -1 | [],_ -> -1
| _ -> 1 | _ -> 1
let serialize = Serialize.Put.list X.serialize let serialize t x = Serialize.Put.list X.serialize t x
let deserialize = Serialize.Get.list X.deserialize let deserialize t = Serialize.Get.list X.deserialize t
end end
...@@ -114,6 +114,6 @@ module Pair(X : T)(Y : T) = struct ...@@ -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 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 hash (x,y) = X.hash x + 17 * Y.hash y
let serialize = Serialize.Put.pair X.serialize Y.serialize let serialize t x = Serialize.Put.pair X.serialize Y.serialize t x
let deserialize = Serialize.Get.pair X.deserialize Y.deserialize let deserialize t = Serialize.Get.pair X.deserialize Y.deserialize t
end end
...@@ -6,9 +6,23 @@ module Put = struct ...@@ -6,9 +6,23 @@ module Put = struct
} }
type 'a f = t -> 'a -> unit 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 run f x =
let t = { buf = Buffer.create 1024; cur_byte = 0; cur_bits = 0 } in let t = { buf = Buffer.create 1024; cur_byte = 0; cur_bits = 0 } in
List.iter (fun (f,_) -> f t) !properties;
f t x; 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); if t.cur_bits > 0 then Buffer.add_char t.buf (Char.chr t.cur_byte);
Buffer.contents t.buf Buffer.contents t.buf
...@@ -21,11 +35,11 @@ module Put = struct ...@@ -21,11 +35,11 @@ module Put = struct
) else ) else
t.cur_bits <- succ t.cur_bits t.cur_bits <- succ t.cur_bits
let rec bits t i nb = (* TODO: opt *) let rec bits nb t i = (* TODO: opt *)
if (nb > 0) then (bool t ((i land 1) <> 0); bits t (i lsr 1) (pred nb)) if (nb > 0) then (bool t ((i land 1) <> 0); bits (pred nb) t (i lsr 1))
let rec int t i = let rec int t i =
bits t i 4; bits 4 t i;
let i = i lsr 4 in let i = i lsr 4 in
if i <> 0 then (bool t true; int t i) else (bool t false) if i <> 0 then (bool t true; int t i) else (bool t false)
...@@ -33,7 +47,7 @@ module Put = struct ...@@ -33,7 +47,7 @@ module Put = struct
let l = String.length s in let l = String.length s in
int t l; int t l;
for i = 0 to l - 1 do for i = 0 to l - 1 do
bits t (Char.code (s.[i])) 8 bits 8 t (Char.code (s.[i]))
done done
let rec list f t = function let rec list f t = function
...@@ -41,6 +55,7 @@ module Put = struct ...@@ -41,6 +55,7 @@ module Put = struct
| hd::tl -> bool t true; f t hd; list f t tl | 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 let pair f1 f2 t (x,y) = f1 t x; f2 t y
end end
...@@ -57,14 +72,14 @@ module Get = struct ...@@ -57,14 +72,14 @@ module Get = struct
else t.idx_bits <- succ t.idx_bits; else t.idx_bits <- succ t.idx_bits;
b b
let rec bits t nb = let rec bits nb t =
if nb = 0 then 0 if nb = 0 then 0
else if bool t else if bool t
then succ (bits t (pred nb) lsl 1) then succ (bits (pred nb) t lsl 1)
else bits t (pred nb) lsl 1 else bits (pred nb) t lsl 1
let rec int t = 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 if bool t then i + (int t) lsl 4
else i else i
...@@ -72,7 +87,7 @@ module Get = struct ...@@ -72,7 +87,7 @@ module Get = struct
let l = int t in let l = int t in
let s = String.create l in let s = String.create l in
for i = 0 to l - 1 do for i = 0 to l - 1 do
s.[i] <- Char.chr (bits t 8) s.[i] <- Char.chr (bits 8 t)
done; done;
s s
......
...@@ -3,12 +3,17 @@ module Put : sig ...@@ -3,12 +3,17 @@ module Put : sig
type 'a f = t -> 'a -> unit type 'a f = t -> 'a -> unit
val run: 'a f -> 'a -> string val run: 'a f -> 'a -> string
val bits: int -> int f
val int: int f val int: int f
val string: string f val string: string f
val bool: bool f val bool: bool f
val list: 'a f -> 'a list f val list: 'a f -> 'a list f
val pair: 'a f -> 'b f -> ('a * 'b) 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 end
module Get : sig module Get : sig
...@@ -16,6 +21,7 @@ module Get : sig ...@@ -16,6 +21,7 @@ module Get : sig
type 'a f = t -> 'a type 'a f = t -> 'a
val run : 'a f -> string -> 'a val run : 'a f -> string -> 'a
val bits: int -> int f
val int : int f val int : int f
val string: string f val string: string f
val bool: bool f val bool: bool f
......
...@@ -99,7 +99,6 @@ and ppat' = ...@@ -99,7 +99,6 @@ and ppat' =
| Arrow of ppat * ppat | Arrow of ppat * ppat
| Optional of ppat | Optional of ppat
| Record of bool * (label * ppat) list | Record of bool * (label * ppat) list
| Capture of id
| Constant of id * pconst | Constant of id * pconst
| Regexp of regexp * ppat | Regexp of regexp * ppat
(* regular expression, continuation: [ re ; cont ], e.g: [ re ; nil ] *) (* 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) ...@@ -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 gram = Grammar.gcreate (Wlexer.lexer Wlexer.token Wlexer.latin1_engine)
let true_atom = Atoms.mk_ascii "true" let true_atom = Atoms.V.mk_ascii "true"
let false_atom = Atoms.mk_ascii "false" let false_atom = Atoms.V.mk_ascii "false"
let true_type = Types.atom (Atoms.atom true_atom) let true_type = Types.atom (Atoms.atom true_atom)
let false_type = Types.atom (Atoms.atom false_atom) let false_type = Types.atom (Atoms.atom false_atom)
...@@ -77,13 +77,11 @@ let is_fun_decl = ...@@ -77,13 +77,11 @@ let is_fun_decl =
Grammar.Entry.of_parser gram "[is_fun_decl]" Grammar.Entry.of_parser gram "[is_fun_decl]"
(fun strm -> (fun strm ->
match Stream.npeek 3 strm with match Stream.npeek 3 strm with
| [ ("", "fun"); ("LIDENT", _); ("", "(") ] | [ ("", "fun"); ("IDENT", _); ("", "(") ]
| [ ("LIDENT", _) ; ("", "(") ; _ ] -> () | [ ("IDENT", _) ; ("", "(") ; _ ] -> ()
| _ -> raise Stream.Failure | _ -> raise Stream.Failure
) )
let dot_RE = Pcre.regexp "\\."
EXTEND EXTEND
GLOBAL: top_phrases prog expr pat regexp const; GLOBAL: top_phrases prog expr pat regexp const;
...@@ -95,7 +93,7 @@ EXTEND ...@@ -95,7 +93,7 @@ EXTEND
[ l = LIST0 [ p = phrase ; OPT ";;" -> p ]; EOI -> List.flatten l ] [ l = LIST0 [ p = phrase ; OPT ";;" -> p ]; EOI -> List.flatten l ]
]; ];
uident: [ [ x = UIDENT -> parse_ident x ] ]; uident: [ [ x = IDENT -> parse_ident x ] ];
phrase: [ phrase: [
[ (f,p,e) = let_binding -> [ (f,p,e) = let_binding ->
...@@ -104,8 +102,7 @@ EXTEND ...@@ -104,8 +102,7 @@ EXTEND
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"-> | (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
[ mk loc (EvalStatement (exp loc (Match (e1,[p,e2])))) ] [ mk loc (EvalStatement (exp loc (Match (e1,[p,e2])))) ]
| "type"; x = uident; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ] | "type"; x = uident; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
| "type"; x = LIDENT -> error loc "Type identifiers must be capitalized" | "schema"; name = IDENT; "="; uri = STRING2 ->
| "schema"; name = UIDENT; "="; uri = STRING2 ->
protect_op "schema"; protect_op "schema";
let schema_doc = Schema_xml.pxp_tree_of uri in let schema_doc = Schema_xml.pxp_tree_of uri in
let schema = Schema_parser.parse_schema schema_doc in let schema = Schema_parser.parse_schema schema_doc in
...@@ -150,11 +147,11 @@ EXTEND ...@@ -150,11 +147,11 @@ EXTEND
]; ];
debug_directive: [ debug_directive: [
[ LIDENT "filter"; t = pat; p = pat -> `Filter(t,p) [ IDENT "filter"; t = pat; p = pat -> `Filter(t,p)
| LIDENT "accept"; p = pat -> `Accept p | IDENT "accept"; p = pat -> `Accept p
| LIDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p) | IDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
| LIDENT "sample"; t = pat -> `Sample t | IDENT "sample"; t = pat -> `Sample t
| LIDENT "subtype"; t1 = pat; t2 = pat -> `Subtype (t1,t2) | IDENT "subtype"; t1 = pat; t2 = pat -> `Subtype (t1,t2)
] ]
]; ];
...@@ -186,10 +183,11 @@ EXTEND ...@@ -186,10 +183,11 @@ EXTEND
exp loc (Match (e, [p1,e1; p2,e2])) exp loc (Match (e, [p1,e1; p2,e2]))
| "transform"; e = SELF; "with"; b = branches -> | "transform"; e = SELF; "with"; b = branches ->
exp loc (Transform (e,b)) exp loc (Transform (e,b))
| "validate"; e = SELF; "with"; schema = UIDENT; "#"; | "validate"; e = SELF; "with"; schema = IDENT; "#";
typ = [ UIDENT | LIDENT | keyword ] -> typ = [ IDENT | keyword ] ->
exp loc (Validate (e, schema, typ)) exp loc (Validate (e, schema, typ))
| "fun"; (f,a,b) = fun_decl -> | "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 }) exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"-> | (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
exp loc (Match (e1,[p,e2])) exp loc (Match (e1,[p,e2]))
...@@ -218,7 +216,7 @@ EXTEND ...@@ -218,7 +216,7 @@ EXTEND
| |
[ e1 = expr; op = ["+" | "-" | "@" ]; e2 = expr -> [ e1 = expr; op = ["+" | "-" | "@" ]; e2 = expr ->
exp loc (Op (op,[e1;e2])) exp loc (Op (op,[e1;e2]))
| e = expr; "\\"; l = [LIDENT | UIDENT | keyword ] -> | e = expr; "\\"; l = [IDENT | keyword ] ->
exp loc (RemoveField (e, label l)) exp loc (RemoveField (e, label l))
] ]
| |
...@@ -235,28 +233,28 @@ EXTEND ...@@ -235,28 +233,28 @@ EXTEND
exp loc (Transform (e,[b])) exp loc (Transform (e,[b]))
] ]
| |
[ e = expr; "."; l = [LIDENT | UIDENT | keyword ] -> [ e = expr; "."; l = [IDENT | keyword ] ->
exp loc (Dot (e, label l)) exp loc (Dot (e, label l))
] ]
| |
[ op = [ LIDENT "flatten" [ op = [ IDENT "flatten"
| LIDENT "load_xml" | IDENT "load_xml"
| LIDENT "load_file" | LIDENT "load_file_utf8" | IDENT "load_file" | IDENT "load_file_utf8"
| LIDENT "getenv" | IDENT "getenv"
| LIDENT "load_html" | IDENT "load_html"
| LIDENT "print_xml" | LIDENT "print_xml_utf8" | IDENT "print_xml" | IDENT "print_xml_utf8"
| LIDENT "print" | IDENT "print"
| LIDENT "int_of" | IDENT "int_of"
| LIDENT "string_of" | IDENT "string_of"
| LIDENT "atom_of" | IDENT "atom_of"
| LIDENT "raise" | IDENT "raise"