parser.ml 21.6 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
    | (name,ns) = namespace_binding ->
	[ mk loc (Namespace (name, ns)) ]
    | (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
	let e = exp loc (NamespaceIn (name, ns, e2)) in
        [ mk loc (EvalStatement (exp loc e)) ]
154
    | "debug"; d = debug_directive -> [ mk loc (Directive (`Debug d)) ]
155 156 157 158 159 160 161 162
    | "#"; 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 ->
163
        [ mk loc (Directive (`Print_type t)) ]
164 165 166
    | "#"; IDENT "dump_value"; e = expr -> [ mk loc (Directive (`Dump e)) ]
    | "#"; IDENT "reinit_ns" -> [ mk loc (Directive `Reinit_ns) ]
    | "#"; IDENT "help" -> [ mk loc (Directive `Help) ]
167
    | "#"; IDENT "builtins" -> [ mk loc (Directive `Builtins) ]
168
    | "include"; s = STRING2 ->
169 170 171 172
	let s = 
	  if Filename.is_relative s 
	  then Filename.concat (Location.current_dir ()) s
	  else s in
173 174
	protect_op "File inclusion";
	(* avoid looping; should issue an error ? *)
175 176
	(* it is possible to have looping with x/../x/../x/.. ....
	   Need to canonicalize filename *)
177 178 179 180
	if List.mem s !include_stack then [] 
	else (
	  include_stack := s :: !include_stack;
	  Location.push_source (`File s);
181 182
	  let saved_enc = !Ulexer.enc in
	  Ulexer.enc := Ulexing.Latin1;
183 184 185
	  protect_exn
	    (fun () ->
	       let chan = open_in s in
186 187 188
	       protect_exn
		 (fun () ->
		    let input = Stream.of_channel chan in
189
		    localize_exn (fun () -> Grammar.Entry.parse prog input))
190
		 (fun () -> close_in chan))
191
	    (fun () ->
192
	       Ulexer.enc := saved_enc;
193 194
	       Location.pop_source ();
	       include_stack := List.tl !include_stack)
195
	)
196
    ] | 
197
    [ e = expr -> [ mk loc (EvalStatement e) ]
198 199 200 201
    ]
  ];

  debug_directive: [
202 203 204 205 206
    [ 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)
207
    | IDENT "explain"; t0 = pat; t = pat; e = expr -> `Explain (t0,t,e)
208 209
    | IDENT "single"; t = pat -> `Single t
    | IDENT "approx"; p = pat; t = pat -> `Approx (p,t)
210
    ]
211
  ];
212

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

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

274
    | 
275
    [ e1 = expr; op = ["+" | "-" | "@" ]; e2 = expr -> apply_op2 loc op e1 e2
276
    | e1 = expr; "||"; e2 = expr -> exp loc (logical_or e1 e2)
277
    | e = expr; "\\"; l = [IDENT | keyword ] -> 
278
	exp loc (RemoveField (e, label l)) 
279 280
    ]
    |
281
    [ e1 = expr; op = ["*"]; e2 = expr -> apply_op2 loc op e1 e2
282
    | e1 = expr; "&&"; e2 = expr -> exp loc (logical_and e1 e2)
283
    | e = expr; op = "/"; p = pat LEVEL "simple" ->
284
	(* transform e with <(Atom)>[($$$::t|_)*] -> [$$$] *)
285 286
	let tag = mk loc (Internal (Types.atom (Atoms.any))) in
	let att = mk loc (Internal Types.Record.any) in
287
	let any = mk loc (Internal Types.any) in
288
	let re = Star(Alt(SeqCapture(noloc,id_dummy,Elem p), Elem any)) in
289
	let ct = mk loc (Regexp re) in
290
        let p = mk loc (XmlT (tag, multi_prod loc [att;ct])) in
291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321
	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
322
    ]
323 324 325
    | [ 
      e1 = SELF; IDENT "div"; e2 = expr -> apply_op2 loc "/" e1 e2
    | e1 = SELF; IDENT "mod"; e2 = expr -> apply_op2 loc "mod" e1 e2
326
    | e1 = SELF; e2 = expr -> exp loc (Apply (e1,e2))
327 328
    ]

329
    | "no_appl" 
330 331 332 333 334 335 336

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

  ];
369

370
  tag: [ [ a = [ IDENT | keyword ] -> exp loc (Atom (ident a)) ] ];
371 372

  tag_type: [
373
    [ IDENT "_" ->  mk loc (Internal (Types.atom Atoms.any))
374 375
    | a = [ IDENT | keyword ] -> mk loc (Cst (Atom (ident a)))
    | t = ANY_IN_NS -> mk loc (NsT (ident t)) 
376 377 378
    ]
  ];

379
  seq_elem: [
380
    [ x = STRING1 -> 
381
	let s = U.mk x in
382
	`String (loc, U.start_index s, U.end_index s, s)
383
    | e = expr LEVEL "no_appl" -> `Elems (loc,e)
384
    | "!"; e = expr LEVEL "no_appl" -> `Explode e
385 386
    ]
  ];
387 388 389
	
  namespace_binding: [
    [ "namespace"; 
390
	name = [ name = [ IDENT | keyword ]; "=" ->
391
		   ident name
392 393
	       | -> U.mk "" ];
	uri = STRING2 ->
394
	  let ns = Ns.mk (ident uri) in
395 396 397 398 399
	  (name,ns)
    ]
  ];

  
400
  let_binding: [
401 402
    [ "let"; is_fun_decl; OPT "fun"; (f,a,b) = fun_decl ->
	let f = match f with Some x -> x | None -> assert false in
403
	let p = mk loc (PatVar (None, snd f)) in
404
	let abst = { fun_name = Some f; fun_iface = a; fun_body = b } in
405
        let e = exp loc (Abstraction abst) in
406
        (true,p,e)
407 408
    | "let"; p = pat; "="; e = expr -> (false,p,e)
    | "let"; p = pat; ":"; t = pat; "="; e = expr -> (false,p, Forget (e,t))
409 410
    | "let"; p = pat; ":"; "?"; t = pat; "="; e = expr -> 
	(false,p, Check (e,t))
411 412 413
    ] 
  ];

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


 fun_decl: [
459
   [ f = OPT located_ident; "("; (a,b) = fun_decl_after_lparen ->
460
       (f,a,b)
461
   ]
462 463
 ];

464
 arrow: [
465
    [ t1 = pat LEVEL "no_arrow"; "->"; t2 = pat -> (t1,t2)]
466 467 468
  ];

  branches: [
469
    [ OPT "|"; l = LIST1 branch SEP "|" -> l ]
470 471 472
  ];

  branch: [
473
    [ p = pat LEVEL "no_arrow"; "->"; e = expr -> (p,e) ]
474 475 476 477
  ];

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

544
  schema_ref: [
545
    [ schema = IDENT; "."; typ = [ IDENT | keyword ] -> (U.mk schema, ident typ)
546 547 548
    ]
  ];

549 550
  located_ident: [ [ a = IDENT -> (lop loc,ident a) ] ];

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

626 627
  or_else : [ [ OPT [ "else"; y = pat -> y ]  ] ];

628
  opt_field_pat: [ [ OPT [ "=";
629
                  o = [ "?" -> true | -> false]; 
630 631 632 633 634 635
                  x = pat;  y = or_else -> (o,x,y) ] ] ];

  record_spec:
    [ [ r = LIST0 [ l = [IDENT | keyword ]; f = opt_field_pat ->
		      let (o,x,y) =
			match f with
636
			  | None -> (false, mknoloc (PatVar (None,ident l)), None)
637 638 639 640 641
			  | Some z -> z
		      in
		      let x = if o then mk loc (Optional x) else x in
		      (label l, (x,y))
                  ] SEP ";" ->
642
	  r
643 644
      ] ];
  
645 646
  char:
    [ 
647
      [ c = STRING1 -> Chars.V.mk_int (parse_char loc c) ]
648 649 650
    ];
     

651
  attrib_spec:
652 653 654
    [ [ r = LIST0 [ l = [IDENT | keyword ]; f = opt_field_pat; OPT ";" -> 
		      let (o,x,y) =
			match f with
655
			  | None -> (false, mknoloc (PatVar (None,ident l)), None)
656 657 658 659 660
			  | Some z -> z
		      in
		      let x = if o then mk loc (Optional x) else x in
		      (label l, (x, y))
                  ] ->
661
	  mk loc (Record (true,r)) 
662 663 664 665
      | "("; t = pat; ")" -> t 
      | "{"; r = record_spec; "}" -> mk loc (Record (true,r))
      | "{|"; r = record_spec; "|}" -> mk loc (Record (false,r))
      ] ];
666

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

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

679
  expr_attrib_spec:
680
    [ [ r = LIST1
681 682
	      [ l = [IDENT | keyword ]; 
		x = opt_field_expr; OPT ";" ->
683
		  let x = match x with Some x -> x | None ->  Var (ident l) in
684 685 686
		  (label l,x) ] ->
	  exp loc (RecordLitt r)
      ]
687
    | [ e = expr LEVEL "no_appl" -> e 
688
      | -> exp loc (RecordLitt []) 
689 690 691 692
      ] 
    ];
END

693 694 695
module Hook = struct
  let expr = expr
  let pat = pat
696
  let keyword = keyword
697 698
end

699
let pat = Grammar.Entry.parse pat
700 701
and expr = Grammar.Entry.parse expr
and prog = Grammar.Entry.parse prog
702 703
and top_phrases = Grammar.Entry.parse top_phrases

704
let sync () = 
705
  match !Ulexer.lexbuf with
706 707 708
    | None -> ()
    | Some lb ->
	let rec aux () =
709
	  match !Ulexer.last_tok with
710 711
	    | ("",";;") | ("EOI","") -> ()
	    | _ -> 
712
		Ulexer.last_tok := fst (Ulexer.token lb); 
713 714 715
		aux ()
	in
	aux ()
716 717 718 719

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