pa_j_3.08.ml

   1 (* camlp4r pa_extend.cmo q_MLast.cmo *)
   2 (***********************************************************************)
   3 (*                                                                     *)
   4 (*                             Camlp4                                  *)
   5 (*                                                                     *)
   6 (*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
   7 (*                                                                     *)
   8 (*  Copyright 2002 Institut National de Recherche en Informatique et   *)
   9 (*  Automatique.  Distributed only by permission.                      *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: pa_o.ml,v 1.58.2.1 2004/08/18 11:17:37 mauny Exp $ *)
  14
  15 open Stdpp;
  16 open Pcaml;
  17
  18 Pcaml.syntax_name.val := "OCaml";
  19 Pcaml.no_constructors_arity.val := True;
  20
  21 (* ------------------------------------------------------------------------- *)
  22 (* Hacked version of the lexer.                                              *)
  23 (* ------------------------------------------------------------------------- *)
  24
  25 open Token;
  26
  27 value jrh_lexer = ref False;
  28
  29 value no_quotations = ref False;
  30
  31 (* The string buffering machinery *)
  32
  33 value buff = ref (String.create 80);
  34 value store len x =
  35   do {
  36     if len >= String.length buff.val then
  37       buff.val := buff.val ^ String.create (String.length buff.val)
  38     else ();
  39     buff.val.[len] := x;
  40     succ len
  41   }
  42 ;
  43 value mstore len s =
  44   add_rec len 0 where rec add_rec len i =
  45     if i == String.length s then len else add_rec (store len s.[i]) (succ i)
  46 ;
  47 value get_buff len = String.sub buff.val 0 len;
  48
  49 (* The lexer *)
  50
  51 value stream_peek_nth n strm =
  52   loop n (Stream.npeek n strm) where rec loop n =
  53     fun
  54     [ [] -> None
  55     | [x] -> if n == 1 then Some x else None
  56     | [_ :: l] -> loop (n - 1) l ]
  57 ;
  58
  59 value rec ident len =
  60   parser
  61   [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
  62          '\248'..'\255' | '0'..'9' | '_' | ''' as
  63          c)
  64         ;
  65        s :] ->
  66       ident (store len c) s
  67   | [: :] -> len ]
  68 and ident2 len =
  69   parser
  70   [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
  71          '%' | '.' | ':' | '<' | '>' | '|' | '$' as
  72          c)
  73         ;
  74        s :] ->
  75       ident2 (store len c) s
  76   | [: :] -> len ]
  77 and ident3 len =
  78   parser
  79   [ [: `('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
  80          '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | '+' | '-' | '.' |
  81          '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | ''' |
  82          '$' as
  83          c)
  84         ;
  85        s :] ->
  86       ident3 (store len c) s
  87   | [: :] -> len ]
  88 and base_number len =
  89   parser
  90   [ [: `'o' | 'O'; s :] -> digits octal (store len 'o') s
  91   | [: `'x' | 'X'; s :] -> digits hexa (store len 'x') s
  92   | [: `'b' | 'B'; s :] -> digits binary (store len 'b') s
  93   | [: a = number len :] -> a ]
  94 and digits kind len =
  95   parser
  96   [ [: d = kind; s :] -> digits_under kind (store len d) s
  97   | [: :] -> raise (Stream.Error "ill-formed integer constant") ]
  98 and digits_under kind len =
  99   parser
 100   [ [: d = kind; s :] -> digits_under kind (store len d) s
 101   | [: `'_'; s :] -> digits_under kind len s
 102   | [: `'l' :] -> ("INT32", get_buff len)
 103   | [: `'L' :] -> ("INT64", get_buff len)
 104   | [: `'n' :] -> ("NATIVEINT", get_buff len)
 105   | [: :] -> ("INT", get_buff len) ]
 106 and octal = parser [ [: `('0'..'7' as d) :] -> d ]
 107 and hexa = parser [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d) :] -> d ]
 108 and binary = parser [ [: `('0'..'1' as d) :] -> d ]
 109 and number len =
 110   parser
 111   [ [: `('0'..'9' as c); s :] -> number (store len c) s
 112   | [: `'_'; s :] -> number len s
 113   | [: `'.'; s :] -> decimal_part (store len '.') s
 114   | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
 115   | [: `'l' :] -> ("INT32", get_buff len)
 116   | [: `'L' :] -> ("INT64", get_buff len)
 117   | [: `'n' :] -> ("NATIVEINT", get_buff len)
 118   | [: :] -> ("INT", get_buff len) ]
 119 and decimal_part len =
 120   parser
 121   [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s
 122   | [: `'_'; s :] -> decimal_part len s
 123   | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
 124   | [: :] -> ("FLOAT", get_buff len) ]
 125 and exponent_part len =
 126   parser
 127   [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s
 128   | [: a = end_exponent_part len :] -> a ]
 129 and end_exponent_part len =
 130   parser
 131   [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (store len c) s
 132   | [: :] -> raise (Stream.Error "ill-formed floating-point constant") ]
 133 and end_exponent_part_under len =
 134   parser
 135   [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (store len c) s
 136   | [: `'_'; s :] -> end_exponent_part_under len s
 137   | [: :] -> ("FLOAT", get_buff len) ]
 138 ;
 139
 140 value error_on_unknown_keywords = ref False;
 141 value err loc msg = raise_with_loc loc (Token.Error msg);
 142
 143 (* ------------------------------------------------------------------------- *)
 144 (* JRH's hack to make the case distinction "unmixed" versus "mixed"          *)
 145 (* ------------------------------------------------------------------------- *)
 146
 147 value is_uppercase s = String.uppercase s = s;
 148 value is_only_lowercase s = String.lowercase s = s && not(is_uppercase s);
 149
 150 value jrh_identifier find_kwd id =
 151   let jflag = jrh_lexer.val in
 152   if id = "set_jrh_lexer" then
 153     (let _ = jrh_lexer.val := True in ("",find_kwd "true"))
 154   else if id = "unset_jrh_lexer" then
 155     (let _ = jrh_lexer.val := False in ("",find_kwd "false"))
 156   else
 157   try ("", find_kwd id) with
 158    [ Not_found ->
 159         if not(jflag) then
 160           if is_uppercase (String.sub id 0 1) then ("UIDENT", id)
 161           else ("LIDENT", id)
 162         else if is_uppercase (String.sub id 0 1) &&
 163         is_only_lowercase (String.sub id 1 (String.length id - 1))
 164 (***** Carl's alternative version
 165         then ("UIDENT", id) else if is_uppercase (String.sub id 0 1) then ("LIDENT", "__uc_"^id) else ("LIDENT", id)];
 166  *****)
 167         then ("UIDENT", id) else ("LIDENT", id)];
 168
 169 (* ------------------------------------------------------------------------- *)
 170 (* Back to original file with the mod of using the above.                    *)
 171 (* ------------------------------------------------------------------------- *)
 172
 173 (* Debugging positions and locations *)
 174 value eprint_pos msg p =
 175    Printf.eprintf "%s: fname=%s; lnum=%d; bol=%d; cnum=%d\n%!"
 176      msg p.Lexing.pos_fname p.Lexing.pos_lnum p.Lexing.pos_bol p.Lexing.pos_cnum
 177 ;
 178
 179 value eprint_loc (bp, ep) =
 180  do { eprint_pos "P1" bp; eprint_pos "P2" ep }
 181 ;
 182
 183 value check_location msg ((bp, ep) as loc) =
 184    let ok =
 185      if (bp.Lexing.pos_lnum > ep.Lexing.pos_lnum ||
 186          bp.Lexing.pos_bol > ep.Lexing.pos_bol ||
 187          bp.Lexing.pos_cnum > ep.Lexing.pos_cnum ||
 188          bp.Lexing.pos_lnum < 0 || ep.Lexing.pos_lnum < 0 ||
 189          bp.Lexing.pos_bol < 0 || ep.Lexing.pos_bol < 0 ||
 190          bp.Lexing.pos_cnum < 0 ||  ep.Lexing.pos_cnum < 0)
 191          (* Here, we don't check
 192             bp.Lexing.pos_cnum < bp.Lexing.pos_bol || ep.Lexing.pos_cnum < bp.Lexing.pos_bol
 193             since the lexer is called on antiquotations, with cnum=0, but lnum and bolpos
 194             have "correct" values *)
 195      then
 196        do {
 197          Printf.eprintf "*** Warning: (%s) strange positions ***\n" msg;
 198          eprint_loc loc;
 199          False
 200           }
 201      else
 202        True in
 203    (ok, loc)
 204 ;
 205
 206 value next_token_fun dfa ssd find_kwd fname lnum bolpos glexr =
 207    let make_pos p =
 208      {Lexing.pos_fname = fname.val; Lexing.pos_lnum = lnum.val;
 209       Lexing.pos_bol = bolpos.val; Lexing.pos_cnum = p} in
 210    let mkloc (bp, ep) = (make_pos bp, make_pos ep) in
 211    let keyword_or_error (bp,ep) s =
 212     let loc = mkloc (bp, ep) in
 213       try (("", find_kwd s), loc) with
 214       [ Not_found ->
 215         if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s)
 216         else (("", s), loc) ] in
 217   let error_if_keyword ( ((_,id) as a), bep) =
 218     let loc = mkloc bep in
 219     try do {
 220       ignore(find_kwd id);
 221       err loc ("illegal use of a keyword as a label: " ^ id) }
 222     with [ Not_found -> (a, loc) ]
 223   in
 224   let rec next_token after_space =
 225     parser bp
 226     [ [: `'\010'; s :] ep ->
 227         do { bolpos.val := ep; incr lnum; next_token True s }
 228     | [: `'\013'; s :] ep ->
 229         let ep =
 230           match Stream.peek s with
 231             [ Some '\010' -> do { Stream.junk s; ep+1 }
 232             | _ -> ep ] in
 233         do { bolpos.val := ep; incr lnum; next_token True s }
 234     | [: `' ' | '\t' | '\026' | '\012'; s :] -> next_token True s
 235     | [: `'#' when bp = bolpos.val; s :] ->
 236         if linedir 1 s then do { line_directive s; next_token True s }
 237         else keyword_or_error (bp, bp + 1) "#"
 238     | [: `'('; s :] -> left_paren bp s
 239     | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] ->
 240         let id = get_buff (ident (store 0 c) s) in
 241         let loc = mkloc (bp, (Stream.count s)) in
 242         (jrh_identifier find_kwd id, loc)
 243
 244 (********** original
 245         (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc)
 246  ***********)
 247
 248
 249     | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] ->
 250         let id = get_buff (ident (store 0 c) s) in
 251         let loc = mkloc (bp, (Stream.count s)) in
 252         (jrh_identifier find_kwd id, loc)
 253
 254 (********** original
 255         (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc)
 256  **********)
 257
 258     | [: `('1'..'9' as c); s :] ->
 259         let tok = number (store 0 c) s in
 260         let loc = mkloc (bp, (Stream.count s)) in
 261         (tok, loc)
 262     | [: `'0'; s :] ->
 263         let tok = base_number (store 0 '0') s in
 264         let loc = mkloc (bp, (Stream.count s)) in
 265         (tok, loc)
 266     | [: `'''; s :] ->
 267         match Stream.npeek 2 s with
 268         [ [_; '''] | ['\\'; _] ->
 269             let tok = ("CHAR", get_buff (char bp 0 s)) in
 270             let loc = mkloc (bp, (Stream.count s)) in
 271             (tok, loc)
 272         | _ -> keyword_or_error (bp, Stream.count s) "'" ]
 273     | [: `'"'; s :] ->
 274         let tok = ("STRING", get_buff (string bp 0 s)) in
 275         let loc = mkloc (bp, Stream.count s) in
 276         (tok, loc)
 277     | [: `'`'; s :] ->
 278         let tok = ("QUOTATION", "tot:"^(qstring bp 0 s)) in
 279         let loc = mkloc (bp, Stream.count s) in
 280         (tok, loc)
 281     | [: `'$'; s :] ->
 282         let tok = dollar bp 0 s in
 283         let loc = mkloc (bp, Stream.count s) in
 284         (tok, loc)
 285     | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c);
 286          s :] ->
 287         let id = get_buff (ident2 (store 0 c) s) in
 288         keyword_or_error (bp, Stream.count s) id
 289     | [: `('~' as c);
 290          a =
 291            parser
 292            [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep ->
 293                let id = get_buff len in
 294                match s with parser
 295                [ [: `':' :] eb -> error_if_keyword (("LABEL", id), (bp, ep))
 296                | [: :] -> error_if_keyword (("TILDEIDENT", id), (bp, ep)) ]
 297            | [: s :] ->
 298                let id = get_buff (ident2 (store 0 c) s) in
 299                keyword_or_error (bp, Stream.count s) id ] :] ->
 300         a
 301
 302     | [: `('?' as c);
 303          a =
 304            parser
 305            [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep ->
 306                let id = get_buff len in
 307                match s with parser
 308                [ [: `':' :] eb -> error_if_keyword (("OPTLABEL", id), (bp,ep))
 309                | [: :] -> error_if_keyword (("QUESTIONIDENT", id), (bp, ep)) ]
 310            | [: s :] ->
 311                let id = get_buff (ident2 (store 0 c) s) in
 312                keyword_or_error (bp, Stream.count s) id ] :] ->
 313         a
 314     | [: `'<'; s :] -> less bp s
 315     | [: `(':' as c1);
 316          len =
 317            parser
 318            [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2
 319            | [: :] -> store 0 c1 ] :] ep ->
 320         let id = get_buff len in
 321         keyword_or_error (bp, ep) id
 322     | [: `('>' | '|' as c1);
 323          len =
 324            parser
 325            [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2
 326            | [: a = ident2 (store 0 c1) :] -> a ] :] ep ->
 327         let id = get_buff len in
 328         keyword_or_error (bp, ep) id
 329     | [: `('[' | '{' as c1); s :] ->
 330         let len =
 331           match Stream.npeek 2 s with
 332           [ ['<'; '<' | ':'] -> store 0 c1
 333           | _ ->
 334               match s with parser
 335               [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2
 336               | [: :] -> store 0 c1 ] ]
 337         in
 338         let ep = Stream.count s in
 339         let id = get_buff len in
 340         keyword_or_error (bp, ep) id
 341     | [: `'.';
 342          id =
 343            parser
 344            [ [: `'.' :] -> ".."
 345            | [: :] -> if ssd && after_space then " ." else "." ] :] ep ->
 346         keyword_or_error (bp, ep) id
 347     | [: `';';
 348          id =
 349            parser
 350            [ [: `';' :] -> ";;"
 351            | [: :] -> ";" ] :] ep ->
 352         keyword_or_error (bp, ep) id
 353     | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), mkloc (bp, ep))
 354     | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c)
 355     | [: _ = Stream.empty :] -> (("EOI", ""), mkloc (bp, succ bp)) ]
 356   and less bp strm =
 357     if no_quotations.val then
 358       match strm with parser
 359       [ [: len = ident2 (store 0 '<') :] ep ->
 360           let id = get_buff len in
 361           keyword_or_error (bp, ep) id ]
 362     else
 363       match strm with parser
 364       [ [: `'<'; len = quotation bp 0 :] ep ->
 365           (("QUOTATION", ":" ^ get_buff len), mkloc (bp, ep))
 366       | [: `':'; i = parser [: len = ident 0 :] -> get_buff len;
 367            `'<' ? "character '<' expected"; len = quotation bp 0 :] ep ->
 368           (("QUOTATION", i ^ ":" ^ get_buff len), mkloc (bp, ep))
 369       | [: len = ident2 (store 0 '<') :] ep ->
 370           let id = get_buff len in
 371           keyword_or_error (bp, ep) id ]
 372   and string bp len =
 373     parser
 374     [ [: `'"' :] -> len
 375     | [: `'\\'; `c; s :] ep  -> string bp (store (store len '\\') c) s
 376     | [: `'\010'; s :] ep -> do { bolpos.val := ep; incr lnum; string bp (store len '\010') s }
 377     | [: `'\013'; s :] ep ->
 378         let (len, ep) =
 379           match Stream.peek s with
 380             [ Some '\010' -> do { Stream.junk s; (store (store len '\013') '\010', ep+1) }
 381             | _ -> (store len '\013', ep) ] in
 382         do { bolpos.val := ep; incr lnum; string bp len s }
 383     | [: `c; s :] -> string bp (store len c) s
 384     | [: :] ep -> err (mkloc (bp, ep)) "string not terminated" ]
 385   and qstring bp len =
 386     parser
 387     [ [: `'`' :] -> get_buff len
 388     | [: `c; s :] -> qstring bp (store len c) s
 389     | [: :] ep -> err (mkloc (bp, ep)) "quotation not terminated" ]
 390   and char bp len =
 391     parser
 392     [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len
 393     | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s
 394     | [: `'\010'; s :] -> do {bolpos.val := bp+1; incr lnum; char bp (store len '\010') s}
 395     | [: `'\013'; s :] ->
 396         let bol =
 397           match Stream.peek s with
 398             [ Some '\010' -> do { Stream.junk s; bp+2 }
 399             | _ -> bp+1 ] in
 400         do { bolpos.val := bol; incr lnum; char bp (store len '\013') s}
 401     | [: `c; s :] -> char bp (store len c) s
 402     | [: :] ep -> err (mkloc (bp, ep)) "char not terminated" ]
 403   and dollar bp len =
 404     parser
 405     [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
 406     | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s
 407     | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
 408     | [: `':'; s :] ->
 409         let k = get_buff len in
 410         ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
 411     | [: `'\\'; `c; s :] ->
 412         ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
 413     | [: s :] ->
 414         if dfa then
 415           match s with parser
 416           [ [: `c :] ->
 417               ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
 418           | [: :] ep -> err (mkloc (bp, ep)) "antiquotation not terminated" ]
 419         else ("", get_buff (ident2 (store 0 '$') s)) ]
 420   and maybe_locate bp len =
 421     parser
 422     [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
 423     | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
 424     | [: `':'; s :] ->
 425         ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s)
 426     | [: `'\\'; `c; s :] ->
 427         ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
 428     | [: `c; s :] ->
 429         ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
 430     | [: :] ep -> err (mkloc (bp, ep)) "antiquotation not terminated" ]
 431   and antiquot bp len =
 432     parser
 433     [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
 434     | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] ->
 435         antiquot bp (store len c) s
 436     | [: `':'; s :] ->
 437         let k = get_buff len in
 438         ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
 439     | [: `'\\'; `c; s :] ->
 440         ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
 441     | [: `c; s :] ->
 442         ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
 443     | [: :] ep -> err (mkloc (bp, ep)) "antiquotation not terminated" ]
 444   and locate_or_antiquot_rest bp len =
 445     parser
 446     [ [: `'$' :] -> get_buff len
 447     | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s
 448     | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s
 449     | [: :] ep -> err (mkloc (bp, ep)) "antiquotation not terminated" ]
 450   and quotation bp len =
 451     parser
 452     [ [: `'>'; s :] -> maybe_end_quotation bp len s
 453     | [: `'<'; s :] ->
 454         quotation bp (maybe_nested_quotation bp (store len '<') s) s
 455     | [: `'\\';
 456          len =
 457            parser
 458            [ [: `('>' | '<' | '\\' as c) :] -> store len c
 459            | [: :] -> store len '\\' ];
 460          s :] ->
 461         quotation bp len s
 462     | [: `'\010'; s :] -> do {bolpos.val := bp+1; incr lnum; quotation bp (store len '\010') s}
 463     | [: `'\013'; s :] ->
 464         let bol =
 465           match Stream.peek s with
 466             [ Some '\010' -> do { Stream.junk s; bp+2 }
 467             | _ -> bp+1 ] in
 468         do { bolpos.val := bol; incr lnum; quotation bp (store len '\013') s}
 469     | [: `c; s :] -> quotation bp (store len c) s
 470     | [: :] ep -> err (mkloc (bp, ep)) "quotation not terminated" ]
 471   and maybe_nested_quotation bp len =
 472     parser
 473     [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
 474     | [: `':'; len = ident (store len ':');
 475          a =
 476            parser
 477            [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
 478            | [: :] -> len ] :] ->
 479         a
 480     | [: :] -> len ]
 481   and maybe_end_quotation bp len =
 482     parser
 483     [ [: `'>' :] -> len
 484     | [: a = quotation bp (store len '>') :] -> a ]
 485   and left_paren bp =
 486     parser
 487     [ [: `'*'; _ = comment bp; a = next_token True :] -> a
 488     | [: :] ep -> keyword_or_error (bp, ep) "(" ]
 489   and comment bp =
 490     parser
 491     [ [: `'('; s :] -> left_paren_in_comment bp s
 492     | [: `'*'; s :] -> star_in_comment bp s
 493     | [: `'"'; _ = string bp 0; s :] -> comment bp s
 494     | [: `'''; s :] -> quote_in_comment bp s
 495     | [: `'\010'; s :] ep -> do { bolpos.val := ep; incr lnum; comment bp s }
 496     | [: `'\013'; s :] ep ->
 497         let ep =
 498           match Stream.peek s with
 499             [ Some '\010' -> do { Stream.junk s; ep+1 }
 500             | _ -> ep ] in
 501         do { bolpos.val := ep; incr lnum; comment bp s }
 502                     | [: `c; s :] -> comment bp s
 503     | [: :] ep -> err (mkloc (bp, ep)) "comment not terminated" ]
 504   and quote_in_comment bp =
 505     parser
 506     [ [: `'''; s :] -> comment bp s
 507     | [: `'\\'; s :] -> quote_antislash_in_comment bp 0 s
 508     | [: s :] ->
 509         do {
 510           match Stream.npeek 2 s with
 511           [ [ ( '\013' | '\010' ); '''] ->
 512             do { bolpos.val := bp + 1; incr lnum;
 513                  Stream.junk s; Stream.junk s }
 514           | [ '\013'; '\010' ] ->
 515                match Stream.npeek 3 s with
 516                  [ [_; _; '''] -> do { bolpos.val := bp + 2; incr lnum;
 517                                        Stream.junk s; Stream.junk s; Stream.junk s }
 518                  | _ -> () ]
 519           | [_; '''] -> do { Stream.junk s; Stream.junk s }
 520           | _ -> () ];
 521           comment bp s
 522         } ]
 523   and quote_any_in_comment bp =
 524     parser
 525     [ [: `'''; s :] -> comment bp s
 526     | [: a = comment bp :] -> a ]
 527   and quote_antislash_in_comment bp len =
 528     parser
 529     [ [: `'''; s :] -> comment bp s
 530     | [: `'\\' | '"' | 'n' | 't' | 'b' | 'r'; s :] ->
 531         quote_any_in_comment bp s
 532     | [: `'0'..'9'; s :] -> quote_antislash_digit_in_comment bp s
 533     | [: a = comment bp :] -> a ]
 534   and quote_antislash_digit_in_comment bp =
 535     parser
 536     [ [: `'0'..'9'; s :] -> quote_antislash_digit2_in_comment bp s
 537     | [: a = comment bp :] -> a ]
 538   and quote_antislash_digit2_in_comment bp =
 539     parser
 540     [ [: `'0'..'9'; s :] -> quote_any_in_comment bp s
 541     | [: a = comment bp :] -> a ]
 542   and left_paren_in_comment bp =
 543     parser
 544     [ [: `'*'; s :] -> do { comment bp s; comment bp s }
 545     | [: a = comment bp :] -> a ]
 546   and star_in_comment bp =
 547     parser
 548     [ [: `')' :] -> ()
 549     | [: a = comment bp :] -> a ]
 550   and linedir n s =
 551     match stream_peek_nth n s with
 552     [ Some (' ' | '\t') -> linedir (n + 1) s
 553     | Some ('0'..'9') -> True
 554     | _ -> False ]
 555   and any_to_nl =
 556     parser
 557     [ [: `'\010'; s :] ep ->
 558         do { bolpos.val := ep; incr lnum }
 559     | [: `'\013'; s :] ep ->
 560         let ep =
 561           match Stream.peek s with
 562             [ Some '\010' -> do { Stream.junk s; ep+1 }
 563             | _ -> ep ] in
 564         do { bolpos.val := ep; incr lnum }
 565     | [: `_; s :] -> any_to_nl s
 566     | [: :] -> () ]
 567   and line_directive = parser (* we are sure that there is a line directive here *)
 568     [ [: _ = skip_spaces; n = line_directive_number 0;
 569          _ = skip_spaces; _ = line_directive_string;
 570          _ = any_to_nl :] ep
 571        -> do { bolpos.val := ep; lnum.val := n }
 572     ]
 573   and skip_spaces = parser
 574     [ [: `' ' | '\t'; s :] -> skip_spaces s
 575     | [: :] -> () ]
 576   and line_directive_number n = parser
 577     [ [: `('0'..'9' as c) ; s :]
 578       -> line_directive_number (10*n + (Char.code c - Char.code '0')) s
 579     | [: :] -> n ]
 580   and line_directive_string = parser
 581     [ [: ` '"' ; _ = line_directive_string_contents 0 :] -> ()
 582     | [: :] -> ()
 583    ]
 584   and line_directive_string_contents len = parser
 585     [ [: ` '\010' | '\013' :]  -> ()
 586     | [: ` '"' :] -> fname.val := get_buff len
 587     | [: `c; s :] -> line_directive_string_contents (store len c) s
 588     ]
 589   in
 590   fun cstrm ->
 591     try
 592       let glex = glexr.val in
 593       let comm_bp = Stream.count cstrm in
 594       let r = next_token False cstrm in
 595       do {
 596         match glex.tok_comm with
 597         [ Some list ->
 598             let next_bp = (fst (snd r)).Lexing.pos_cnum in
 599             if next_bp > comm_bp then
 600               let comm_loc = mkloc (comm_bp, next_bp) in
 601               glex.tok_comm := Some [comm_loc :: list]
 602             else ()
 603         | None -> () ];
 604         r
 605       }
 606     with
 607     [ Stream.Error str ->
 608         err (mkloc (Stream.count cstrm, Stream.count cstrm + 1)) str ]
 609 ;
 610
 611
 612 value dollar_for_antiquotation = ref True;
 613 value specific_space_dot = ref False;
 614
 615 value func kwd_table glexr =
 616   let bolpos = ref 0 in
 617   let lnum = ref 1 in
 618   let fname = ref "" in
 619   let find = Hashtbl.find kwd_table in
 620   let dfa = dollar_for_antiquotation.val in
 621   let ssd = specific_space_dot.val in
 622   Token.lexer_func_of_parser (next_token_fun dfa ssd find fname lnum bolpos glexr)
 623 ;
 624
 625 value rec check_keyword_stream =
 626   parser [: _ = check; _ = Stream.empty :] -> True
 627 and check =
 628   parser
 629   [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255'
 630         ;
 631        s :] ->
 632       check_ident s
 633   | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
 634         '%' | '.'
 635         ;
 636        s :] ->
 637       check_ident2 s
 638   | [: `'<'; s :] ->
 639       match Stream.npeek 1 s with
 640       [ [':' | '<'] -> ()
 641       | _ -> check_ident2 s ]
 642   | [: `':';
 643        _ =
 644          parser
 645          [ [: `']' | ':' | '=' | '>' :] -> ()
 646          | [: :] -> () ] :] ep ->
 647       ()
 648   | [: `'>' | '|';
 649        _ =
 650          parser
 651          [ [: `']' | '}' :] -> ()
 652          | [: a = check_ident2 :] -> a ] :] ->
 653       ()
 654   | [: `'[' | '{'; s :] ->
 655       match Stream.npeek 2 s with
 656       [ ['<'; '<' | ':'] -> ()
 657       | _ ->
 658           match s with parser
 659           [ [: `'|' | '<' | ':' :] -> ()
 660           | [: :] -> () ] ]
 661   | [: `';';
 662        _ =
 663          parser
 664          [ [: `';' :] -> ()
 665          | [: :] -> () ] :] ->
 666       ()
 667   | [: `_ :] -> () ]
 668 and check_ident =
 669   parser
 670   [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
 671         '\248'..'\255' | '0'..'9' | '_' | '''
 672         ;
 673        s :] ->
 674       check_ident s
 675   | [: :] -> () ]
 676 and check_ident2 =
 677   parser
 678   [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
 679         '%' | '.' | ':' | '<' | '>' | '|'
 680         ;
 681        s :] ->
 682       check_ident2 s
 683   | [: :] -> () ]
 684 ;
 685
 686 value check_keyword s =
 687   try check_keyword_stream (Stream.of_string s) with _ -> False
 688 ;
 689
 690 value error_no_respect_rules p_con p_prm =
 691   raise
 692     (Token.Error
 693        ("the token " ^
 694           (if p_con = "" then "\"" ^ p_prm ^ "\""
 695            else if p_prm = "" then p_con
 696            else p_con ^ " \"" ^ p_prm ^ "\"") ^
 697           " does not respect Plexer rules"))
 698 ;
 699
 700 value error_ident_and_keyword p_con p_prm =
 701   raise
 702     (Token.Error
 703        ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^
 704           " and as keyword"))
 705 ;
 706
 707 value using_token kwd_table ident_table (p_con, p_prm) =
 708   match p_con with
 709   [ "" ->
 710       if not (Hashtbl.mem kwd_table p_prm) then
 711         if check_keyword p_prm then
 712           if Hashtbl.mem ident_table p_prm then
 713             error_ident_and_keyword (Hashtbl.find ident_table p_prm) p_prm
 714           else Hashtbl.add kwd_table p_prm p_prm
 715         else error_no_respect_rules p_con p_prm
 716       else ()
 717   | "LIDENT" ->
 718       if p_prm = "" then ()
 719       else
 720         match p_prm.[0] with
 721         [ 'A'..'Z' -> error_no_respect_rules p_con p_prm
 722         | _ ->
 723             if Hashtbl.mem kwd_table p_prm then
 724               error_ident_and_keyword p_con p_prm
 725             else Hashtbl.add ident_table p_prm p_con ]
 726   | "UIDENT" ->
 727       if p_prm = "" then ()
 728       else
 729         match p_prm.[0] with
 730         [ 'a'..'z' -> error_no_respect_rules p_con p_prm
 731         | _ ->
 732             if Hashtbl.mem kwd_table p_prm then
 733               error_ident_and_keyword p_con p_prm
 734             else Hashtbl.add ident_table p_prm p_con ]
 735   | "INT" | "INT32" | "INT64" | "NATIVEINT"
 736   | "FLOAT" | "CHAR" | "STRING"
 737   | "TILDEIDENT" | "QUESTIONIDENT" | "LABEL" | "OPTLABEL"
 738   | "QUOTATION" | "ANTIQUOT" | "LOCATE" | "EOI" ->
 739       ()
 740   | _ ->
 741       raise
 742         (Token.Error
 743            ("the constructor \"" ^ p_con ^
 744               "\" is not recognized by Plexer")) ]
 745 ;
 746
 747 value removing_token kwd_table ident_table (p_con, p_prm) =
 748   match p_con with
 749   [ "" -> Hashtbl.remove kwd_table p_prm
 750   | "LIDENT" | "UIDENT" ->
 751       if p_prm <> "" then Hashtbl.remove ident_table p_prm else ()
 752   | _ -> () ]
 753 ;
 754
 755 value text =
 756   fun
 757   [ ("", t) -> "'" ^ t ^ "'"
 758   | ("LIDENT", "") -> "lowercase identifier"
 759   | ("LIDENT", t) -> "'" ^ t ^ "'"
 760   | ("UIDENT", "") -> "uppercase identifier"
 761   | ("UIDENT", t) -> "'" ^ t ^ "'"
 762   | ("INT", "") -> "integer"
 763   | ("INT32", "") -> "32 bits integer"
 764   | ("INT64", "") -> "64 bits integer"
 765   | ("NATIVEINT", "") -> "native integer"
 766   | (("INT" | "INT32" | "NATIVEINT"), s) -> "'" ^ s ^ "'"
 767   | ("FLOAT", "") -> "float"
 768   | ("STRING", "") -> "string"
 769   | ("CHAR", "") -> "char"
 770   | ("QUOTATION", "") -> "quotation"
 771   | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\""
 772   | ("LOCATE", "") -> "locate"
 773   | ("EOI", "") -> "end of input"
 774   | (con, "") -> con
 775   | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ]
 776 ;
 777
 778 value eq_before_colon p e =
 779   loop 0 where rec loop i =
 780     if i == String.length e then
 781       failwith "Internal error in Plexer: incorrect ANTIQUOT"
 782     else if i == String.length p then e.[i] == ':'
 783     else if p.[i] == e.[i] then loop (i + 1)
 784     else False
 785 ;
 786
 787 value after_colon e =
 788   try
 789     let i = String.index e ':' in
 790     String.sub e (i + 1) (String.length e - i - 1)
 791   with
 792   [ Not_found -> "" ]
 793 ;
 794
 795 value tok_match =
 796   fun
 797   [ ("ANTIQUOT", p_prm) ->
 798       fun
 799       [ ("ANTIQUOT", prm) when eq_before_colon p_prm prm -> after_colon prm
 800       | _ -> raise Stream.Failure ]
 801   | tok -> Token.default_match tok ]
 802 ;
 803
 804 value gmake () =
 805   let kwd_table = Hashtbl.create 301 in
 806   let id_table = Hashtbl.create 301 in
 807   let glexr =
 808     ref
 809      {tok_func = fun []; tok_using = fun []; tok_removing = fun [];
 810       tok_match = fun []; tok_text = fun []; tok_comm = None}
 811   in
 812   let glex =
 813     {tok_func = func kwd_table glexr;
 814      tok_using = using_token kwd_table id_table;
 815      tok_removing = removing_token kwd_table id_table; tok_match = tok_match;
 816      tok_text = text; tok_comm = None}
 817   in
 818   do { glexr.val := glex; glex }
 819 ;
 820
 821 value tparse =
 822   fun
 823   [ ("ANTIQUOT", p_prm) ->
 824       let p =
 825         parser
 826           [: `("ANTIQUOT", prm) when eq_before_colon p_prm prm :] ->
 827             after_colon prm
 828       in
 829       Some p
 830   | _ -> None ]
 831 ;
 832
 833 value make () =
 834   let kwd_table = Hashtbl.create 301 in
 835   let id_table = Hashtbl.create 301 in
 836   let glexr =
 837     ref
 838      {tok_func = fun []; tok_using = fun []; tok_removing = fun [];
 839       tok_match = fun []; tok_text = fun []; tok_comm = None}
 840   in
 841   {func = func kwd_table glexr; using = using_token kwd_table id_table;
 842    removing = removing_token kwd_table id_table; tparse = tparse; text = text}
 843 ;
 844
 845 (* ------------------------------------------------------------------------- *)
 846 (* Resume the main file.                                                     *)
 847 (* ------------------------------------------------------------------------- *)
 848
 849 do {
 850   let odfa = dollar_for_antiquotation.val in
 851   dollar_for_antiquotation.val := False;
 852   Grammar.Unsafe.gram_reinit gram (gmake ());
 853   dollar_for_antiquotation.val := odfa;
 854   Grammar.Unsafe.clear_entry interf;
 855   Grammar.Unsafe.clear_entry implem;
 856   Grammar.Unsafe.clear_entry top_phrase;
 857   Grammar.Unsafe.clear_entry use_file;
 858   Grammar.Unsafe.clear_entry module_type;
 859   Grammar.Unsafe.clear_entry module_expr;
 860   Grammar.Unsafe.clear_entry sig_item;
 861   Grammar.Unsafe.clear_entry str_item;
 862   Grammar.Unsafe.clear_entry expr;
 863   Grammar.Unsafe.clear_entry patt;
 864   Grammar.Unsafe.clear_entry ctyp;
 865   Grammar.Unsafe.clear_entry let_binding;
 866   Grammar.Unsafe.clear_entry type_declaration;
 867   Grammar.Unsafe.clear_entry class_type;
 868   Grammar.Unsafe.clear_entry class_expr;
 869   Grammar.Unsafe.clear_entry class_sig_item;
 870   Grammar.Unsafe.clear_entry class_str_item
 871 };
 872
 873 Pcaml.parse_interf.val := Grammar.Entry.parse interf;
 874 Pcaml.parse_implem.val := Grammar.Entry.parse implem;
 875
 876 value o2b =
 877   fun
 878   [ Some _ -> True
 879   | None -> False ]
 880 ;
 881
 882 value mkumin loc f arg =
 883   match (f, arg) with
 884   [ ("-", <:expr< $int:n$ >>) when int_of_string n > 0 ->
 885       let n = "-" ^ n in
 886       <:expr< $int:n$ >>
 887   | ("-", MLast.ExInt32 loc n) when (Int32.of_string n) > 0l ->
 888       MLast.ExInt32 loc ("-" ^ n)
 889   | ("-", MLast.ExInt64 loc n) when (Int64.of_string n) > 0L ->
 890       MLast.ExInt64 loc ("-" ^ n)
 891   | ("-", MLast.ExNativeInt loc n) when (Nativeint.of_string n) > 0n ->
 892       MLast.ExNativeInt loc ("-" ^ n)
 893   | (_, <:expr< $flo:n$ >>) when float_of_string n > 0.0 ->
 894       let n = "-" ^ n in
 895       <:expr< $flo:n$ >>
 896   | _ ->
 897       let f = "~" ^ f in
 898       <:expr< $lid:f$ $arg$ >> ]
 899 ;
 900
 901
 902 value mklistexp loc last =
 903   loop True where rec loop top =
 904     fun
 905     [ [] ->
 906         match last with
 907         [ Some e -> e
 908         | None -> <:expr< [] >> ]
 909     | [e1 :: el] ->
 910         let loc = if top then loc else (fst (MLast.loc_of_expr e1), snd loc) in
 911         <:expr< [$e1$ :: $loop False el$] >> ]
 912 ;
 913
 914 value mklistpat loc last =
 915   loop True where rec loop top =
 916     fun
 917     [ [] ->
 918         match last with
 919         [ Some p -> p
 920         | None -> <:patt< [] >> ]
 921     | [p1 :: pl] ->
 922         let loc = if top then loc else (fst (MLast.loc_of_patt p1), snd loc) in
 923         <:patt< [$p1$ :: $loop False pl$] >> ]
 924 ;
 925
 926 (*** JRH pulled this outside so user can add new infixes here too ***)
 927
 928 value ht = Hashtbl.create 73;
 929
 930 (*** And JRH added all the new HOL Light infixes here already ***)
 931
 932 value is_operator =
 933   let ct = Hashtbl.create 73 in
 934   do {
 935     List.iter (fun x -> Hashtbl.add ht x True)
 936       ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; "o"; "upto";
 937        "F_F"; "THENC"; "THEN"; "THENL"; "ORELSE"; "ORELSEC";
 938        "THEN_TCL"; "ORELSE_TCL"];
 939     List.iter (fun x -> Hashtbl.add ct x True)
 940       ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~';
 941        '?'; '%'; '.'; '$'];
 942     fun x ->
 943       try Hashtbl.find ht x with
 944       [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ]
 945   }
 946 ;
 947
 948 (*** JRH added this so parenthesised operators undergo same mapping ***)
 949
 950 value translate_operator =
 951   fun s ->
 952    match s with
 953     [ "THEN" -> "then_"
 954     | "THENC" -> "thenc_"
 955     | "THENL" -> "thenl_"
 956     | "ORELSE" -> "orelse_"
 957     | "ORELSEC" -> "orelsec_"
 958     | "THEN_TCL" -> "then_tcl_"
 959     | "ORELSE_TCL" -> "orelse_tcl_"
 960     | "F_F" -> "f_f_"
 961     | _ -> s];
 962
 963 (*** And JRH inserted it in here ***)
 964
 965 value operator_rparen =
 966   Grammar.Entry.of_parser gram "operator_rparen"
 967     (fun strm ->
 968        match Stream.npeek 2 strm with
 969        [ [("", s); ("", ")")] when is_operator s ->
 970            do { Stream.junk strm; Stream.junk strm; translate_operator s }
 971        | _ -> raise Stream.Failure ])
 972 ;
 973
 974 value lident_colon =
 975   Grammar.Entry.of_parser gram "lident_colon"
 976     (fun strm ->
 977        match Stream.npeek 2 strm with
 978        [ [("LIDENT", i); ("", ":")] ->
 979            do { Stream.junk strm; Stream.junk strm; i }
 980        | _ -> raise Stream.Failure ])
 981 ;
 982
 983 value symbolchar =
 984   let list =
 985     ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?';
 986      '@'; '^'; '|'; '~']
 987   in
 988   let rec loop s i =
 989     if i == String.length s then True
 990     else if List.mem s.[i] list then loop s (i + 1)
 991     else False
 992   in
 993   loop
 994 ;
 995
 996 value prefixop =
 997   let list = ['!'; '?'; '~'] in
 998   let excl = ["!="; "??"] in
 999   Grammar.Entry.of_parser gram "prefixop"
1000     (parser
1001        [: `("", x)
1002            when
1003              not (List.mem x excl) && String.length x >= 2 &&
1004              List.mem x.[0] list && symbolchar x 1 :] ->
1005          x)
1006 ;
1007
1008 value infixop0 =
1009   let list = ['='; '<'; '>'; '|'; '&'; '$'] in
1010   let excl = ["<-"; "||"; "&&"] in
1011   Grammar.Entry.of_parser gram "infixop0"
1012     (parser
1013        [: `("", x)
1014            when
1015              not (List.mem x excl) && String.length x >= 2 &&
1016              List.mem x.[0] list && symbolchar x 1 :] ->
1017          x)
1018 ;
1019
1020 value infixop1 =
1021   let list = ['@'; '^'] in
1022   Grammar.Entry.of_parser gram "infixop1"
1023     (parser
1024        [: `("", x)
1025            when
1026              String.length x >= 2 && List.mem x.[0] list &&
1027              symbolchar x 1 :] ->
1028          x)
1029 ;
1030
1031 value infixop2 =
1032   let list = ['+'; '-'] in
1033   Grammar.Entry.of_parser gram "infixop2"
1034     (parser
1035        [: `("", x)
1036            when
1037              x <> "->" && String.length x >= 2 && List.mem x.[0] list &&
1038              symbolchar x 1 :] ->
1039          x)
1040 ;
1041
1042 value infixop3 =
1043   let list = ['*'; '/'; '%'] in
1044   Grammar.Entry.of_parser gram "infixop3"
1045     (parser
1046        [: `("", x)
1047            when
1048              String.length x >= 2 && List.mem x.[0] list &&
1049              symbolchar x 1 :] ->
1050          x)
1051 ;
1052
1053 value infixop4 =
1054   Grammar.Entry.of_parser gram "infixop4"
1055     (parser
1056        [: `("", x)
1057            when
1058              String.length x >= 3 && x.[0] == '*' && x.[1] == '*' &&
1059              symbolchar x 2 :] ->
1060          x)
1061 ;
1062
1063 value test_constr_decl =
1064   Grammar.Entry.of_parser gram "test_constr_decl"
1065     (fun strm ->
1066        match Stream.npeek 1 strm with
1067        [ [("UIDENT", _)] ->
1068            match Stream.npeek 2 strm with
1069            [ [_; ("", ".")] -> raise Stream.Failure
1070            | [_; ("", "(")] -> raise Stream.Failure
1071            | [_ :: _] -> ()
1072            | _ -> raise Stream.Failure ]
1073        | [("", "|")] -> ()
1074        | _ -> raise Stream.Failure ])
1075 ;
1076
1077 value stream_peek_nth n strm =
1078   loop n (Stream.npeek n strm) where rec loop n =
1079     fun
1080     [ [] -> None
1081     | [x] -> if n == 1 then Some x else None
1082     | [_ :: l] -> loop (n - 1) l ]
1083 ;
1084
1085 (* horrible hack to be able to parse class_types *)
1086
1087 value test_ctyp_minusgreater =
1088   Grammar.Entry.of_parser gram "test_ctyp_minusgreater"
1089     (fun strm ->
1090        let rec skip_simple_ctyp n =
1091          match stream_peek_nth n strm with
1092          [ Some ("", "->") -> n
1093          | Some ("", "[" | "[<") ->
1094              skip_simple_ctyp (ignore_upto "]" (n + 1) + 1)
1095          | Some ("", "(") -> skip_simple_ctyp (ignore_upto ")" (n + 1) + 1)
1096          | Some
1097              ("",
1098               "as" | "'" | ":" | "*" | "." | "#" | "<" | ">" | ".." | ";" |
1099               "_") ->
1100              skip_simple_ctyp (n + 1)
1101          | Some ("QUESTIONIDENT" | "LIDENT" | "UIDENT", _) ->
1102              skip_simple_ctyp (n + 1)
1103          | Some _ | None -> raise Stream.Failure ]
1104        and ignore_upto end_kwd n =
1105          match stream_peek_nth n strm with
1106          [ Some ("", prm) when prm = end_kwd -> n
1107          | Some ("", "[" | "[<") ->
1108              ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1)
1109          | Some ("", "(") -> ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1)
1110          | Some _ -> ignore_upto end_kwd (n + 1)
1111          | None -> raise Stream.Failure ]
1112        in
1113        match Stream.peek strm with
1114        [ Some (("", "[") | ("LIDENT" | "UIDENT", _)) -> skip_simple_ctyp 1
1115        | Some ("", "object") -> raise Stream.Failure
1116        | _ -> 1 ])
1117 ;
1118
1119 value test_label_eq =
1120   Grammar.Entry.of_parser gram "test_label_eq"
1121     (test 1 where rec test lev strm =
1122        match stream_peek_nth lev strm with
1123        [ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) ->
1124            test (lev + 1) strm
1125        | Some ("", "=") -> ()
1126        | _ -> raise Stream.Failure ])
1127 ;
1128
1129 value test_typevar_list_dot =
1130   Grammar.Entry.of_parser gram "test_typevar_list_dot"
1131     (let rec test lev strm =
1132        match stream_peek_nth lev strm with
1133        [ Some ("", "'") -> test2 (lev + 1) strm
1134        | Some ("", ".") -> ()
1135        | _ -> raise Stream.Failure ]
1136     and test2 lev strm =
1137        match stream_peek_nth lev strm with
1138        [ Some ("UIDENT" | "LIDENT", _) -> test (lev + 1) strm
1139        | _ -> raise Stream.Failure ]
1140     in
1141     test 1)
1142 ;
1143
1144 value constr_arity = ref [("Some", 1); ("Match_Failure", 1)];
1145
1146 value rec is_expr_constr_call =
1147   fun
1148   [ <:expr< $uid:_$ >> -> True
1149   | <:expr< $uid:_$.$e$ >> -> is_expr_constr_call e
1150   | <:expr< $e$ $_$ >> -> is_expr_constr_call e
1151   | _ -> False ]
1152 ;
1153
1154 value rec constr_expr_arity loc =
1155   fun
1156   [ <:expr< $uid:c$ >> ->
1157       try List.assoc c constr_arity.val with [ Not_found -> 0 ]
1158   | <:expr< $uid:_$.$e$ >> -> constr_expr_arity loc e
1159   | <:expr< $e$ $_$ >> ->
1160       if is_expr_constr_call e then
1161         Stdpp.raise_with_loc loc (Stream.Error "currified constructor")
1162       else 1
1163   | _ -> 1 ]
1164 ;
1165
1166 value rec is_patt_constr_call =
1167   fun
1168   [ <:patt< $uid:_$ >> -> True
1169   | <:patt< $uid:_$.$p$ >> -> is_patt_constr_call p
1170   | <:patt< $p$ $_$ >> -> is_patt_constr_call p
1171   | _ -> False ]
1172 ;
1173
1174 value rec constr_patt_arity loc =
1175   fun
1176   [ <:patt< $uid:c$ >> ->
1177       try List.assoc c constr_arity.val with [ Not_found -> 0 ]
1178   | <:patt< $uid:_$.$p$ >> -> constr_patt_arity loc p
1179   | <:patt< $p$ $_$ >> ->
1180       if is_patt_constr_call p then
1181         Stdpp.raise_with_loc loc (Stream.Error "currified constructor")
1182       else 1
1183   | _ -> 1 ]
1184 ;
1185
1186 value get_seq =
1187   fun
1188   [ <:expr< do { $list:el$ } >> -> el
1189   | e -> [e] ]
1190 ;
1191
1192 value choose_tvar tpl =
1193   let rec find_alpha v =
1194     let s = String.make 1 v in
1195     if List.mem_assoc s tpl then
1196       if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1))
1197     else Some (String.make 1 v)
1198   in
1199   let rec make_n n =
1200     let v = "a" ^ string_of_int n in
1201     if List.mem_assoc v tpl then make_n (succ n) else v
1202   in
1203   match find_alpha 'a' with
1204   [ Some x -> x
1205   | None -> make_n 1 ]
1206 ;
1207
1208 value rec patt_lid =
1209   fun
1210   [ <:patt< $p1$ $p2$ >> ->
1211       match p1 with
1212       [ <:patt< $lid:i$ >> -> Some (MLast.loc_of_patt p1, i, [p2])
1213       | _ ->
1214           match patt_lid p1 with
1215           [ Some (loc, i, pl) -> Some (loc, i, [p2 :: pl])
1216           | None -> None ] ]
1217   | _ -> None ]
1218 ;
1219
1220 value bigarray_get loc arr arg =
1221   let coords =
1222     match arg with
1223     [ <:expr< ($list:el$) >> -> el
1224     | _ -> [arg] ]
1225   in
1226   match coords with
1227   [ [c1] -> <:expr< Bigarray.Array1.get $arr$ $c1$ >>
1228   | [c1; c2] -> <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >>
1229   | [c1; c2; c3] -> <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >>
1230   | coords -> <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ]
1231 ;
1232
1233 value bigarray_set loc var newval =
1234   match var with
1235   [ <:expr< Bigarray.Array1.get $arr$ $c1$ >> ->
1236       Some <:expr< Bigarray.Array1.set $arr$ $c1$ $newval$ >>
1237   | <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> ->
1238       Some <:expr< Bigarray.Array2.set $arr$ $c1$ $c2$ $newval$ >>
1239   | <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> ->
1240       Some <:expr< Bigarray.Array3.set $arr$ $c1$ $c2$ $c3$ $newval$ >>
1241   | <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ->
1242       Some <:expr< Bigarray.Genarray.set $arr$ [| $list:coords$ |] $newval$ >>
1243   | _ -> None ]
1244 ;
1245
1246 (* ...works bad...
1247 value rec sync cs =
1248   match cs with parser
1249   [ [: `';' :] -> sync_semi cs
1250   | [: `_ :] -> sync cs ]
1251 and sync_semi cs =
1252   match cs with parser
1253   [ [: `';' :] -> sync_semisemi cs
1254   | [: :] -> sync cs ]
1255 and sync_semisemi cs =
1256   match Stream.peek cs with
1257   [ Some ('\010' | '\013') -> ()
1258   | _ -> sync_semi cs ]
1259 ;
1260 Pcaml.sync.val := sync;
1261 *)
1262
1263
1264 EXTEND
1265   GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type
1266     class_expr class_sig_item class_str_item let_binding type_declaration;
1267   module_expr:
1268     [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->";
1269         me = SELF ->
1270           <:module_expr< functor ( $i$ : $t$ ) -> $me$ >>
1271       | "struct"; st = LIST0 [ s = str_item; OPT ";;" -> s ]; "end" ->
1272           <:module_expr< struct $list:st$ end >> ]
1273     | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ]
1274     | [ i = mod_expr_ident -> i
1275       | "("; me = SELF; ":"; mt = module_type; ")" ->
1276           <:module_expr< ( $me$ : $mt$ ) >>
1277       | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ]
1278   ;
1279
1280   mod_expr_ident:
1281     [ LEFTA
1282       [ i = SELF; "."; j = SELF -> <:module_expr< $i$ . $j$ >> ]
1283     | [ i = UIDENT -> <:module_expr< $uid:i$ >> ] ]
1284   ;
1285
1286   str_item:
1287     [ "top"
1288       [ "exception"; (_, c, tl) = constructor_declaration; b = rebind_exn ->
1289           <:str_item< exception $c$ of $list:tl$ = $b$ >>
1290       | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
1291           <:str_item< external $i$ : $t$ = $list:pd$ >>
1292       | "external"; "("; i = operator_rparen; ":"; t = ctyp; "=";
1293         pd = LIST1 STRING ->
1294           <:str_item< external $i$ : $t$ = $list:pd$ >>
1295       | "include"; me = module_expr -> <:str_item< include $me$ >>
1296       | "module"; i = UIDENT; mb = module_binding ->
1297           <:str_item< module $i$ = $mb$ >>
1298       | "module"; "rec"; nmtmes = LIST1 module_rec_binding SEP "and" ->
1299           MLast.StRecMod loc nmtmes
1300       | "module"; "type"; i = UIDENT; "="; mt = module_type ->
1301           <:str_item< module type $i$ = $mt$ >>
1302       | "open"; i = mod_ident -> <:str_item< open $i$ >>
1303       | "type"; tdl = LIST1 type_declaration SEP "and" ->
1304           <:str_item< type $list:tdl$ >>
1305       | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
1306         x = expr ->
1307           let e = <:expr< let $opt:o2b r$ $list:l$ in $x$ >> in
1308           <:str_item< $exp:e$ >>
1309       | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" ->
1310           match l with
1311           [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >>
1312           | _ -> <:str_item< value $opt:o2b r$ $list:l$ >> ]
1313       | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr ->
1314           <:str_item< let module $m$ = $mb$ in $e$ >>
1315       | e = expr -> <:str_item< $exp:e$ >> ] ]
1316   ;
1317
1318   rebind_exn:
1319     [ [ "="; sl = mod_ident -> sl
1320       | -> [] ] ]
1321   ;
1322   module_binding:
1323     [ RIGHTA
1324       [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF ->
1325           <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >>
1326       | ":"; mt = module_type; "="; me = module_expr ->
1327           <:module_expr< ( $me$ : $mt$ ) >>
1328       | "="; me = module_expr -> <:module_expr< $me$ >> ] ]
1329   ;
1330   module_rec_binding:
1331     [ [ m = UIDENT; ":"; mt = module_type; "="; me = module_expr ->
1332           (m, mt, me) ] ]
1333   ;
1334   (* Module types *)
1335   module_type:
1336     [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF ->
1337           <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ]
1338     | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" ->
1339           <:module_type< $mt$ with $list:wcl$ >> ]
1340     | [ "sig"; sg = LIST0 [ s = sig_item; OPT ";;" -> s ]; "end" ->
1341           <:module_type< sig $list:sg$ end >>
1342       | i = mod_type_ident -> i
1343       | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ]
1344   ;
1345   mod_type_ident:
1346     [ LEFTA
1347       [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >>
1348       | m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ]
1349     | [ m = UIDENT -> <:module_type< $uid:m$ >>
1350       | m = LIDENT -> <:module_type< $lid:m$ >> ] ]
1351   ;
1352   sig_item:
1353     [ "top"
1354       [ "exception"; (_, c, tl) = constructor_declaration ->
1355           <:sig_item< exception $c$ of $list:tl$ >>
1356       | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
1357           <:sig_item< external $i$ : $t$ = $list:pd$ >>
1358       | "external"; "("; i = operator_rparen; ":"; t = ctyp; "=";
1359         pd = LIST1 STRING ->
1360           <:sig_item< external $i$ : $t$ = $list:pd$ >>
1361       | "include"; mt = module_type -> <:sig_item< include $mt$ >>
1362       | "module"; i = UIDENT; mt = module_declaration ->
1363           <:sig_item< module $i$ : $mt$ >>
1364       | "module"; "rec"; mds = LIST1 module_rec_declaration SEP "and" ->
1365           MLast.SgRecMod loc mds
1366       | "module"; "type"; i = UIDENT; "="; mt = module_type ->
1367           <:sig_item< module type $i$ = $mt$ >>
1368       | "module"; "type"; i = UIDENT ->
1369           <:sig_item< module type $i$ = 'abstract >>
1370       | "open"; i = mod_ident -> <:sig_item< open $i$ >>
1371       | "type"; tdl = LIST1 type_declaration SEP "and" ->
1372           <:sig_item< type $list:tdl$ >>
1373       | "val"; i = LIDENT; ":"; t = ctyp -> <:sig_item< value $i$ : $t$ >>
1374       | "val"; "("; i = operator_rparen; ":"; t = ctyp ->
1375           <:sig_item< value $i$ : $t$ >> ] ]
1376   ;
1377   module_declaration:
1378     [ RIGHTA
1379       [ ":"; mt = module_type -> <:module_type< $mt$ >>
1380       | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF ->
1381           <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ]
1382   ;
1383   module_rec_declaration:
1384     [ [ m = UIDENT; ":"; mt = module_type -> (m, mt)] ]
1385   ;
1386   (* "with" constraints (additional type equations over signature
1387      components) *)
1388   with_constr:
1389     [ [ "type"; tpl = type_parameters; i = mod_ident; "="; t = ctyp ->
1390           MLast.WcTyp loc i tpl t
1391       | "module"; i = mod_ident; "="; me = module_expr ->
1392           MLast.WcMod loc i me ] ]
1393   ;
1394   (* Core expressions *)
1395   expr:
1396     [ "top" RIGHTA
1397       [ e1 = SELF; ";"; e2 = SELF ->
1398           <:expr< do { $list:[e1 :: get_seq e2]$ } >>
1399       | e1 = SELF; ";" -> e1 ]
1400     | "expr1"
1401       [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
1402         x = expr LEVEL "top" ->
1403           <:expr< let $opt:o2b o$ $list:l$ in $x$ >>
1404       | "let"; "module"; m = UIDENT; mb = module_binding; "in";
1405         e = expr LEVEL "top" ->
1406           <:expr< let module $m$ = $mb$ in $e$ >>
1407       | "function"; OPT "|"; l = LIST1 match_case SEP "|" ->
1408           <:expr< fun [ $list:l$ ] >>
1409       | "fun"; p = simple_patt; e = fun_def ->
1410           <:expr< fun [$p$ -> $e$] >>
1411       | "match"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" ->
1412           <:expr< match $e$ with [ $list:l$ ] >>
1413       | "try"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" ->
1414           <:expr< try $e$ with [ $list:l$ ] >>
1415       | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1";
1416         "else"; e3 = expr LEVEL "expr1" ->
1417           <:expr< if $e1$ then $e2$ else $e3$ >>
1418       | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1" ->
1419           <:expr< if $e1$ then $e2$ else () >>
1420       | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
1421         "do"; e = SELF; "done" ->
1422           <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:get_seq e$ } >>
1423       | "while"; e1 = SELF; "do"; e2 = SELF; "done" ->
1424           <:expr< while $e1$ do { $list:get_seq e2$ } >>
1425       | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" ->
1426           (* <:expr< object $opt:cspo$ $list:cf$ end >> *)
1427           MLast.ExObj loc cspo cf ]
1428     | [ e = SELF; ","; el = LIST1 NEXT SEP "," ->
1429           <:expr< ( $list:[e :: el]$ ) >> ]
1430     | ":=" NONA
1431       [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" ->
1432           <:expr< $e1$.val := $e2$ >>
1433       | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" ->
1434           match bigarray_set loc e1 e2 with
1435           [ Some e -> e
1436           | None -> <:expr< $e1$ := $e2$ >> ] ]
1437     | "||" RIGHTA
1438       [ e1 = SELF; "or"; e2 = SELF -> <:expr< $lid:"or"$ $e1$ $e2$ >>
1439       | e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ]
1440     | "&&" RIGHTA
1441       [ e1 = SELF; "&"; e2 = SELF -> <:expr< $lid:"&"$ $e1$ $e2$ >>
1442       | e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ]
1443     | "<" LEFTA
1444       [ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >>
1445       | e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >>
1446       | e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >>
1447       | e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >>
1448       | e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >>
1449       | e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >>
1450       | e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >>
1451       | e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >>
1452       | e1 = SELF; "$"; e2 = SELF -> <:expr< $lid:"\$"$ $e1$ $e2$ >>
1453       | e1 = SELF; op = infixop0; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
1454     | "^" RIGHTA
1455       [ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >>
1456       | e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >>
1457       | e1 = SELF; op = infixop1; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
1458     | RIGHTA
1459       [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ]
1460     | "+" LEFTA
1461       [ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >>
1462       | e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >>
1463       | e1 = SELF; op = infixop2; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
1464     | "*" LEFTA
1465       [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >>
1466       | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >>
1467       | e1 = SELF; "%"; e2 = SELF -> <:expr< $lid:"%"$ $e1$ $e2$ >>
1468       | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >>
1469       | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >>
1470       | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >>
1471       | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >>
1472       | e1 = SELF; op = infixop3; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
1473     | "**" RIGHTA
1474       [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >>
1475       | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >>
1476       | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >>
1477       | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >>
1478       | e1 = SELF; op = infixop4; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
1479     | "unary minus" NONA
1480       [ "-"; e = SELF -> <:expr< $mkumin loc "-" e$ >>
1481       | "-."; e = SELF -> <:expr< $mkumin loc "-." e$ >> ]
1482     | "apply" LEFTA
1483       [ e1 = SELF; e2 = SELF ->
1484           match constr_expr_arity loc e1 with
1485           [ 1 -> <:expr< $e1$ $e2$ >>
1486           | _ ->
1487               match e2 with
1488               [ <:expr< ( $list:el$ ) >> ->
1489                   List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el
1490               | _ -> <:expr< $e1$ $e2$ >> ] ]
1491       | "assert"; e = SELF ->
1492           match e with
1493           [ <:expr< False >> -> <:expr< assert False >>
1494           | _ -> <:expr< assert ($e$) >> ]
1495       | "lazy"; e = SELF ->
1496           <:expr< lazy ($e$) >> ]
1497     | "." LEFTA
1498       [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >>
1499       | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >>
1500       | e1 = SELF; "."; "{"; e2 = SELF; "}" -> bigarray_get loc e1 e2
1501       | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ]
1502     | "~-" NONA
1503       [ "!"; e = SELF -> <:expr< $e$ . val>>
1504       | "~-"; e = SELF -> <:expr< ~- $e$ >>
1505       | "~-."; e = SELF -> <:expr< ~-. $e$ >>
1506       | f = prefixop; e = SELF -> <:expr< $lid:f$ $e$ >> ]
1507     | "simple" LEFTA
1508       [ s = INT -> <:expr< $int:s$ >>
1509       | s = INT32 -> MLast.ExInt32 loc s
1510       | s = INT64 -> MLast.ExInt64 loc s
1511       | s = NATIVEINT -> MLast.ExNativeInt loc s
1512       | s = FLOAT -> <:expr< $flo:s$ >>
1513       | s = STRING -> <:expr< $str:s$ >>
1514       | c = CHAR -> <:expr< $chr:c$ >>
1515       | UIDENT "True" -> <:expr< $uid:" True"$ >>
1516       | UIDENT "False" -> <:expr< $uid:" False"$ >>
1517       | i = expr_ident -> i
1518       | s = "false" -> <:expr< False >>
1519       | s = "true" -> <:expr< True >>
1520       | "["; "]" -> <:expr< [] >>
1521       | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >>
1522       | "[|"; "|]" -> <:expr< [| |] >>
1523       | "[|"; el = expr1_semi_list; "|]" -> <:expr< [| $list:el$ |] >>
1524       | "{"; test_label_eq; lel = lbl_expr_list; "}" ->
1525           <:expr< { $list:lel$ } >>
1526       | "{"; e = expr LEVEL "."; "with"; lel = lbl_expr_list; "}" ->
1527           <:expr< { ($e$) with $list:lel$ } >>
1528       | "("; ")" -> <:expr< () >>
1529       | "("; op = operator_rparen -> <:expr< $lid:op$ >>
1530       | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >>
1531       | "("; e = SELF; ")" -> <:expr< $e$ >>
1532       | "begin"; e = SELF; "end" -> <:expr< $e$ >>
1533       | "begin"; "end" -> <:expr< () >>
1534       | x = LOCATE ->
1535           let x =
1536             try
1537               let i = String.index x ':' in
1538               ({Lexing.pos_fname = "";
1539                 Lexing.pos_lnum = 0;
1540                 Lexing.pos_bol = 0;
1541                 Lexing.pos_cnum = int_of_string (String.sub x 0 i)},
1542                String.sub x (i + 1) (String.length x - i - 1))
1543             with
1544             [ Not_found | Failure _ -> (Token.nowhere, x) ]
1545           in
1546           Pcaml.handle_expr_locate loc x
1547       | x = QUOTATION ->
1548           let x =
1549             try
1550               let i = String.index x ':' in
1551               (String.sub x 0 i,
1552                String.sub x (i + 1) (String.length x - i - 1))
1553             with
1554             [ Not_found -> ("", x) ]
1555           in
1556           Pcaml.handle_expr_quotation loc x ] ]
1557   ;
1558   let_binding:
1559     [ [ p = patt; e = fun_binding ->
1560           match patt_lid p with
1561           [ Some (loc, i, pl) ->
1562               let e =
1563                 List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl
1564               in
1565               (<:patt< $lid:i$ >>, e)
1566           | None -> (p, e) ] ] ]
1567   ;
1568   fun_binding:
1569     [ RIGHTA
1570       [ p = simple_patt; e = SELF -> <:expr< fun $p$ -> $e$ >>
1571       | "="; e = expr -> <:expr< $e$ >>
1572       | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ]
1573   ;
1574   match_case:
1575     [ [ x1 = patt; w = OPT [ "when"; e = expr -> e ]; "->"; x2 = expr ->
1576           (x1, w, x2) ] ]
1577   ;
1578   lbl_expr_list:
1579     [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel]
1580       | le = lbl_expr; ";" -> [le]
1581       | le = lbl_expr -> [le] ] ]
1582   ;
1583   lbl_expr:
1584     [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ]
1585   ;
1586   expr1_semi_list:
1587     [ [ e = expr LEVEL "expr1"; ";"; el = SELF -> [e :: el]
1588       | e = expr LEVEL "expr1"; ";" -> [e]
1589       | e = expr LEVEL "expr1" -> [e] ] ]
1590   ;
1591   fun_def:
1592     [ RIGHTA
1593       [ p = simple_patt; e = SELF -> <:expr< fun $p$ -> $e$ >>
1594       | "->"; e = expr -> <:expr< $e$ >> ] ]
1595   ;
1596   expr_ident:
1597     [ RIGHTA
1598       [ i = LIDENT -> <:expr< $lid:i$ >>
1599       | i = UIDENT -> <:expr< $uid:i$ >>
1600       | i = UIDENT; "."; j = SELF ->
1601           let rec loop m =
1602             fun
1603             [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
1604             | e -> <:expr< $m$ . $e$ >> ]
1605           in
1606           loop <:expr< $uid:i$ >> j
1607       | i = UIDENT; "."; "("; j = operator_rparen ->
1608           <:expr< $uid:i$ . $lid:j$ >> ] ]
1609   ;
1610   (* Patterns *)
1611   patt:
1612     [ LEFTA
1613       [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ]
1614     | LEFTA
1615       [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ]
1616     | [ p = SELF; ","; pl = LIST1 NEXT SEP "," ->
1617           <:patt< ( $list:[p :: pl]$) >> ]
1618     | NONA
1619       [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ]
1620     | RIGHTA
1621       [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ]
1622     | LEFTA
1623       [ p1 = SELF; p2 = SELF ->
1624           match constr_patt_arity loc p1 with
1625           [ 1 -> <:patt< $p1$ $p2$ >>
1626           | n ->
1627               let p2 =
1628                 match p2 with
1629                 [ <:patt< _ >> when n > 1 ->
1630                     let pl =
1631                       loop n where rec loop n =
1632                         if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)]
1633                     in
1634                     <:patt< ( $list:pl$ ) >>
1635                 | _ -> p2 ]
1636               in
1637               match p2 with
1638               [ <:patt< ( $list:pl$ ) >> ->
1639                   List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl
1640               | _ -> <:patt< $p1$ $p2$ >> ] ] ]
1641     | LEFTA
1642       [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
1643     | "simple"
1644       [ p = simple_patt -> p ] ]
1645   ;
1646
1647   simple_patt:
1648     [ [ s = LIDENT -> <:patt< $lid:s$ >>
1649       | s = UIDENT -> <:patt< $uid:s$ >>
1650       | s = INT -> <:patt< $int:s$ >>
1651       | s = INT32 -> MLast.PaInt32 loc s
1652       | s = INT64 -> MLast.PaInt64 loc s
1653       | s = NATIVEINT -> MLast.PaNativeInt loc s
1654       | "-"; s = INT -> <:patt< $int:"-" ^ s$ >>
1655       | "-"; s = INT32 -> MLast.PaInt32 loc ("-" ^ s)
1656       | "-"; s = INT64 -> MLast.PaInt64 loc ("-" ^ s)
1657       | "-"; s = NATIVEINT -> MLast.PaNativeInt loc ("-" ^ s)
1658       | "-"; s = FLOAT -> <:patt< $flo:"-" ^ s$ >>
1659       | s = FLOAT -> <:patt< $flo:s$ >>
1660       | s = STRING -> <:patt< $str:s$ >>
1661       | s = CHAR -> <:patt< $chr:s$ >>
1662       | UIDENT "True" -> <:patt< $uid:" True"$ >>
1663       | UIDENT "False" -> <:patt< $uid:" False"$ >>
1664       | s = "false" -> <:patt< False >>
1665       | s = "true" -> <:patt< True >>
1666       | "["; "]" -> <:patt< [] >>
1667       | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >>
1668       | "[|"; "|]" -> <:patt< [| |] >>
1669       | "[|"; pl = patt_semi_list; "|]" -> <:patt< [| $list:pl$ |] >>
1670       | "{"; lpl = lbl_patt_list; "}" -> <:patt< { $list:lpl$ } >>
1671       | "("; ")" -> <:patt< () >>
1672       | "("; op = operator_rparen -> <:patt< $lid:op$ >>
1673       | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
1674       | "("; p = patt; ")" -> <:patt< $p$ >>
1675       | "_" -> <:patt< _ >>
1676       | "`"; s = ident -> <:patt< ` $s$ >>
1677       | "#"; t = mod_ident -> <:patt< # $list:t$ >>
1678       | x = LOCATE ->
1679           let x =
1680             try
1681               let i = String.index x ':' in
1682               ({Lexing.pos_fname = "";
1683                 Lexing.pos_lnum = 0;
1684                 Lexing.pos_bol = 0;
1685                 Lexing.pos_cnum = int_of_string (String.sub x 0 i)},
1686                String.sub x (i + 1) (String.length x - i - 1))
1687             with
1688             [ Not_found | Failure _ -> (Token.nowhere, x) ]
1689           in
1690           Pcaml.handle_patt_locate loc x
1691       | x = QUOTATION ->
1692           let x =
1693             try
1694               let i = String.index x ':' in
1695               (String.sub x 0 i,
1696                String.sub x (i + 1) (String.length x - i - 1))
1697             with
1698             [ Not_found -> ("", x) ]
1699           in
1700           Pcaml.handle_patt_quotation loc x ] ]
1701   ;
1702
1703   patt_semi_list:
1704     [ [ p = patt; ";"; pl = SELF -> [p :: pl]
1705       | p = patt; ";" -> [p]
1706       | p = patt -> [p] ] ]
1707   ;
1708   lbl_patt_list:
1709     [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel]
1710       | le = lbl_patt; ";" -> [le]
1711       | le = lbl_patt -> [le] ] ]
1712   ;
1713   lbl_patt:
1714     [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ]
1715   ;
1716   patt_label_ident:
1717     [ LEFTA
1718       [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
1719     | RIGHTA
1720       [ i = UIDENT -> <:patt< $uid:i$ >>
1721       | i = LIDENT -> <:patt< $lid:i$ >> ] ]
1722   ;
1723   (* Type declaration *)
1724   type_declaration:
1725     [ [ tpl = type_parameters; n = type_patt; "="; tk = type_kind;
1726         cl = LIST0 constrain ->
1727           (n, tpl, tk, cl)
1728       | tpl = type_parameters; n = type_patt; cl = LIST0 constrain ->
1729           (n, tpl, <:ctyp< '$choose_tvar tpl$ >>, cl) ] ]
1730   ;
1731   type_patt:
1732     [ [ n = LIDENT -> (loc, n) ] ]
1733   ;
1734   constrain:
1735     [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ]
1736   ;
1737   type_kind:
1738     [ [ "private"; "{"; ldl = label_declarations; "}" ->
1739           <:ctyp< private { $list:ldl$ } >>
1740       | "private"; OPT "|";
1741         cdl = LIST1 constructor_declaration SEP "|" -> <:ctyp< private [ $list:cdl$ ] >>
1742       | test_constr_decl; OPT "|";
1743         cdl = LIST1 constructor_declaration SEP "|" -> <:ctyp< [ $list:cdl$ ] >>
1744       | t = ctyp -> <:ctyp< $t$ >>
1745       | t = ctyp; "="; "private"; "{"; ldl = label_declarations; "}" ->
1746           <:ctyp< $t$ == private { $list:ldl$ } >>
1747       | t = ctyp; "="; "{"; ldl = label_declarations; "}" ->
1748           <:ctyp< $t$ == { $list:ldl$ } >>
1749       | t = ctyp; "="; "private"; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" ->
1750           <:ctyp< $t$ == private [ $list:cdl$ ] >>
1751       | t = ctyp; "="; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" ->
1752           <:ctyp< $t$ == [ $list:cdl$ ] >>
1753       | "{"; ldl = label_declarations; "}" ->
1754           <:ctyp< { $list:ldl$ } >> ] ]
1755   ;
1756   type_parameters:
1757     [ [ -> (* empty *) []
1758       | tp = type_parameter -> [tp]
1759       | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ]
1760   ;
1761   type_parameter:
1762     [ [ "'"; i = ident -> (i, (False, False))
1763       | "+"; "'"; i = ident -> (i, (True, False))
1764       | "-"; "'"; i = ident -> (i, (False, True)) ] ]
1765   ;
1766   constructor_declaration:
1767     [ [ ci = UIDENT; "of"; cal = LIST1 ctyp LEVEL "ctyp1" SEP "*" ->
1768           (loc, ci, cal)
1769       | ci = UIDENT -> (loc, ci, []) ] ]
1770   ;
1771   label_declarations:
1772     [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl]
1773       | ld = label_declaration; ";" -> [ld]
1774       | ld = label_declaration -> [ld] ] ]
1775   ;
1776   label_declaration:
1777     [ [ i = LIDENT; ":"; t = poly_type -> (loc, i, False, t)
1778       | "mutable"; i = LIDENT; ":"; t = poly_type -> (loc, i, True, t) ] ]
1779   ;
1780   (* Core types *)
1781   ctyp:
1782     [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ]
1783     | "arrow" RIGHTA
1784       [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ]
1785     | "star"
1786       [ t = SELF; "*"; tl = LIST1 (ctyp LEVEL "ctyp1") SEP "*" ->
1787           <:ctyp< ( $list:[t :: tl]$ ) >> ]
1788     | "ctyp1"
1789       [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ]
1790     | "ctyp2"
1791       [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >>
1792       | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ]
1793     | "simple"
1794       [ "'"; i = ident -> <:ctyp< '$i$ >>
1795       | "_" -> <:ctyp< _ >>
1796       | i = LIDENT -> <:ctyp< $lid:i$ >>
1797       | i = UIDENT -> <:ctyp< $uid:i$ >>
1798       | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")";
1799         i = ctyp LEVEL "ctyp2" ->
1800           List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl]
1801       | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ]
1802   ;
1803   (* Identifiers *)
1804   ident:
1805     [ [ i = LIDENT -> i
1806       | i = UIDENT -> i ] ]
1807   ;
1808   mod_ident:
1809     [ RIGHTA
1810       [ i = UIDENT -> [i]
1811       | i = LIDENT -> [i]
1812       | i = UIDENT; "."; j = SELF -> [i :: j] ] ]
1813   ;
1814   (* Miscellaneous *)
1815   direction_flag:
1816     [ [ "to" -> True
1817       | "downto" -> False ] ]
1818   ;
1819   (* Objects and Classes *)
1820   str_item:
1821     [ [ "class"; cd = LIST1 class_declaration SEP "and" ->
1822           <:str_item< class $list:cd$ >>
1823       | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" ->
1824           <:str_item< class type $list:ctd$ >> ] ]
1825   ;
1826   sig_item:
1827     [ [ "class"; cd = LIST1 class_description SEP "and" ->
1828           <:sig_item< class $list:cd$ >>
1829       | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" ->
1830           <:sig_item< class type $list:ctd$ >> ] ]
1831   ;
1832   (* Class expressions *)
1833   class_declaration:
1834     [ [ vf = OPT "virtual"; ctp = class_type_parameters; i = LIDENT;
1835         cfb = class_fun_binding ->
1836           {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
1837            MLast.ciNam = i; MLast.ciExp = cfb} ] ]
1838   ;
1839   class_fun_binding:
1840     [ [ "="; ce = class_expr -> ce
1841       | ":"; ct = class_type; "="; ce = class_expr ->
1842           <:class_expr< ($ce$ : $ct$) >>
1843       | p = simple_patt; cfb = SELF ->
1844           <:class_expr< fun $p$ -> $cfb$ >> ] ]
1845   ;
1846   class_type_parameters:
1847     [ [ -> (loc, [])
1848       | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ]
1849   ;
1850   class_fun_def:
1851     [ [ p = simple_patt; "->"; ce = class_expr ->
1852           <:class_expr< fun $p$ -> $ce$ >>
1853       | p = labeled_patt; "->"; ce = class_expr ->
1854           <:class_expr< fun $p$ -> $ce$ >>
1855       | p = simple_patt; cfd = SELF ->
1856           <:class_expr< fun $p$ -> $cfd$ >>
1857       | p = labeled_patt; cfd = SELF ->
1858           <:class_expr< fun $p$ -> $cfd$ >> ] ]
1859   ;
1860   class_expr:
1861     [ "top"
1862       [ "fun"; cfd = class_fun_def -> cfd
1863       | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in";
1864         ce = SELF ->
1865           <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ]
1866     | "apply" LEFTA
1867       [ ce = SELF; e = expr LEVEL "label" ->
1868           <:class_expr< $ce$ $e$ >> ]
1869     | "simple"
1870       [ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]";
1871         ci = class_longident ->
1872           <:class_expr< $list:ci$ [ $list:[ct :: ctcl]$ ] >>
1873       | "["; ct = ctyp; "]"; ci = class_longident ->
1874           <:class_expr< $list:ci$ [ $ct$ ] >>
1875       | ci = class_longident -> <:class_expr< $list:ci$ >>
1876       | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" ->
1877           <:class_expr< object $opt:cspo$ $list:cf$ end >>
1878       | "("; ce = SELF; ":"; ct = class_type; ")" ->
1879           <:class_expr< ($ce$ : $ct$) >>
1880       | "("; ce = SELF; ")" -> ce ] ]
1881   ;
1882   class_structure:
1883     [ [ cf = LIST0 class_str_item -> cf ] ]
1884   ;
1885   class_self_patt:
1886     [ [ "("; p = patt; ")" -> p
1887       | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ]
1888   ;
1889   class_str_item:
1890     [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] ->
1891           <:class_str_item< inherit $ce$ $opt:pb$ >>
1892       | "val"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
1893           <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
1894       | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
1895           <:class_str_item< method virtual private $l$ : $t$ >>
1896       | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
1897           <:class_str_item< method virtual private $l$ : $t$ >>
1898       | "method"; "virtual"; l = label; ":"; t = poly_type ->
1899           <:class_str_item< method virtual $l$ : $t$ >>
1900       | "method"; "private"; l = label; ":"; t = poly_type; "="; e = expr ->
1901           MLast.CrMth loc l True e (Some t)
1902       | "method"; "private"; l = label; sb = fun_binding ->
1903           MLast.CrMth loc l True sb None
1904       | "method"; l = label; ":"; t = poly_type; "="; e = expr ->
1905           MLast.CrMth loc l False e (Some t)
1906       | "method"; l = label; sb = fun_binding ->
1907           MLast.CrMth loc l False sb None
1908       | "constraint"; t1 = ctyp; "="; t2 = ctyp ->
1909           <:class_str_item< type $t1$ = $t2$ >>
1910       | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ]
1911   ;
1912   cvalue_binding:
1913     [ [ "="; e = expr -> e
1914       | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >>
1915       | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr ->
1916           <:expr< ($e$ : $t$ :> $t2$) >>
1917       | ":>"; t = ctyp; "="; e = expr ->
1918           <:expr< ($e$ :> $t$) >> ] ]
1919   ;
1920   label:
1921     [ [ i = LIDENT -> i ] ]
1922   ;
1923   (* Class types *)
1924   class_type:
1925     [ [ test_ctyp_minusgreater; t = ctyp LEVEL "star"; "->"; ct = SELF ->
1926           <:class_type< [ $t$ ] -> $ct$ >>
1927       | cs = class_signature -> cs ] ]
1928   ;
1929   class_signature:
1930     [ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = clty_longident ->
1931           <:class_type< $list:id$ [ $list:tl$ ] >>
1932       | id = clty_longident -> <:class_type< $list:id$ >>
1933       | "object"; cst = OPT class_self_type; csf = LIST0 class_sig_item;
1934         "end" ->
1935           <:class_type< object $opt:cst$ $list:csf$ end >> ] ]
1936   ;
1937   class_self_type:
1938     [ [ "("; t = ctyp; ")" -> t ] ]
1939   ;
1940   class_sig_item:
1941     [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >>
1942       | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
1943           <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
1944       | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
1945           <:class_sig_item< method virtual private $l$ : $t$ >>
1946       | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
1947           <:class_sig_item< method virtual private $l$ : $t$ >>
1948       | "method"; "virtual"; l = label; ":"; t = poly_type ->
1949           <:class_sig_item< method virtual $l$ : $t$ >>
1950       | "method"; "private"; l = label; ":"; t = poly_type ->
1951           <:class_sig_item< method private $l$ : $t$ >>
1952       | "method"; l = label; ":"; t = poly_type ->
1953           <:class_sig_item< method $l$ : $t$ >>
1954       | "constraint"; t1 = ctyp; "="; t2 = ctyp ->
1955           <:class_sig_item< type $t1$ = $t2$ >> ] ]
1956   ;
1957   class_description:
1958     [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; ":";
1959         ct = class_type ->
1960           {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
1961            MLast.ciNam = n; MLast.ciExp = ct} ] ]
1962   ;
1963   class_type_declaration:
1964     [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; "=";
1965         cs = class_signature ->
1966           {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
1967            MLast.ciNam = n; MLast.ciExp = cs} ] ]
1968   ;
1969   (* Expressions *)
1970   expr: LEVEL "simple"
1971     [ LEFTA
1972       [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ]
1973   ;
1974   expr: LEVEL "."
1975     [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ]
1976   ;
1977   expr: LEVEL "simple"
1978     [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" ->
1979           <:expr< ($e$ : $t$ :> $t2$) >>
1980       | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >>
1981       | "{<"; ">}" -> <:expr< {< >} >>
1982       | "{<"; fel = field_expr_list; ">}" -> <:expr< {< $list:fel$ >} >> ] ]
1983   ;
1984   field_expr_list:
1985     [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF ->
1986           [(l, e) :: fel]
1987       | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)]
1988       | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ]
1989   ;
1990   (* Core types *)
1991   ctyp: LEVEL "simple"
1992     [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >>
1993       | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >>
1994       | "<"; ">" -> <:ctyp< < > >> ] ]
1995   ;
1996   meth_list:
1997     [ [ f = field; ";"; (ml, v) = SELF -> ([f :: ml], v)
1998       | f = field; ";" -> ([f], False)
1999       | f = field -> ([f], False)
2000       | ".." -> ([], True) ] ]
2001   ;
2002   field:
2003     [ [ lab = LIDENT; ":"; t = poly_type -> (lab, t) ] ]
2004   ;
2005   (* Polymorphic types *)
2006   typevar:
2007     [ [ "'"; i = ident -> i ] ]
2008   ;
2009   poly_type:
2010     [ [ test_typevar_list_dot; tpl = LIST1 typevar; "."; t2 = ctyp ->
2011           <:ctyp< ! $list:tpl$ . $t2$ >>
2012       | t = ctyp -> t ] ]
2013   ;
2014   (* Identifiers *)
2015   clty_longident:
2016     [ [ m = UIDENT; "."; l = SELF -> [m :: l]
2017       | i = LIDENT -> [i] ] ]
2018   ;
2019   class_longident:
2020     [ [ m = UIDENT; "."; l = SELF -> [m :: l]
2021       | i = LIDENT -> [i] ] ]
2022   ;
2023   (* Labels *)
2024   ctyp: LEVEL "arrow"
2025     [ RIGHTA
2026       [ i = lident_colon; t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
2027           <:ctyp< ( ~ $i$ : $t1$ ) -> $t2$ >>
2028       | i = OPTLABEL; t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
2029           <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >>
2030       | i = QUESTIONIDENT; ":"; t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
2031           <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >>
2032       | "?"; i=lident_colon;t1 = ctyp LEVEL "star"; "->"; t2 = SELF ->
2033           <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> ] ]
2034   ;
2035   ctyp: LEVEL "simple"
2036     [ [ "["; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" ->
2037           <:ctyp< [ = $list:rfl$ ] >>
2038       | "["; ">"; "]" -> <:ctyp< [ > $list:[]$ ] >>
2039       | "["; ">"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" ->
2040           <:ctyp< [ > $list:rfl$ ] >>
2041       | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" ->
2042           <:ctyp< [ < $list:rfl$ ] >>
2043       | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; ">";
2044         ntl = LIST1 name_tag; "]" ->
2045           <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ]
2046   ;
2047   row_field:
2048     [ [ "`"; i = ident -> MLast.RfTag i True []
2049       | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" ->
2050           MLast.RfTag i (o2b ao) l
2051       | t = ctyp -> MLast.RfInh t ] ]
2052   ;
2053   name_tag:
2054     [ [ "`"; i = ident -> i ] ]
2055   ;
2056   expr: LEVEL "expr1"
2057     [ [ "fun"; p = labeled_patt; e = fun_def -> <:expr< fun $p$ -> $e$ >> ] ]
2058   ;
2059   expr: AFTER "apply"
2060     [ "label"
2061       [ i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >>
2062       | i = TILDEIDENT -> <:expr< ~ $i$ >>
2063       | "~"; i = LIDENT -> <:expr< ~ $i$ >>
2064       | i = OPTLABEL; e = SELF -> <:expr< ? $i$ : $e$ >>
2065       | i = QUESTIONIDENT -> <:expr< ? $i$ >>
2066       | "?"; i = LIDENT -> <:expr< ? $i$ >> ] ]
2067   ;
2068   expr: LEVEL "simple"
2069     [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ]
2070   ;
2071   fun_def:
2072     [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ]
2073   ;
2074   fun_binding:
2075     [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ]
2076   ;
2077   labeled_patt:
2078     [ [ i = LABEL; p = simple_patt ->
2079            <:patt< ~ $i$ : $p$ >>
2080       | i = TILDEIDENT ->
2081            <:patt< ~ $i$ >>
2082       | "~"; i=LIDENT -> <:patt< ~ $i$ >>
2083       | "~"; "("; i = LIDENT; ")" ->
2084            <:patt< ~ $i$ >>
2085       | "~"; "("; i = LIDENT; ":"; t = ctyp; ")" ->
2086            <:patt< ~ $i$ : ($lid:i$ : $t$) >>
2087       | i = OPTLABEL; j = LIDENT ->
2088            <:patt< ? $i$ : ($lid:j$) >>
2089       | i = OPTLABEL; "("; p = patt; "="; e = expr; ")" ->
2090           <:patt< ? $i$ : ( $p$ = $e$ ) >>
2091       | i = OPTLABEL; "("; p = patt; ":"; t = ctyp; ")" ->
2092           <:patt< ? $i$ : ( $p$ : $t$ ) >>
2093       | i = OPTLABEL; "("; p = patt; ":"; t = ctyp; "=";
2094         e = expr; ")" ->
2095           <:patt< ? $i$ : ( $p$ : $t$ = $e$ ) >>
2096       | i = QUESTIONIDENT -> <:patt< ? $i$ >>
2097       | "?"; i = LIDENT -> <:patt< ? $i$ >>
2098       | "?"; "("; i = LIDENT; "="; e = expr; ")" ->
2099           <:patt< ? ( $lid:i$ = $e$ ) >>
2100       | "?"; "("; i = LIDENT; ":"; t = ctyp; "="; e = expr; ")" ->
2101           <:patt< ? ( $lid:i$ : $t$ = $e$ ) >>
2102       | "?"; "("; i = LIDENT; ")" ->
2103           <:patt< ? $i$ >>
2104       | "?"; "("; i = LIDENT; ":"; t = ctyp; ")" ->
2105           <:patt< ? ( $lid:i$ : $t$ ) >> ] ]
2106   ;
2107   class_type:
2108     [ [ i = lident_colon; t = ctyp LEVEL "star"; "->"; ct = SELF ->
2109           <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >>
2110       | i = OPTLABEL; t = ctyp LEVEL "star"; "->"; ct = SELF ->
2111           <:class_type< [ ? $i$ : $t$ ] -> $ct$ >>
2112       | i = QUESTIONIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF ->
2113           <:class_type< [ ? $i$ : $t$ ] -> $ct$ >>
2114       | "?"; i = LIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF ->
2115           <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> ] ]
2116   ;
2117   class_fun_binding:
2118     [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ]
2119   ;
2120 END;
2121
2122 (* Main entry points *)
2123
2124 EXTEND
2125   GLOBAL: interf implem use_file top_phrase expr patt;
2126   interf:
2127     [ [ si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
2128       | "#"; n = LIDENT; dp = OPT expr; ";;" ->
2129           ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True)
2130       | EOI -> ([], False) ] ]
2131   ;
2132   sig_item_semi:
2133     [ [ si = sig_item; OPT ";;" -> (si, loc) ] ]
2134   ;
2135   implem:
2136     [ [ si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
2137       | "#"; n = LIDENT; dp = OPT expr; ";;" ->
2138           ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True)
2139       | EOI -> ([], False) ] ]
2140   ;
2141   str_item_semi:
2142     [ [ si = str_item; OPT ";;" -> (si, loc) ] ]
2143   ;
2144   top_phrase:
2145     [ [ ph = phrase; ";;" -> Some ph
2146       | EOI -> None ] ]
2147   ;
2148   use_file:
2149     [ [ si = str_item; OPT ";;"; (sil, stopped) = SELF ->
2150           ([si :: sil], stopped)
2151       | "#"; n = LIDENT; dp = OPT expr; ";;" ->
2152           ([<:str_item< # $n$ $opt:dp$ >>], True)
2153       | EOI -> ([], False) ] ]
2154   ;
2155   phrase:
2156     [ [ sti = str_item -> sti
2157       | "#"; n = LIDENT; dp = OPT expr -> <:str_item< # $n$ $opt:dp$ >> ] ]
2158   ;
2159 END;
2160
2161 Pcaml.add_option "-no_quot" (Arg.Set Plexer.no_quotations)
2162   "Don't parse quotations, allowing to use, e.g. \"<:>\" as token";
2163
2164 EXTEND
2165   expr: AFTER "<"
2166    [[ f = expr; "o"; g = expr -> <:expr< ((o $f$) $g$) >>
2167     | f = expr; "upto"; g = expr -> <:expr< ((upto $f$) $g$) >>
2168     | f = expr; "F_F"; g = expr -> <:expr< ((f_f_ $f$) $g$) >>
2169     | f = expr; "THENC"; g = expr -> <:expr< ((thenc_ $f$) $g$) >>
2170     | f = expr; "THEN"; g = expr -> <:expr< ((then_ $f$) $g$) >>
2171     | f = expr; "THENL"; g = expr -> <:expr< ((thenl_ $f$) $g$) >>
2172     | f = expr; "ORELSE"; g = expr -> <:expr< ((orelse_ $f$) $g$) >>
2173     | f = expr; "ORELSEC"; g = expr -> <:expr< ((orelsec_ $f$) $g$) >>
2174     | f = expr; "THEN_TCL"; g = expr -> <:expr< ((then_tcl_ $f$) $g$) >>
2175     | f = expr; "ORELSE_TCL"; g = expr -> <:expr< ((orelse_tcl_ $f$) $g$) >>
2176 ]];
2177 END;
2178
2179 EXTEND
2180   top_phrase:
2181    [ [ sti = str_item; ";;" ->
2182          match sti with
2183          [ <:str_item< $exp:e$ >> -> Some <:str_item< value it = $e$ >>
2184          | x -> Some x ] ] ]
2185   ;
2186 END;