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