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
    [ IDENT "_" ->  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
      | IDENT "_" -> 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 -> ()