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 -> ()