parser.ml 21.2 KB
Newer Older
1
2
#load "pa_extend.cmo";;

3
4
open Location
open Ast
5
open Ident
6
open Printf
7

8
(*
9
let ()  = Grammar.error_verbose := true
10
*)
11

12
13
14
15
16
17
let tloc (i,j) = (i.Lexing.pos_cnum,j.Lexing.pos_cnum)
let nopos = (Lexing.dummy_pos, Lexing.dummy_pos)


let mk loc x = Location.mk (tloc loc) x

18
19
exception Error of string
let error (i,j) s = Location.raise_loc i j (Error s)
20
let error loc s = error (tloc loc) s
21

22
let gram    = Grammar.gcreate Ulexer.lex
23

24
25
26
27
28
29
30
31
32
33
34
let id_dummy = U.mk "$$$"

let ident s =
  let b = Buffer.create (String.length s) in
  let rec aux i =
    if (i = String.length s) then Buffer.contents b
    else match s.[i] with
      | '\\' -> assert (s.[i+1] = '.'); Buffer.add_char b '.'; aux (i+2)
      | c -> Buffer.add_char b c; aux (i+1)
  in
  aux 0
35

36
37
let label s = U.mk (ident s)
let ident s = U.mk (ident s)
38

39
let prog    = Grammar.Entry.create gram "prog"
40
let top_phrases   = Grammar.Entry.create gram "toplevel phrases"
41
42
43
let expr    = Grammar.Entry.create gram "expression"
let pat     = Grammar.Entry.create gram "type/pattern expression"
let regexp  = Grammar.Entry.create gram "type/pattern regexp"
44
let keyword = Grammar.Entry.create gram "keyword"
45
		
46
47
let lop pos = loc_of_pos (tloc pos)
let exp pos e = LocatedExpr (lop pos,e)
48

49
50
51
52
53
let rec multi_prod loc = function
  | [ x ] -> x
  | x :: l -> mk loc (Prod (x, multi_prod loc l))
  | [] -> assert false
      
54
let rec tuple = function
55
  | [ x ] -> x
56
  | x :: l -> Pair (x, tuple l)
57
  | [] -> assert false
58
59

let tuple_queue = 
60
  List.fold_right (fun x q -> Pair (x, q))
61
62


63
let char = mknoloc (Internal (Types.char Chars.any))
64
let string_regexp = Star (Elem char)
65
	       
66
let seq_of_string s =
67
68
  let s = Encodings.Utf8.mk s in
  let rec aux i j =
69
70
    if Encodings.Utf8.equal_index i j then []
    else let (c,i) = Encodings.Utf8.next s i in c :: (aux i j)
71
  in
72
  aux (Encodings.Utf8.start_index s) (Encodings.Utf8.end_index s)
73

74

75
let parse_char loc s =
76
77
  match seq_of_string s with
    | [ c ] -> c
78
    | _ -> error loc "Character litteral must have length 1"
79

80
81
let include_stack = ref []

82
83
84
85
let protect_exn f g =
  try let x = f () in g (); x
  with e -> g (); raise e

86
87
88
89
let localize_exn f = 
  try f ()
  with
  | Stdpp.Exc_located (_, (Location _ as e)) -> raise e
90
91
(*  | Stdpp.Exc_located ((i,j), e) -> raise_loc i j e *)
  | Stdpp.Exc_located ((i,j), e) -> raise_loc i.Lexing.pos_cnum j.Lexing.pos_cnum e
92

93
94
95
96
let is_fun_decl =
   Grammar.Entry.of_parser gram "[is_fun_decl]"
     (fun strm ->
       match Stream.npeek 3 strm with
97
98
	 | [ ("", "fun"); ("IDENT", _); ("", "(") ]
	 | [ ("IDENT", _) ; ("", "(") ; _ ] -> ()
99
100
101
	 | _ -> raise Stream.Failure
     )

102
103
104
105
106
107
108
109
110
let is_capture =
   Grammar.Entry.of_parser gram "[is_capture]"
     (fun strm ->
       match Stream.npeek 2 strm with
	 | [ ("IDENT", _) ; ("", "::") ; _ ] -> ()
	 | _ -> raise Stream.Failure
     )


111
112
113
114
115
let if_then_else cond e1 e2 = Match (cond, [pat_true,e1; pat_false,e2])
 
let logical_and e1 e2 = if_then_else e1 e2 cst_false
let logical_or e1 e2 = if_then_else e1 cst_true e2
let logical_not e = if_then_else e cst_false cst_true
116

117
let apply_op2_noloc op e1 e2 = Apply (Apply (Var (ident op), e1), e2)
118
let apply_op2 loc op e1 e2 = exp loc (apply_op2_noloc op e1 e2)
119
 
120
121
122
123
124
let set_ref e1 e2 = Apply (Dot (e1, U.mk "set", []), e2)
let get_ref e = Apply (Dot (e, U.mk "get", []), cst_nil)
let let_in e1 p e2 =  Match (e1, [p,e2])
let seq e1 e2 = let_in e1 pat_nil e2
let concat e1 e2 = apply_op2_noloc "@" e1 e2
125

126
EXTEND
127
  GLOBAL: top_phrases prog expr pat regexp keyword;
128
129

  top_phrases: [
130
    [ l = LIST0 phrase; ";;" -> List.flatten l  ]
131
  ];
132
133

  prog: [
134
    [ l = LIST0 [ p = phrase ; OPT ";;" -> p ]; EOI -> List.flatten l ]
135
136
137
  ];

  phrase: [
138
139
140
141
    [ (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"->
142
        [ mk loc (EvalStatement (exp loc (let_in e1 p e2))) ]
143
    | "type"; x = located_ident; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
144
145
    | "using"; name = IDENT; "="; cu = [ IDENT | STRING2 ] ->
	[ mk loc (Using (U.mk name, U.mk cu)) ]
146
    | "schema"; name = IDENT; "="; uri = STRING2 ->
147
	protect_op "schema";
148
        [ mk loc (SchemaDecl (U.mk name, uri)) ]
149
150
151
152
153
154
155
156
157
158
159
160
    | n = namespace_binding ->
	let d = match n with
	    | `Prefix (name,ns) ->  Namespace (name, ns)
	    | `Keep b -> KeepNs b in
	[ mk loc d ]
    | n = namespace_binding; "in"; e2 = expr LEVEL "top" ->
	let e = 
	  match n with
	    | `Prefix (name,ns) -> NamespaceIn (name, ns, e2)
	    | `Keep b -> KeepNsIn (b,e2)
	in
	[ mk loc (EvalStatement (exp loc e)) ]
161
    | "debug"; d = debug_directive -> [ mk loc (Directive (`Debug d)) ]
162
163
164
165
166
167
168
169
    | "#"; IDENT "verbose" -> [ mk loc (Directive `Verbose) ]
    | "#"; IDENT "silent" -> [ mk loc (Directive `Silent) ]
    | "#"; IDENT "utf8" -> Ulexer.enc := Ulexing.Utf8; [ ]
    | "#"; IDENT "latin1" -> Ulexer.enc := Ulexing.Latin1; [ ]
    | "#"; IDENT "ascii" -> Ulexer.enc := Ulexing.Ascii; [ ]
    | "#"; IDENT "quit" -> [ mk loc (Directive `Quit) ]
    | "#"; IDENT "env" -> [ mk loc (Directive `Env) ]
    | "#"; IDENT "print_type"; t = pat ->
170
        [ mk loc (Directive (`Print_type t)) ]
171
172
173
    | "#"; IDENT "dump_value"; e = expr -> [ mk loc (Directive (`Dump e)) ]
    | "#"; IDENT "reinit_ns" -> [ mk loc (Directive `Reinit_ns) ]
    | "#"; IDENT "help" -> [ mk loc (Directive `Help) ]
174
    | "#"; IDENT "builtins" -> [ mk loc (Directive `Builtins) ]
175
    | "include"; s = STRING2 ->
176
177
178
179
	let s = 
	  if Filename.is_relative s 
	  then Filename.concat (Location.current_dir ()) s
	  else s in
180
181
	protect_op "File inclusion";
	(* avoid looping; should issue an error ? *)
182
183
	(* it is possible to have looping with x/../x/../x/.. ....
	   Need to canonicalize filename *)
184
185
186
187
	if List.mem s !include_stack then [] 
	else (
	  include_stack := s :: !include_stack;
	  Location.push_source (`File s);
188
189
	  let saved_enc = !Ulexer.enc in
	  Ulexer.enc := Ulexing.Latin1;
190
191
192
	  protect_exn
	    (fun () ->
	       let chan = open_in s in
193
194
195
	       protect_exn
		 (fun () ->
		    let input = Stream.of_channel chan in
196
		    localize_exn (fun () -> Grammar.Entry.parse prog input))
197
		 (fun () -> close_in chan))
198
	    (fun () ->
199
	       Ulexer.enc := saved_enc;
200
201
	       Location.pop_source ();
	       include_stack := List.tl !include_stack)
202
	)
203
    ] | 
204
    [ e = expr -> [ mk loc (EvalStatement e) ]
205
206
207
208
    ]
  ];

  debug_directive: [
209
210
211
212
213
    [ 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)
214
    | IDENT "single"; t = pat -> `Single t
215
    ]
216
  ];
217

218
219
220
221
222
  keyword: [
    [ a = 
	[ "map" | "match" | "with" | "try" | "xtransform"
	| "if" | "then"	| "else"
	| "transform" | "fun" | "in"
223
	| "let" | "type" | "debug" | "include"
224
        | "and" | "or" | "validate" | "schema" | "namespace" | "ref" | "alias"
225
	| "not" | "as" | "where" | "select" | "from"
226
227
228
229
230
	]
	-> a
    ]
  ];

231
232
  expr: [
    "top" RIGHTA
233
234
    [ "match"; e = SELF; "with"; b = branches -> 
	exp loc (Match (e,b))
235
    | "try"; e = SELF; "with"; b = branches -> 
236
	exp loc (Try (e,b))
237
238
239
240
    | "map"; e = SELF; "with"; b = branches -> 
	exp loc (Map (e,b))
    | "xtransform"; e = SELF; "with"; b = branches -> 
	exp loc (Xtrans (e,b))
241
    | "if"; e = SELF; "then"; e1 = SELF; "else"; e2 = SELF ->
242
	exp loc (if_then_else e e1 e2)
243
    | "transform"; e = SELF; "with"; b = branches -> 
244
	exp loc (Transform (e,b))
245
246
    | "validate"; e = SELF; "with"; (schema, typ) = schema_ref ->
        exp loc (Validate (e, schema, typ))
247
248
249
250
    | "select"; e = SELF; "from"; 
      l = LIST1 [ x = pat ; "in"; e = expr -> (x,e)] SEP "," ;
      cond = [ "where"; c = LIST1 [ expr ] SEP "and" -> c 
	     | -> [] ] -> exp loc (SelectFW (e,l,cond)) 
251
    | "fun"; (f,a,b) = fun_decl ->
252
	exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
253
    | (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
254
        exp loc (let_in e1 p e2)
255
256
257
258
    | n = namespace_binding; "in"; e2 = expr LEVEL "top" ->
	(match n with
	   | `Prefix (name,ns) -> exp loc (NamespaceIn (name, ns, e2))
	   | `Keep f -> exp loc (KeepNsIn (f,e2)))
259
    | e = expr; ":"; p = pat ->
260
	exp loc (Forget (e,p))
261
262
    | e = expr; ":"; "?"; p = pat ->
	exp loc (Check (e,p))
263
    | e1 = expr; ";"; e2 = expr ->
264
	exp loc (seq e1 e2) 
265
266
    | "ref"; p = pat; e = expr ->
	exp loc (Ref (e,p))
267
    | "not"; e = expr -> exp loc (logical_not e)
268
269
    ]
    |
270
    [ e1 = expr; ":="; e2 = expr -> exp loc (set_ref e1 e2)
271
    ]
272
273
274
275
276
277
    | 
    [ e1 = expr; op = ["=" | "<=" | "<<" | ">>" | ">=" ]; e2 = expr -> 
	let op = match op with
	  | "<<" -> "<"
	  | ">>" -> ">"
	  | s -> s in
278
	apply_op2 loc op e1 e2
279
280
    ]

281
    | 
282
    [ e1 = expr; op = ["+" | "-" | "@" ]; e2 = expr -> apply_op2 loc op e1 e2
283
    | e1 = expr; ["||" | "or"]; e2 = expr -> exp loc (logical_or e1 e2)
284
    | e = expr; "\\"; l = [IDENT | keyword ] -> 
285
	exp loc (RemoveField (e, label l)) 
286
287
    ]
    |
288
    [ e1 = expr; op = ["*"]; e2 = expr -> apply_op2 loc op e1 e2
289
    | e1 = expr; "&&"; e2 = expr -> exp loc (logical_and e1 e2)
290
    | e = expr; op = "/"; p = pat LEVEL "simple" ->
291
	(* transform e with <(Atom)>[($$$::t|_)*] -> [$$$] *)
292
293
	let tag = mk loc (Internal (Types.atom (Atoms.any))) in
	let att = mk loc (Internal Types.Record.any) in
294
	let any = mk loc (Internal Types.any) in
295
	let re = Star(Alt(SeqCapture(noloc,id_dummy,Elem p), Elem any)) in
296
	let ct = mk loc (Regexp re) in
297
        let p = mk loc (XmlT (tag, multi_prod loc [att;ct])) in
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
	exp loc (Transform (e,[p, Var id_dummy]))
    | e = expr; "/@"; a = [IDENT|keyword] ->
	(* transform e with <(Atom) {a=$$$}>_ -> [$$$] *)
        let tag = mk loc (Internal (Types.atom Atoms.any)) in
        let any = mk loc (Internal Types.any) in
        let att = mk loc (Record
			    (true, [(label a,
				     (mk loc (PatVar (None,id_dummy)),
				      None))])) in
        let p = mk loc (XmlT (tag, multi_prod loc [att;any])) in
        let t = (p, Pair (Var id_dummy,cst_nil)) in
        exp loc (Transform (e,[t]))
     | e = expr; "//" ; p = pat ->
	 (*
	   let $stack=ref [p*] [] in
	   let _ = xtransform e with $$$ & p -> $stack := !$stack @ $$$ in
	   !stack;; 
	 *)
	 let stk = U.mk "$stack" in
	 let assign = 
	   set_ref 
	     (Var stk)
	     (concat (get_ref (Var stk)) (Pair (Var id_dummy,cst_nil))) in
	 let capt = mk loc (And (mk loc (PatVar (None,U.mk "$$$")),p)) in
	 let xt = Xtrans (e,[capt,assign]) in
	 let rf = Ref (cst_nil, mk loc (Regexp (Star(Elem p)))) in
	 let body = 
	   let_in rf (mk loc (PatVar (None,stk)))
	     (let_in xt (mk loc (Internal Types.any)) (get_ref (Var stk)))
	 in
	 exp loc body
329
    ]
330
331
332
    | [ 
      e1 = SELF; IDENT "div"; e2 = expr -> apply_op2 loc "/" e1 e2
    | e1 = SELF; IDENT "mod"; e2 = expr -> apply_op2 loc "mod" e1 e2
333
    | e1 = SELF; e2 = expr -> exp loc (Apply (e1,e2))
334
335
    ]

336
    | "no_appl" 
337
338
339
340
341
342
343

    [ e = expr;  "."; l = [IDENT | keyword ];
      tyargs = [ "with"; "{"; pl = LIST0 pat; "}" -> pl | -> [] ]
      -> 
	exp loc (Dot (e, label l,tyargs)) 
    ]  
    | [ 
344
      "("; l = LIST1 expr SEP ","; ")" -> exp loc (tuple l)
345
    | "[";  l = LIST0 seq_elem; e = OPT [ ";"; e = expr -> e ]; 
346
      loc_end = ["]" -> loc] ->
347
	let e = match e with Some e -> e | None -> cst_nil in
348
349
        let e = exp loc_end e in
        let (_,loc_end) = loc_end in
350
351
352
	let l = List.fold_right 
		  (fun x q ->
		     match x with
353
		       | `String (loc,i,j,s) -> exp loc (String (i,j,s,q))
354
		       | `Elems ((loc,_),x) -> exp (loc,loc_end) (Pair(x,q))
355
		       | `Explode x -> concat x q
356
357
358
		  ) l e
	in
	exp loc l
359
    | "<"; t = [ "("; e = expr; ")" -> e
360
	       | a = tag -> exp loc a
361
	       ];
362
	a = expr_attrib_spec; ">"; c = expr ->
363
	  exp loc (Xml (t, Pair (a,c)))
364
    | "{"; r = expr_record_spec; "}" -> r
365
    | s = STRING2 ->
366
	let s = U.mk s in
367
	exp loc (String (U.start_index s, U.end_index s, s, cst_nil))
368
    | a = IDENT -> exp loc (Var (ident a))
369
    | "!"; e = expr -> exp loc (get_ref e)
370
371
372
    | i = INT -> exp loc (Integer (Intervals.V.mk i))
    | "`"; a = tag -> a
    | c = char -> exp loc (Char c)
373
374
375
    ]

  ];
376

377
  tag: [ [ a = [ IDENT | keyword ] -> exp loc (Atom (ident a)) ] ];
378
379

  tag_type: [
380
    [ "_" ->  mk loc (Internal (Types.atom Atoms.any))
381
382
    | a = [ IDENT | keyword ] -> mk loc (Cst (Atom (ident a)))
    | t = ANY_IN_NS -> mk loc (NsT (ident t)) 
383
384
385
    ]
  ];

386
  seq_elem: [
387
    [ x = STRING1 -> 
388
	let s = U.mk x in
389
	`String (loc, U.start_index s, U.end_index s, s)
390
    | e = expr LEVEL "no_appl" -> `Elems (loc,e)
391
    | "!"; e = expr LEVEL "no_appl" -> `Explode e
392
393
    ]
  ];
394
395
	
  namespace_binding: [
396
397
398
399
400
    [ "namespace"; r = [
	[ name = 
	    [ name = [ IDENT | keyword ]; "=" -> ident name
	    | -> U.mk "" ];
	  uri = STRING2 ->
401
	    let ns = Ns.Uri.mk (ident uri) in
402
403
404
405
	    `Prefix (name,ns)
	| IDENT "on" -> `Keep true
	| IDENT "off" -> `Keep false ]
      ] -> r ]
406
407
408
  ];

  
409
  let_binding: [
410
411
    [ "let"; is_fun_decl; OPT "fun"; (f,a,b) = fun_decl ->
	let f = match f with Some x -> x | None -> assert false in
412
	let p = mk loc (PatVar (None, snd f)) in
413
	let abst = { fun_name = Some f; fun_iface = a; fun_body = b } in
414
        let e = exp loc (Abstraction abst) in
415
        (true,p,e)
416
417
    | "let"; p = pat; "="; e = expr -> (false,p,e)
    | "let"; p = pat; ":"; t = pat; "="; e = expr -> (false,p, Forget (e,t))
418
419
    | "let"; p = pat; ":"; "?"; t = pat; "="; e = expr -> 
	(false,p, Check (e,t))
420
421
422
    ] 
  ];

423
 fun_decl_after_lparen: [
424
(* need an hack to do this, because both productions would
425
   match   [ OPT IDENT; "("; pat ] .... *)
426
427
428
429
430
431
   [ p1 = pat LEVEL "no_arrow";
     res = [ "->"; p2 = pat;
	     a = [ ";"; a = LIST0 arrow SEP ";" -> a | -> [] ];
	     ")"; b = branches -> `Classic (p2,a,b)
	   | ":"; targ1 = pat;
	     args = LIST0 [ ","; arg = pat; ":"; targ = pat -> (arg,targ) ]; 
432
433
434
435
436
437
438
439
440
	     ")";
	     others = LIST0 
			[ "(";
			  args = 
			    LIST1 
			      [ arg = pat; ":"; targ = pat -> (arg,targ) ]
			      SEP ",";
			  ")" -> args ];
	     ":"; tres = pat ; 
441
	     "="; body = expr ->
442
	       `Compact (targ1,args,others,tres,body)
443
444
445
	   ] ->
       match res with
	 | `Classic (p2,a,b) -> (p1,p2)::a,b
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
	 | `Compact (targ1,args,others,tres,body) ->
	     let mkfun args =
	       multi_prod nopos (List.map snd args),
	       multi_prod nopos (List.map fst args)
	     in
	     let (tres,body) =
	       List.fold_right
		 (fun args (tres,body) ->
		    let (targ,arg) = mkfun args in
		    let e = Abstraction 
			      { fun_name = None; fun_iface = [targ,tres]; 
				fun_body = [arg,body] } in
		    let t = mknoloc (Arrow (targ,tres)) in
		    (t,e)
		 )
		 others (tres,body) in
	     let (targ,arg) = mkfun ((p1,targ1) :: args) in
	     [(targ,tres)],[(arg,body)]
	      ] ];
465
466
467


 fun_decl: [
468
   [ f = OPT located_ident; "("; (a,b) = fun_decl_after_lparen ->
469
       (f,a,b)
470
   ]
471
472
 ];

473
 arrow: [
474
    [ t1 = pat LEVEL "no_arrow"; "->"; t2 = pat -> (t1,t2)]
475
476
477
  ];

  branches: [
478
    [ OPT "|"; l = LIST1 branch SEP "|" -> l ]
479
480
481
  ];

  branch: [
482
    [ p = pat LEVEL "no_arrow"; "->"; e = expr -> (p,e) ]
483
484
485
486
  ];

	  
  regexp: [ 
487
488
489
490
491
    [ x = regexp; "|"; y = regexp -> 
	match (x,y) with
	  | Elem x, Elem y -> Elem (mk loc (Or (x,y)))
	  | _ -> Alt (x,y) 
    ]
492
  | [ x = regexp; y = regexp -> Seq (x,y) ]
493
494
495
496
497
  | [ x = regexp; "&"; y = regexp ->
	match (x,y) with
	  | Elem x, Elem y -> Elem (mk loc (And (x,y)))
	  | _ -> error loc "Conjunction not allowed in regular expression"
    ]
498
  | [ a = IDENT; "::"; x = regexp -> SeqCapture (lop loc,ident a,x) ] 
499
500
501
502
  | [ x = regexp; "*" -> Star x
    | x = regexp; "*?" -> WeakStar x
    | x = regexp; "+" -> Seq (x, Star x)
    | x = regexp; "+?" -> Seq (x, WeakStar x)
503
    | x = regexp; "?" ->  Alt (x, Epsilon)
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
    | x = regexp; "??" -> Alt (Epsilon, x) 
    | x = regexp; "**"; i = INT ->
	let rec aux i accu =
	  if (i = 0) then accu
	  else aux (pred i) (Seq (x, accu))
	in
	let i = 
	  try 
	    let i = int_of_string i in
	    if (i > 1024) then raise Exit else i
	      (* We cannot handle type that huge... *)
	  with Failure _ | Exit -> error loc "Repetition number too large"
	in
	if (i <= 0) then 
	  error loc "Repetition number must be a positive integer";
	aux i Epsilon
    ]
521
  | [ "("; x = LIST1 regexp SEP ","; ")" ->
522
523
524
525
526
527
528
529
530
531
532
	(match x with
	  | [ x ] -> x
	  | _ ->
	      let x = 
		List.map 
		  (function
		     | Elem x -> x
		     | _ -> error loc 
			 "Mixing regular expressions and products")
		  x in
	      Elem (multi_prod loc x))
533
534
    | "("; a = IDENT; ":="; c = expr; ")" -> 
	Elem (mk loc (Constant ((ident a,c))))
535
    | "/"; p = pat LEVEL "simple" -> Guard p
536
    | IDENT "PCDATA" -> string_regexp
537
    | i = STRING1; "--"; j = STRING1 ->
538
539
	let i = Chars.V.mk_int (parse_char loc i)
	and j = Chars.V.mk_int (parse_char loc j) in
540
        Elem (mk loc (Internal (Types.char (Chars.char_class i j))))
541
    |  s = STRING1 ->
542
	List.fold_right
543
	  (fun c accu -> 
544
	     let c = Chars.V.mk_int c in
545
	     let c = Chars.atom c in
546
547
	     Seq (Elem (mknoloc (Internal (Types.char c))), accu))
	  (seq_of_string s)
548
549
	  Epsilon ]
    | [ e = pat LEVEL "simple" -> Elem e
550
551
552
    ]
  ];

553
  schema_ref: [
554
    [ schema = IDENT; "."; typ = [ IDENT | keyword ] -> (U.mk schema, ident typ)
555
556
557
    ]
  ];

558
  located_ident: [ [ a = [IDENT|keyword] -> (lop loc,ident a) ] ];
559

560
  pat: [ 
561
      [ x = pat; "where"; 
562
563
        b = LIST1 [ (la,a) = located_ident; "="; y = pat -> 
		      (la,a,y) ] SEP "and"
564
            -> mk loc (Recurs (x,b)) ]
565
    | RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y))
566
567
             | x = pat; "@"; y = pat -> mk loc (Concat (x,y))
             | x = pat; "+"; y = pat -> mk loc (Merge (x,y)) ]
568
    | "no_arrow" [ x = pat; "|"; y = pat -> mk loc (Or (x,y)) ] 
569
    | "simple" [ x = pat; "&"; y = pat -> mk loc (And (x,y)) 
570
	       | x = pat; "\\"; y = pat -> mk loc (Diff (x,y)) ]
571
    | 
572
      [ "{"; r = record_spec; "}" -> r
573
574
      | "ref"; p = pat ->
	  let get_fun = mk loc (Arrow (pat_nil, p)) 
575
576
577
	  and set_fun = mk loc (Arrow (p, pat_nil))in
	  let fields = 
	    [ label "get", (get_fun, None); label "set", (set_fun, None) ] in
578
	  mk loc (Record (false, fields))
579
      | "_" -> mk loc (Internal Types.any)
580
      | "("; a = IDENT; ":="; c = expr; ")" -> 
581
	  mk loc (Constant (ident a,c))
582
583
      | "!"; a = IDENT ->
	  mk loc (Internal (Types.abstract (Types.Abstract.atom a)))
584
      | cu = OPT [ cu = IDENT; "." -> U.mk cu ]; a = [ IDENT | keyword ] ->
585
	  mk loc (PatVar (cu, ident a))
586
      | i = INT ; "--"; j = INT -> 
587
588
          let i =  Intervals.V.mk i 
	  and j =  Intervals.V.mk j in
589
590
          mk loc (Internal (Types.interval (Intervals.bounded i j)))
      | i = INT -> 
591
          let i =  Intervals.V.mk i  in
592
          mk loc (Internal (Types.interval (Intervals.atom i)))
593
      | "*"; "--"; j = INT ->
594
	  let j =  Intervals.V.mk j in
595
          mk loc (Internal (Types.interval (Intervals.left j)))
596
      | i = INT; "--"; "*" ->
597
	  let i = Intervals.V.mk i in
598
          mk loc (Internal (Types.interval (Intervals.right i)))
599
600
      | i = char ->
          mk loc (Internal (Types.char (Chars.char_class i i)))
601
      | i = char ; "--"; j = char ->
602
          mk loc (Internal (Types.char (Chars.char_class i j)))
603
      | "`"; c = tag_type -> c
604
605
      | "("; l = LIST1 pat SEP ","; ")" -> multi_prod loc l
      | "["; r = [ r = regexp -> r | -> Epsilon ];
606
607
608
609
610
611
612
613
614
615
             q = [ ";"; q = pat -> Some q
                 | -> None ]; 
             "]" -> 
	       let r = match q with
		 | Some q -> 	
		     let any = mk loc (Internal (Types.any)) in
		     Seq(r,Seq(Guard q, Star (Elem any)))
		 | None -> r
	       in
	       mk loc (Regexp r)
616
      | "<"; t =
617
618
            [ x = tag_type -> x
            | "("; t = pat; ")" -> t ];
619
	a = attrib_spec; ">"; c = pat ->
620
          mk loc (XmlT (t, multi_prod loc [a;c]))
621
      | s = STRING2 ->
622
623
624
625
626
627
	  let s = 
	    List.map 
	      (fun c -> 
		 mknoloc (Internal
			     (Types.char
				(Chars.atom
628
				   (Chars.V.mk_int c))))) 
629
630
	      (seq_of_string s) in
	  let s = s @ [mknoloc (Internal (Sequence.nil_type))] in
631
	  multi_prod loc s
632
633
634
635
      ]
    
  ];

636
637
  or_else : [ [ OPT [ "else"; y = pat -> y ]  ] ];

638
  opt_field_pat: [ [ OPT [ "=";
639
                  o = [ "?" -> true | -> false]; 
640
641
642
                  x = pat;  y = or_else -> (o,x,y) ] ] ];

  record_spec:
643
    [ [ r = LIST0 [ l = [IDENT | keyword ]; f = opt_field_pat; OPT ";" ->
644
645
		      let (o,x,y) =
			match f with
646
			  | None -> (false, mknoloc (PatVar (None,ident l)), None)
647
648
649
650
			  | Some z -> z
		      in
		      let x = if o then mk loc (Optional x) else x in
		      (label l, (x,y))
651
652
                  ]; op = [ ".." -> true | -> false ] ->
	  mk loc (Record (op,r))
653
654
      ] ];
  
655
656
  char:
    [ 
657
      [ c = STRING1 -> Chars.V.mk_int (parse_char loc c) ]
658
659
660
    ];
     

661
662
663
664
  attrib_spec: [
    [ r = record_spec -> r
    | "("; t = pat; ")" -> t 
    ] ];
665

666
667
  opt_field_expr: [ [ OPT [ "="; x = expr LEVEL "no_appl" -> x ] ] ];

668
  expr_record_spec:
669
    [ [ r = LIST0
670
	      [ l = [IDENT | keyword ]; 
671
		x = opt_field_expr; OPT ";" ->
672
		  let x = match x with Some x -> x | None ->  Var (ident l) in
673
		  (label l,x) ] 
674
	  ->
675
	  exp loc (RecordLitt r)
676
      ] ];
677

678
679
680
681
  expr_attrib_spec: [
    [ e = expr_record_spec -> e
    | "("; e = expr; ")" -> e 
    ] ];
682
683
END

684
685
686
module Hook = struct
  let expr = expr
  let pat = pat
687
  let keyword = keyword
688
689
end

690
let pat = Grammar.Entry.parse pat
691
692
and expr = Grammar.Entry.parse expr
and prog = Grammar.Entry.parse prog
693
694
and top_phrases = Grammar.Entry.parse top_phrases

695
let sync () = 
696
  match !Ulexer.lexbuf with
697
698
699
    | None -> ()
    | Some lb ->
	let rec aux () =
700
	  match !Ulexer.last_tok with
701
702
	    | ("",";;") | ("EOI","") -> ()
	    | _ -> 
703
		Ulexer.last_tok := fst (Ulexer.token lb); 
704
705
706
		aux ()
	in
	aux ()
707
708
709
710

let sync () =
  try sync ()
  with Ulexing.Error -> ()