Skip to content

GitLab

Commit 9386048d authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-10-01 22:59:28 by cvscast] Empty log message 

Original author: cvscast
Date: 2003-10-01 22:59:29+00:00
parent bff1a3d7
Hide whitespace changes
Inline Side-by-side
Showing with 510 additions and 80 deletions
Makefile.distrib
View file @ 9386048d
......@@ -95,6 +95,7 @@ OBJECTS = \
compile/lambda.cmo \
\
runtime/load_xml.cmo runtime/run_dispatch.cmo \
runtime/explain.cmo \
runtime/print_xml.cmo runtime/eval.cmo \
compile/compile.cmo \
compile/operators.cmo \
......
compile/lambda.ml
View file @ 9386048d
......@@ -6,7 +6,6 @@ type var_loc =
| Global of int
| Dummy
type expr =
| Var of var_loc
| Apply of bool * expr * expr
......@@ -22,10 +21,10 @@ type expr =
| Map of expr * branches
| Transform of expr * branches
| Xtrans of expr * branches
| Try of expr * branches
| Validate of expr * string * string
| RemoveField of expr * label
| Dot of expr * label
| Try of expr * branches
| UnaryOp of int * expr
| BinaryOp of int * expr * expr
| Ref of expr * Types.Node.t
......@@ -43,3 +42,209 @@ type let_decl = {
let_pat : Patterns.node;
let_expr : expr;
}
let nbits = 5
module Put = struct
let unary_op = ref (fun _ _ -> assert false; ())
let binary_op = ref (fun _ _ -> assert false; ())
open Serialize.Put
let var_loc s = function
| Stack i ->
bits 2 s 0;
int s i
| Global i ->
bits 2 s 1;
int s i
| Env i ->
bits 2 s 2;
int s i
| Dummy ->
bits 2 s 3
let rec expr s = function
| Var v ->
bits nbits s 0;
var_loc s v
| Apply (tail,e1,e2) ->
bits nbits s 1;
bool s tail;
expr s e1;
expr s e2
| Abstraction (slots,iface,brs) ->
bits nbits s 2;
array var_loc s slots;
list (pair Types.serialize Types.serialize) s iface;
branches s brs
| Const c ->
bits nbits s 3;
Types.Const.serialize s c
| Pair (e1,e2) ->
bits nbits s 4;
expr s e1;
expr s e2
| Xml (e1,e2,e3) ->
bits nbits s 5;
expr s e1;
expr s e2;
expr s e3
| Record r ->
bits nbits s 6;
LabelMap.serialize expr s r
| String (i,j,st,q) ->
bits nbits s 7;
U.serialize_sub s st i j;
expr s q
| Match (e,brs) ->
bits nbits s 8;
expr s e;
branches s brs
| Map (e,brs) ->
bits nbits s 9;
expr s e;
branches s brs
| Transform (e,brs) ->
bits nbits s 10;
expr s e;
branches s brs
| Xtrans (e,brs) ->
bits nbits s 11;
expr s e;
branches s brs
| Try (e,brs) ->
bits nbits s 12;
expr s e;
branches s brs
| Validate (e,sch,t) ->
assert false (* Need to store a pointer to the schema ... *)
| RemoveField (e,l) ->
bits nbits s 14;
expr s e;
LabelPool.serialize s l
| Dot (e,l) ->
bits nbits s 15;
expr s e;
LabelPool.serialize s l
| UnaryOp (op,e) ->
bits nbits s 16;
!unary_op s op;
expr s e
| BinaryOp (op,e1,e2) ->
bits nbits s 17;
!binary_op s op;
expr s e1;
expr s e2
| Ref (e,t) ->
bits nbits s 18;
expr s e;
Types.Node.serialize s t
and branches s brs =
list (pair Patterns.Node.serialize expr) s brs.brs;
bool s brs.brs_tail;
Types.serialize s brs.brs_input;
bool s brs.brs_accept_chars
end
module Get = struct
let unary_op = ref (fun _ -> assert false)
let binary_op = ref (fun _ -> assert false)
open Serialize.Get
let var_loc s =
match bits 2 s with
| 0 -> Stack (int s)
| 1 -> Global (int s)
| 2 -> Env (int s)
| 3 -> Dummy
| _ -> assert false
let rec expr s =
match bits nbits s with
| 0 -> Var (var_loc s)
| 1 ->
let recurs = bool s in
let e1 = expr s in
let e2 = expr s in
Apply (recurs,e1,e2)
| 2 ->
let slots = array var_loc s in
let iface = list (pair Types.deserialize Types.deserialize) s in
let brs = branches s in
Abstraction (slots,iface,brs)
| 3 -> Const (Types.Const.deserialize s)
| 4 ->
let e1 = expr s in
let e2 = expr s in
Pair (e1,e2)
| 5 ->
let e1 = expr s in
let e2 = expr s in
let e3 = expr s in
Xml (e1,e2,e3)
| 6 -> Record (LabelMap.deserialize expr s)
| 7 ->
let st = U.deserialize s in
let e = expr s in
String (U.start_index st, U.end_index st, st, e)
| 8 ->
let e = expr s in
let brs = branches s in
Match (e,brs)
| 9 ->
let e = expr s in
let brs = branches s in
Map (e,brs)
| 10 ->
let e = expr s in
let brs = branches s in
Transform (e,brs)
| 11 ->
let e = expr s in
let brs = branches s in
Xtrans (e,brs)
| 12 ->
let e = expr s in
let brs = branches s in
Try (e,brs)
| 13 -> assert false
| 14 ->
let e = expr s in
let l = LabelPool.deserialize s in
RemoveField (e,l)
| 15 ->
let e = expr s in
let l = LabelPool.deserialize s in
Dot (e,l)
| 16 ->
let op = !unary_op s in
let e = expr s in
UnaryOp (op,e)
| 17 ->
let op = !binary_op s in
let e1 = expr s in
let e2 = expr s in
BinaryOp (op,e1,e2)
| 18 ->
let e = expr s in
let t = Types.Node.deserialize s in
Ref (e,t)
| _ -> assert false
and branches s =
let brs = list (pair Patterns.Node.deserialize expr) s in
let tail = bool s in
let input = Types.deserialize s in
let accept_chars = bool s in
{ brs = brs; brs_tail = tail; brs_input = input;
brs_accept_chars = accept_chars;
brs_compiled = None
}
end
compile/operators.ml
View file @ 9386048d
......@@ -17,6 +17,8 @@ module Unary = struct
Typer.mk_unary_op := (fun name env -> mk (Proxy.instantiate name env));;
Typer.typ_unary_op := (fun i -> fst (Proxy.content (value i)));;
Eval.eval_unary_op := (fun i -> snd (Proxy.content (value i)));;
Lambda.Put.unary_op := serialize;;
Lambda.Get.unary_op := deserialize;;
end
module Binary = struct
......@@ -36,4 +38,6 @@ module Binary = struct
Typer.mk_binary_op := (fun name env -> mk (Proxy.instantiate name env));;
Typer.typ_binary_op := (fun i -> fst (Proxy.content (value i)));;
Eval.eval_binary_op := (fun i -> snd (Proxy.content (value i)));;
Lambda.Put.binary_op := serialize;;
Lambda.Get.binary_op := deserialize;;
end
depend
View file @ 9386048d
......@@ -126,12 +126,10 @@ typing/typer.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/builtin
schema/schema_types.cmx schema/schema_validator.cmx types/sequence.cmx \
misc/serialize.cmx misc/state.cmx misc/stats.cmx typing/typed.cmx \
types/types.cmx typing/typer.cmi
compile/lambda.cmo: misc/q_symbol.cmo types/ident.cmo types/patterns.cmi types/types.cmi
compile/lambda.cmx: misc/q_symbol.cmo types/ident.cmx types/patterns.cmx types/types.cmx
compile/compile.cmo: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo types/patterns.cmi \
typing/typed.cmo runtime/value.cmi
compile/compile.cmx: misc/q_symbol.cmo types/ident.cmx compile/lambda.cmx types/patterns.cmx \
typing/typed.cmx runtime/value.cmx
compile/lambda.cmo: misc/q_symbol.cmo types/ident.cmo types/patterns.cmi misc/serialize.cmi \
types/types.cmi
compile/lambda.cmx: misc/q_symbol.cmo types/ident.cmx types/patterns.cmx misc/serialize.cmx \
types/types.cmx
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 \
......@@ -142,24 +140,34 @@ runtime/run_dispatch.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc
runtime/run_dispatch.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/patterns.cmx types/types.cmx runtime/value.cmx \
runtime/run_dispatch.cmi
runtime/explain.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/ident.cmo types/patterns.cmi types/types.cmi runtime/value.cmi \
runtime/explain.cmi
runtime/explain.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/patterns.cmx types/types.cmx runtime/value.cmx \
runtime/explain.cmi
runtime/print_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi types/ident.cmo \
parser/location.cmi misc/ns.cmi types/sequence.cmi runtime/value.cmi
runtime/print_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx types/ident.cmx \
parser/location.cmx misc/ns.cmx types/sequence.cmx runtime/value.cmx
runtime/eval.cmo: misc/q_symbol.cmo types/builtin_defs.cmi types/ident.cmo types/patterns.cmi \
runtime/run_dispatch.cmi schema/schema_validator.cmi \
runtime/eval.cmo: misc/q_symbol.cmo types/builtin_defs.cmi types/ident.cmo compile/lambda.cmo \
types/patterns.cmi runtime/run_dispatch.cmi schema/schema_validator.cmi \
schema/schema_xml.cmi types/sequence.cmi typing/typed.cmo \
typing/typer.cmi types/types.cmi runtime/value.cmi runtime/eval.cmi
runtime/eval.cmx: misc/q_symbol.cmo types/builtin_defs.cmx types/ident.cmx types/patterns.cmx \
runtime/run_dispatch.cmx schema/schema_validator.cmx \
runtime/eval.cmx: misc/q_symbol.cmo types/builtin_defs.cmx types/ident.cmx compile/lambda.cmx \
types/patterns.cmx runtime/run_dispatch.cmx schema/schema_validator.cmx \
schema/schema_xml.cmx types/sequence.cmx typing/typed.cmx \
typing/typer.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi
compile/operators.cmo: misc/q_symbol.cmo misc/custom.cmo runtime/eval.cmi parser/location.cmi \
misc/pool.cmi typing/typer.cmi types/types.cmi runtime/value.cmi \
compile/operators.cmi
compile/operators.cmx: misc/q_symbol.cmo misc/custom.cmx runtime/eval.cmx parser/location.cmx \
misc/pool.cmx typing/typer.cmx types/types.cmx runtime/value.cmx \
compile/operators.cmi
compile/compile.cmo: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo types/patterns.cmi \
typing/typed.cmo types/types.cmi
compile/compile.cmx: misc/q_symbol.cmo types/ident.cmx compile/lambda.cmx types/patterns.cmx \
typing/typed.cmx types/types.cmx
compile/operators.cmo: misc/q_symbol.cmo misc/custom.cmo runtime/eval.cmi compile/lambda.cmo \
parser/location.cmi misc/pool.cmi typing/typer.cmi types/types.cmi \
runtime/value.cmi compile/operators.cmi
compile/operators.cmx: misc/q_symbol.cmo misc/custom.cmx runtime/eval.cmx compile/lambda.cmx \
parser/location.cmx misc/pool.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx compile/operators.cmi
types/builtin.cmo: misc/q_symbol.cmo types/atoms.cmi types/builtin_defs.cmi types/chars.cmi \
types/ident.cmo types/intervals.cmi runtime/load_xml.cmi \
parser/location.cmi misc/ns.cmi compile/operators.cmi \
......@@ -171,15 +179,15 @@ types/builtin.cmx: misc/q_symbol.cmo types/atoms.cmx types/builtin_defs.cmx type
runtime/print_xml.cmx types/sequence.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx types/builtin.cmi
driver/cduce.cmo: misc/q_symbol.cmo parser/ast.cmo types/builtin.cmi compile/compile.cmo \
runtime/eval.cmi types/ident.cmo parser/location.cmi misc/ns.cmi \
parser/parser.cmi types/patterns.cmi types/sample.cmi misc/state.cmi \
typing/typed.cmo typing/typer.cmi types/types.cmi parser/ulexer.cmi \
runtime/value.cmi driver/cduce.cmi
runtime/eval.cmi runtime/explain.cmi types/ident.cmo parser/location.cmi \
misc/ns.cmi parser/parser.cmi types/patterns.cmi types/sample.cmi \
misc/state.cmi typing/typed.cmo typing/typer.cmi types/types.cmi \
parser/ulexer.cmi runtime/value.cmi driver/cduce.cmi
driver/cduce.cmx: misc/q_symbol.cmo parser/ast.cmx types/builtin.cmx compile/compile.cmx \
runtime/eval.cmx types/ident.cmx parser/location.cmx misc/ns.cmx \
parser/parser.cmx types/patterns.cmx types/sample.cmx misc/state.cmx \
typing/typed.cmx typing/typer.cmx types/types.cmx parser/ulexer.cmx \
runtime/value.cmx driver/cduce.cmi
runtime/eval.cmx runtime/explain.cmx types/ident.cmx parser/location.cmx \
misc/ns.cmx parser/parser.cmx types/patterns.cmx types/sample.cmx \
misc/state.cmx typing/typed.cmx typing/typer.cmx types/types.cmx \
parser/ulexer.cmx runtime/value.cmx driver/cduce.cmi
driver/run.cmo: misc/q_symbol.cmo driver/cduce.cmi types/ident.cmo runtime/load_xml.cmi \
parser/location.cmi types/sequence.cmi misc/state.cmi misc/stats.cmi \
parser/ulexer.cmi runtime/value.cmi
......@@ -201,8 +209,8 @@ types/chars.cmi: misc/q_symbol.cmo misc/custom.cmo
types/atoms.cmi: misc/q_symbol.cmo misc/custom.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
types/patterns.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi types/ident.cmo \
types/types.cmi
types/patterns.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/custom.cmo \
types/ident.cmo types/types.cmi
types/sequence.cmi: misc/q_symbol.cmo types/atoms.cmi types/types.cmi
types/sample.cmi: misc/q_symbol.cmo types/types.cmi
types/builtin_defs.cmi: misc/q_symbol.cmo types/atoms.cmi types/ident.cmo types/types.cmi
......@@ -220,7 +228,9 @@ typing/typer.cmi: misc/q_symbol.cmo parser/ast.cmo misc/custom.cmo types/ident.c
types/types.cmi
runtime/load_xml.cmi: misc/q_symbol.cmo runtime/value.cmi
runtime/run_dispatch.cmi: misc/q_symbol.cmo types/patterns.cmi runtime/value.cmi
runtime/eval.cmi: misc/q_symbol.cmo types/ident.cmo typing/typed.cmo runtime/value.cmi
runtime/explain.cmi: misc/q_symbol.cmo types/types.cmi runtime/value.cmi
runtime/eval.cmi: misc/q_symbol.cmo types/ident.cmo compile/lambda.cmo typing/typed.cmo \
runtime/value.cmi
compile/operators.cmi: misc/q_symbol.cmo misc/custom.cmo parser/location.cmi misc/serialize.cmi \
typing/typer.cmi types/types.cmi runtime/value.cmi
types/builtin.cmi: misc/q_symbol.cmo typing/typer.cmi
......
driver/cduce.ml
View file @ 9386048d
......@@ -113,6 +113,49 @@ let rec print_exn ppf = function
(* raise exn *)
Format.fprintf ppf "%a@." print_protect (Printexc.to_string exn)
let insert_bindings ppf =
List.iter2
(fun (x,t) (y,v) ->
assert (x = y);
typing_env := Typer.enter_value x t !typing_env;
eval_env := Env.add x v !eval_env;
if not !quiet then
Format.fprintf ppf "val %a : @[@[%a@] =@ @[%a@]@]@."
U.print (Id.value x) print_norm t print_value v)
let display ppf =
List.iter
(fun x ->
let t = get_global_type x in
let v = get_global_value x in
if not !quiet then
Format.fprintf ppf "val %a : @[@[%a@] =@ @[%a@]@]@."
U.print (Id.value x) print_norm t print_value v)
let eval ppf e =
let (fv,e) = Typer.expr !typing_env e in
let t = Typer.type_check !typing_env e Types.any true in
Typer.report_unused_branches ();
if not !quiet then
Location.dump_loc ppf (e.Typed.exp_loc,`Full);
if !do_compile then
let e = Compile.compile !compile_env false e in
let v = Eval.L.eval e in
if not !quiet then
Format.fprintf ppf "- : @[@[%a@] =@ @[%a@]@]@."
print_norm t print_value v;
v
else
let v = Eval.eval !eval_env e in
if not !quiet then
Format.fprintf ppf "- : @[@[%a@] =@ @[%a@]@]@."
print_norm t print_value v;
v
let debug ppf = function
| `Subtype (t1,t2) ->
Format.fprintf ppf "[DEBUG:subtype]@.";
......@@ -145,25 +188,17 @@ let debug ppf = function
let t = Typer.typ !typing_env t
and pl = List.map (Typer.pat !typing_env) pl in
Patterns.Compile.debug_compile ppf t pl
| `Explain (t,e) ->
Format.fprintf ppf "[DEBUG:explain]@.";
let t = Typer.typ !typing_env t in
(match Explain.explain (Types.descr t) (eval ppf e) with
| Some p ->
Format.fprintf ppf "Explanation: @[%a@]@."
Explain.print_path p
| None ->
Format.fprintf ppf "Explanation: value has given type@.")
let insert_bindings ppf =
List.iter2
(fun (x,t) (y,v) ->
assert (x = y);
typing_env := Typer.enter_value x t !typing_env;
eval_env := Env.add x v !eval_env;
if not !quiet then
Format.fprintf ppf "val %a : @[@[%a@] =@ @[%a@]@]@."
U.print (Id.value x) print_norm t print_value v)
let display ppf =
List.iter
(fun x ->
let t = get_global_type x in
let v = get_global_value x in
if not !quiet then
Format.fprintf ppf "val %a : @[@[%a@] =@ @[%a@]@]@."
U.print (Id.value x) print_norm t print_value v)
let rec collect_funs ppf accu = function
| { descr = Ast.FunDecl e } :: rest ->
......@@ -193,6 +228,7 @@ let rec collect_types ppf accu = function
Typer.enter_types (Typer.type_defs !typing_env accu) !typing_env;
rest
let rec phrases ppf phs = match phs with
| { descr = Ast.FunDecl _ } :: _ ->
phrases ppf (collect_funs ppf [] phs)
......@@ -205,25 +241,7 @@ let rec phrases ppf phs = match phs with
typing_env := Typer.enter_ns pr ns !typing_env;
phrases ppf rest
| { descr = Ast.EvalStatement e } :: rest ->
let (fv,e) = Typer.expr !typing_env e in
let t = Typer.type_check !typing_env e Types.any true in
Typer.report_unused_branches ();
if not !quiet then
Location.dump_loc ppf (e.Typed.exp_loc,`Full);
if !do_compile then
let e = Compile.compile !compile_env false e in
let v = Eval.L.eval e in
if not !quiet then
Format.fprintf ppf "- : @[@[%a@] =@ @[%a@]@]@."
print_norm t print_value v;
else
(let v = Eval.eval !eval_env e in
if not !quiet then
Format.fprintf ppf "- : @[@[%a@] =@ @[%a@]@]@."
print_norm t print_value v );
ignore (eval ppf e);
phrases ppf rest
| { descr = Ast.LetDecl (p,e) } :: rest ->
let decl = Typer.let_decl !typing_env p e in
......
misc/serialize.ml
View file @ 9386048d
......@@ -68,6 +68,12 @@ module Put = struct
| [] -> bool t false
| hd::tl -> bool t true; f t hd; list f t tl
let array f t a =
int t (Array.length a);
for i = 0 to Array.length a - 1 do
f t a.(i)
done
let pair f1 f2 t (x,y) = f1 t x; f2 t y
end
......@@ -138,6 +144,16 @@ module Get = struct
if bool t then let hd = f t in hd::(list f t)
else []
let array f t =
let n = int t in
if n = 0 then [| |]
else
let a = Array.create n (f t) in
for i = 1 to Array.length a - 1 do
a.(i) <- f t
done;
a
let pair f1 f2 t =
let x = f1 t in
let y = f2 t in
......
misc/serialize.mli
View file @ 9386048d
......@@ -10,6 +10,7 @@ module Put : sig
val bool: bool f
val list: 'a f -> 'a list f
val array: 'a f -> 'a array f
val pair: 'a f -> 'b f -> ('a * 'b) f
type 'b property
......@@ -30,6 +31,7 @@ module Get : sig
val bool: bool f
val list: 'a f -> 'a list f
val array: 'a f -> 'a array f
val pair: 'a f -> 'b f -> ('a * 'b) f
type 'b property
......
parser/ast.ml
View file @ 9386048d
......@@ -23,6 +23,7 @@ and debug_directive =
| `Accept of ppat
| `Compile of ppat * ppat list
| `Subtype of ppat * ppat
| `Explain of ppat * pexpr
]
and toplevel_directive =
[ `Quit
......
parser/parser.ml
View file @ 9386048d
......@@ -92,15 +92,13 @@ EXTEND
[ l = LIST0 [ p = phrase ; OPT ";;" -> p ]; EOI -> List.flatten l ]
];
uident: [ [ x = IDENT -> ident x ] ];
phrase: [
[ (f,p,e) = let_binding ->
if f then [ mk loc (FunDecl e) ] else
[ mk loc (LetDecl (p,e)) ]
| (_,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 = IDENT; "="; t = pat -> [ mk loc (TypeDecl (ident x,t)) ]
| "schema"; name = IDENT; "="; uri = STRING2 ->
protect_op "schema";
let schema_doc = Schema_xml.pxp_tree_of uri in
......@@ -157,6 +155,7 @@ EXTEND
| 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)
| IDENT "explain"; t = pat; e = expr -> `Explain (t,e)
]
];
......@@ -288,7 +287,7 @@ EXTEND
| s = STRING2 ->
let s = U.mk s in
exp loc (String (U.start_index s, U.end_index s, s, cst_nil))
| a = uident -> exp loc (Var a)
| a = IDENT -> exp loc (Var (ident a))
| "!"; e = expr ->
exp loc (Apply (Dot (e, U.mk "get"), cst_nil))
| i = INT -> exp loc (Integer (Intervals.V.mk i))
......@@ -398,9 +397,16 @@ EXTEND
| x = regexp; "+?" -> Seq (x, WeakStar x)
| x = regexp; "?" -> Alt (x, Epsilon)
| x = regexp; "??" -> Alt (Epsilon, x) ]
| [ "("; x = regexp; ")" -> x
| "("; a = uident; ":="; c = expr; ")" ->
Elem (mk loc (Constant ((a,c))))
| [ "("; x = LIST1 regexp SEP ","; ")" ->
let x =
List.map
(function
| Elem x -> x
| _ -> error loc "Mixing regular expressions and products")
x in
Elem (multi_prod loc x)
| "("; a = IDENT; ":="; c = expr; ")" ->
Elem (mk loc (Constant ((ident a,c))))
| IDENT "PCDATA" -> string_regexp
| i = STRING1; "--"; j = STRING1 ->
let i = Chars.V.mk_int (parse_char loc i)
......@@ -420,7 +426,7 @@ EXTEND
pat: [
[ x = pat; IDENT "where";
b = LIST1 [ a = uident; "="; y = pat -> (a,y) ] SEP "and"
b = LIST1 [ a = IDENT; "="; y = pat -> (ident 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)) ]
......@@ -448,8 +454,8 @@ EXTEND
| _ -> assert false
in
mk loc (SchemaVar (kind, schema, typ))
| a = uident ->
mk loc (PatVar a)
| a = IDENT ->
mk loc (PatVar (ident a))
| i = INT ; "--"; j = INT ->