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 "explain"; t0 = pat; t = pat; e = expr -> `Explain (t0,t,e)
215
    | IDENT "single"; t = pat -> `Single t
216
    ]
217
  ];
218

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

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

282
    | 
283
    [ e1 = expr; op = ["+" | "-" | "@" ]; e2 = expr -> apply_op2 loc op e1 e2
284
    | e1 = expr; ["||" | "or"]; e2 = expr -> exp loc (logical_or e1 e2)
285
    | e = expr; "\\"; l = [IDENT | keyword ] -> 
286
	exp loc (RemoveField (e, label l)) 
287
288
    ]
    |
289
    [ e1 = expr; op = ["*"]; e2 = expr -> apply_op2 loc op e1 e2
290
    | e1 = expr; "&&"; e2 = expr -> exp loc (logical_and e1 e2)
291
    | e = expr; op = "/"; p = pat LEVEL "simple" ->
292
	(* transform e with <(Atom)>[($$$::t|_)*] -> [$$$] *)
293
294
	let tag = mk loc (Internal (Types.atom (Atoms.any))) in
	let att = mk loc (Internal Types.Record.any) in
295
	let any = mk loc (Internal Types.any) in
296
	let re = Star(Alt(SeqCapture(noloc,id_dummy,Elem p), Elem any)) in
297
	let ct = mk loc (Regexp re) in
298
        let p = mk loc (XmlT (tag, multi_prod loc [att;ct])) in
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
329
	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
330
    ]
331
332
333
    | [ 
      e1 = SELF; IDENT "div"; e2 = expr -> apply_op2 loc "/" e1 e2
    | e1 = SELF; IDENT "mod"; e2 = expr -> apply_op2 loc "mod" e1 e2
334
    | e1 = SELF; e2 = expr -> exp loc (Apply (e1,e2))
335
336
    ]

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

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

  ];
377

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

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

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

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

424
 fun_decl_after_lparen: [
425
(* need an hack to do this, because both productions would
426
   match   [ OPT IDENT; "("; pat ] .... *)
427
428
429
430
431
432
   [ 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) ]; 
433
434
435
436
437
438
439
440
441
	     ")";
	     others = LIST0 
			[ "(";
			  args = 
			    LIST1 
			      [ arg = pat; ":"; targ = pat -> (arg,targ) ]
			      SEP ",";
			  ")" -> args ];
	     ":"; tres = pat ; 
442
	     "="; body = expr ->
443
	       `Compact (targ1,args,others,tres,body)
444
445
446
	   ] ->
       match res with
	 | `Classic (p2,a,b) -> (p1,p2)::a,b
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
	 | `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)]
	      ] ];
466
467
468


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

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

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

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

	  
  regexp: [ 
488
489
490
491
492
    [ x = regexp; "|"; y = regexp -> 
	match (x,y) with
	  | Elem x, Elem y -> Elem (mk loc (Or (x,y)))
	  | _ -> Alt (x,y) 
    ]
493
  | [ x = regexp; y = regexp -> Seq (x,y) ]
494
495
496
497
498
  | [ 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"
    ]
499
  | [ a = IDENT; "::"; x = regexp -> SeqCapture (lop loc,ident a,x) ] 
500
501
502
503
  | [ x = regexp; "*" -> Star x
    | x = regexp; "*?" -> WeakStar x
    | x = regexp; "+" -> Seq (x, Star x)
    | x = regexp; "+?" -> Seq (x, WeakStar x)
504
    | x = regexp; "?" ->  Alt (x, Epsilon)
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
    | 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
    ]
522
  | [ "("; x = LIST1 regexp SEP ","; ")" ->
523
524
525
526
527
528
529
530
531
532
533
	(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))
534
535
    | "("; a = IDENT; ":="; c = expr; ")" -> 
	Elem (mk loc (Constant ((ident a,c))))
536
    | "/"; p = pat LEVEL "simple" -> Guard p
537
    | IDENT "PCDATA" -> string_regexp
538
    | i = STRING1; "--"; j = STRING1 ->
539
540
	let i = Chars.V.mk_int (parse_char loc i)
	and j = Chars.V.mk_int (parse_char loc j) in
541
        Elem (mk loc (Internal (Types.char (Chars.char_class i j))))
542
    |  s = STRING1 ->
543
	List.fold_right
544
	  (fun c accu -> 
545
	     let c = Chars.V.mk_int c in
546
	     let c = Chars.atom c in
547
548
	     Seq (Elem (mknoloc (Internal (Types.char c))), accu))
	  (seq_of_string s)
549
550
	  Epsilon ]
    | [ e = pat LEVEL "simple" -> Elem e
551
552
553
    ]
  ];

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

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

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

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

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

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

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

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

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

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

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

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

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

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