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