pa_j_3.1x_5.xx.ml

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