(* $Id: pa_cl.ml,v 1.18 2002-02-18 18:28:03 ddr Exp $ *)

(* Caml Light syntax. Restrictions:
      1/ constructors must start with an uppercase letter
      2/ variables must start with an lowercase letter
      3/ no mutable constructors *)

#load "pa_extend.cmo";
#load "q_MLast.cmo";

open Stdpp;
open Pcaml;

module Plexer =
  struct
    open Stdpp;
    open Token;
    (* The string buffering machinery *)
    value buff = ref (String.create 80);
    value store len x =
      do {
        if len >= String.length buff.val then
          buff.val := buff.val ^ String.create (String.length buff.val)
        else ();
        buff.val.[len] := x;
        succ len
      }
    ;
    value mstore len s =
      add_rec len 0 where rec add_rec len i =
        if i == String.length s then len
        else add_rec (store len s.[i]) (succ i)
    ;
    value get_buff len = String.sub buff.val 0 len;
    (* The lexer *)
    value rec ident len =
      parser
      [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
             '\248'..'\255' | '0'..'9' | '_' | ''' as
             c)
            ;
           s :] ->
          ident (store len c) s
      | [: :] -> len ]
    and ident2 len =
      parser
      [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
             '%' | '.' | ':' | '<' | '>' | '|' | '$' as
             c)
            ;
           s :] ->
          ident2 (store len c) s
      | [: :] -> len ]
    and ident3 len =
      parser
      [ [: `('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' |
             '\216'..'\246' | '\248'..'\255' | '_' | '!' | '%' | '&' | '*' |
             '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' |
             '|' | '~' | ''' | '$' as
             c)
            ;
           s :] ->
          ident3 (store len c) s
      | [: :] -> len ]
    and base_number len =
      parser
      [ [: `'o' | 'O'; s :] -> octal_digits (store len 'o') s
      | [: `'x' | 'X'; s :] -> hexa_digits (store len 'x') s
      | [: `'b' | 'B'; s :] -> binary_digits (store len 'b') s
      | [: a = number len :] -> a ]
    and octal_digits len =
      parser
      [ [: `('0'..'7' as d); s :] -> octal_digits (store len d) s
      | [: :] -> ("INT", get_buff len) ]
    and hexa_digits len =
      parser
      [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d); s :] ->
          hexa_digits (store len d) s
      | [: :] -> ("INT", get_buff len) ]
    and binary_digits len =
      parser
      [ [: `('0'..'1' as d); s :] -> binary_digits (store len d) s
      | [: :] -> ("INT", get_buff len) ]
    and number len =
      parser
      [ [: `('0'..'9' as c); s :] -> number (store len c) s
      | [: `'.'; s :] -> decimal_part (store len '.') s
      | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
      | [: :] -> ("INT", get_buff len) ]
    and decimal_part len =
      parser
      [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s
      | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
      | [: :] -> ("FLOAT", get_buff len) ]
    and exponent_part len =
      parser
      [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s
      | [: a = end_exponent_part len :] -> a ]
    and end_exponent_part len =
      parser
      [ [: `('0'..'9' as c); s :] -> end_exponent_part (store len c) s
      | [: :] -> ("FLOAT", get_buff len) ]
    ;
    value rec skip_spaces =
      parser
      [ [: `' ' | '\010' | '\013' | '\t' | '\026' | '\012'; s :] ->
          skip_spaces s
      | [: :] -> () ]
    ;
    value error_on_unknown_keywords = ref False;
    value err loc msg = raise_with_loc loc (Token.Error msg);
    value next_token_fun dfa find_kwd =
      let keyword_or_error loc s =
        try (("", find_kwd s), loc) with
        [ Not_found ->
            if error_on_unknown_keywords.val then
              err loc ("illegal token: " ^ s)
            else (("", s), loc) ]
      in
      let rec next_token =
        parser bp
        [ [: `' ' | '\010' | '\013' | '\t' | '\026' | '\012'; s :] ->
            next_token s
        | [: `'('; s :] -> left_paren bp s
        | [: `'#'; s :] -> do { spaces_tabs s; linenum bp s }
        | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] ->
            let id = get_buff (ident (store 0 c) s) in
            let loc = (bp, Stream.count s) in
            (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc)
        | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' as c); s :] ->
            let id = get_buff (ident (store 0 c) s) in
            let loc = (bp, Stream.count s) in
            try (("", find_kwd id), loc) with
            [ Not_found -> (("LIDENT", id), loc) ]
        | [: `('1'..'9' as c); s :] ->
            let tok = number (store 0 c) s in
            let loc = (bp, Stream.count s) in
            (tok, loc)
        | [: `'0'; s :] ->
            let tok = base_number (store 0 '0') s in
            let loc = (bp, Stream.count s) in
            (tok, loc)
        | [: `'`'; s :] ->
            let tok = ("CHAR", char bp 0 s) in
            let loc = (bp, Stream.count s) in
            (tok, loc)
        | [: `'"'; s :] ->
            let tok = ("STRING", string bp 0 s) in
            let loc = (bp, Stream.count s) in
            (tok, loc)
        | [: `'$'; s :] ->
            let tok = dollar bp 0 s in
            let loc = (bp, Stream.count s) in
            (tok, loc)
        | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c)
              ;
             s :] ->
            let id = get_buff (ident2 (store 0 c) s) in
            keyword_or_error (bp, Stream.count s) id
        | [: `('~' as c);
             a =
               parser
               [ [: `('a'..'z' as c); len = ident (store 0 c);
                    t =
                      parser
                      [ [: `':' :] -> "TILDEIDENTCOLON"
                      | [: :] -> "TILDEIDENT" ] :] ep ->
                   ((t, get_buff len), (bp, ep))
               | [: s :] ->
                   let id = get_buff (ident2 (store 0 c) s) in
                   keyword_or_error (bp, Stream.count s) id ] :] ->
            a
        | [: `('?' as c);
             a =
               parser
               [ [: `('a'..'z' as c); len = ident (store 0 c);
                    t =
                      parser
                      [ [: `':' :] -> "QUESTIONIDENTCOLON"
                      | [: :] -> "QUESTIONIDENT" ] :] ep ->
                   ((t, get_buff len), (bp, ep))
               | [: s :] ->
                   let id = get_buff (ident2 (store 0 c) s) in
                   keyword_or_error (bp, Stream.count s) id ] :] ->
            a
        | [: `'<'; s :] -> less bp s
        | [: `(':' as c1);
             len =
               parser
               [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2
               | [: :] -> store 0 c1 ] :] ep ->
            let id = get_buff len in
            keyword_or_error (bp, ep) id
        | [: `('>' | '|' as c1);
             len =
               parser
               [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2
               | [: a = ident2 (store 0 c1) :] -> a ] :] ep ->
            let id = get_buff len in
            keyword_or_error (bp, ep) id
        | [: `('[' | '{' as c1); s :] ->
            let len =
              match Stream.npeek 2 s with
              [ ['<'; '<' | ':'] -> store 0 c1
              | _ ->
                  match s with parser
                  [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2
                  | [: :] -> store 0 c1 ] ]
            in
            let ep = Stream.count s in
            let id = get_buff len in
            keyword_or_error (bp, ep) id
        | [: `'.';
             id =
               parser
               [ [: `'.' :] -> ".."
               | [: :] -> "." ] :] ep ->
            keyword_or_error (bp, ep) id
        | [: `';';
             id =
               parser
               [ [: `';' :] -> ";;"
               | [: :] -> ";" ] :] ep ->
            keyword_or_error (bp, ep) id
        | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep))
        | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c)
        | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ]
      and less bp =
        parser
        [ [: `'<'; len = quotation bp 0 :] ep ->
            (("QUOTATION", ":" ^ get_buff len), (bp, ep))
        | [: `':'; i = parser [: len = ident 0 :] -> get_buff len;
             `'<' ? "character '<' expected"; len = quotation bp 0 :] ep ->
            (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep))
        | [: len = ident2 (store 0 '<') :] ep ->
            let id = get_buff len in
            keyword_or_error (bp, ep) id ]
      and string bp len =
        parser
        [ [: `'"' :] -> get_buff len
        | [: `'\\'; `c; s :] ->
            let len = if c = '`' then len else store len '\\' in
            string bp (store len c) s
        | [: `c; s :] -> string bp (store len c) s
        | [: :] ep -> err (bp, ep) "string not terminated" ]
      and char bp len =
        parser
        [ [: `'`'; s :] ->
            if len = 0 then char bp (store len ''') s else get_buff len
        | [: `'\\'; `c; s :] ->
            let len = if c = '`' then len else store len '\\' in
            char bp (store len c) s
        | [: `c; s :] -> char bp (store len c) s
        | [: :] ep -> err (bp, ep) "char not terminated" ]
      and dollar bp len =
        parser
        [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
        | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s
        | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
        | [: `':'; s :] ->
            let k = get_buff len in
            ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
        | [: `'\\'; `c; s :] ->
            ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
        | [: s :] ->
            if dfa then
              match s with parser
              [ [: `c :] ->
                  ("ANTIQUOT",
                   ":" ^ locate_or_antiquot_rest bp (store len c) s)
              | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
            else ("", get_buff (ident2 (store 0 '$') s)) ]
      and maybe_locate bp len =
        parser
        [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
        | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
        | [: `':'; s :] ->
            ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s)
        | [: `'\\'; `c; s :] ->
            ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
        | [: `c; s :] ->
            ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
        | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
      and antiquot bp len =
        parser
        [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
        | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] ->
            antiquot bp (store len c) s
        | [: `':'; s :] ->
            let k = get_buff len in
            ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
        | [: `'\\'; `c; s :] ->
            ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
        | [: `c; s :] ->
            ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
        | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
      and locate_or_antiquot_rest bp len =
        parser
        [ [: `'$' :] -> get_buff len
        | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s
        | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s
        | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
      and quotation bp len =
        parser
        [ [: `'>'; s :] -> maybe_end_quotation bp len s
        | [: `'<'; s :] ->
            quotation bp (maybe_nested_quotation bp (store len '<') strm__) s
        | [: `'\\';
             len =
               parser
               [ [: `('>' | '<' | '\\' as c) :] -> store len c
               | [: :] -> store len '\\' ];
             s :] ->
            quotation bp len s
        | [: `c; s :] -> quotation bp (store len c) s
        | [: :] ep -> err (bp, ep) "quotation not terminated" ]
      and maybe_nested_quotation bp len =
        parser
        [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
        | [: `':'; len = ident (store len ':');
             a =
               parser
               [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
               | [: :] -> len ] :] ->
            a
        | [: :] -> len ]
      and maybe_end_quotation bp len =
        parser
        [ [: `'>' :] -> len
        | [: a = quotation bp (store len '>') :] -> a ]
      and left_paren bp =
        parser
        [ [: `'*'; _ = comment bp; a = next_token :] -> a
        | [: :] ep -> keyword_or_error (bp, ep) "(" ]
      and comment bp =
        parser
        [ [: `'('; s :] -> left_paren_in_comment bp s
        | [: `'*'; s :] -> star_in_comment bp s
        | [: `c; s :] -> comment bp s
        | [: :] ep -> err (bp, ep) "comment not terminated" ]
      and left_paren_in_comment bp =
        parser
        [ [: `'*'; s :] -> do { comment bp s; comment bp s }
        | [: a = comment bp :] -> a ]
      and star_in_comment bp =
        parser
        [ [: `')' :] -> ()
        | [: a = comment bp :] -> a ]
      and linenum bp =
        parser
        [ [: `'0'..'9'; _ = digits; _ = spaces_tabs; `'"'; _ = any_to_nl;
             s :] ->
            next_token s
        | [: :] -> keyword_or_error (bp, bp + 1) "#" ]
      and spaces_tabs =
        parser
        [ [: `' ' | '\t'; s :] -> spaces_tabs s
        | [: :] -> () ]
      and digits =
        parser
        [ [: `'0'..'9'; s :] -> digits s
        | [: :] -> () ]
      and any_to_nl =
        parser
        [ [: `'\013' | '\010' :] -> ()
        | [: `_; s :] -> any_to_nl s
        | [: :] -> () ]
      in
      fun cstrm ->
        try next_token cstrm with
        [ Stream.Error str ->
            err (Stream.count cstrm, Stream.count cstrm + 1) str ]
    ;
    value dollar_for_antiquotation = ref True;
    value func kwd_table =
      let find = Hashtbl.find kwd_table in
      let dfa = dollar_for_antiquotation.val in
      Token.lexer_func_of_parser (next_token_fun dfa find)
    ;
    value rec check_keyword_stream =
      parser [: _ = check; _ = Stream.empty :] -> True
    and check =
      parser
      [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
            '\248'..'\255'
            ;
           s :] ->
          check_ident s
      | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
            '%' | '.'
            ;
           s :] ->
          check_ident2 s
      | [: `'<'; s :] ->
          match Stream.npeek 1 s with
          [ [':' | '<'] -> ()
          | _ -> check_ident2 s ]
      | [: `':';
           _ =
             parser
             [ [: `']' | ':' | '=' | '>' :] -> ()
             | [: :] -> () ] :] ep ->
          ()
      | [: `'>' | '|';
           _ =
             parser
             [ [: `']' | '}' :] -> ()
             | [: a = check_ident2 :] -> a ] :] ->
          ()
      | [: `'[' | '{'; s :] ->
          match Stream.npeek 2 s with
          [ ['<'; '<' | ':'] -> ()
          | _ ->
              match s with parser
              [ [: `'|' | '<' | ':' :] -> ()
              | [: :] -> () ] ]
      | [: `';';
           _ =
             parser
             [ [: `';' :] -> ()
             | [: :] -> () ] :] ->
          ()
      | [: `_ :] -> () ]
    and check_ident =
      parser
      [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
            '\248'..'\255' | '0'..'9' | '_' | '''
            ;
           s :] ->
          check_ident s
      | [: :] -> () ]
    and check_ident2 =
      parser
      [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
            '%' | '.' | ':' | '<' | '>' | '|'
            ;
           s :] ->
          check_ident2 s
      | [: :] -> () ]
    ;
    value check_keyword s =
      try check_keyword_stream (Stream.of_string s) with _ -> False
    ;
    value error_no_respect_rules p_con p_prm =
      raise
        (Token.Error
           ("the token " ^
              (if p_con = "" then "\"" ^ p_prm ^ "\""
               else if p_prm = "" then p_con
               else p_con ^ " \"" ^ p_prm ^ "\"") ^
              " does not respect Plexer rules"))
    ;
    value using_token kwd_table (p_con, p_prm) =
      match p_con with
      [ "" ->
          try
            let _ = Hashtbl.find kwd_table p_prm in
            ()
          with
          [ Not_found ->
              if check_keyword p_prm then Hashtbl.add kwd_table p_prm p_prm
              else error_no_respect_rules p_con p_prm ]
      | "LIDENT" ->
          if p_prm = "" then ()
          else
            match p_prm.[0] with
            [ 'A'..'Z' -> error_no_respect_rules p_con p_prm
            | _ -> () ]
      | "UIDENT" ->
          if p_prm = "" then ()
          else
            match p_prm.[0] with
            [ 'a'..'z' -> error_no_respect_rules p_con p_prm
            | _ -> () ]
      | "TILDEIDENT" | "TILDEIDENTCOLON" | "QUESTIONIDENT" |
        "QUESTIONIDENTCOLON" | "INT" | "FLOAT" | "CHAR" | "STRING" |
        "QUOTATION" | "ANTIQUOT" | "LOCATE" | "EOI" ->
          ()
      | _ ->
          raise
            (Token.Error
               ("the constructor \"" ^ p_con ^
                  "\" is not recognized by Plexer")) ]
    ;
    value removing_token kwd_table (p_con, p_prm) =
      if p_con = "" then Hashtbl.remove kwd_table p_prm else ()
    ;
    value text =
      fun
      [ ("", t) -> "'" ^ t ^ "'"
      | ("LIDENT", "") -> "lowercase identifier"
      | ("LIDENT", t) -> "'" ^ t ^ "'"
      | ("UIDENT", "") -> "uppercase identifier"
      | ("UIDENT", t) -> "'" ^ t ^ "'"
      | ("INT", "") -> "integer"
      | ("INT", s) -> "'" ^ s ^ "'"
      | ("FLOAT", "") -> "float"
      | ("STRING", "") -> "string"
      | ("CHAR", "") -> "char"
      | ("QUOTATION", "") -> "quotation"
      | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\""
      | ("LOCATE", "") -> "locate"
      | ("EOI", "") -> "end of input"
      | (con, "") -> con
      | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ]
    ;
    value eq_before_colon p e =
      loop 0 where rec loop i =
        if i == String.length e then
          failwith "Internal error in Plexer: incorrect ANTIQUOT"
        else if i == String.length p then e.[i] == ':'
        else if p.[i] == e.[i] then loop (i + 1)
        else False
    ;
    value after_colon e =
      try
        let i = String.index e ':' in
        String.sub e (i + 1) (String.length e - i - 1)
      with
      [ Not_found -> "" ]
    ;
    value tparse =
      fun
      [ ("ANTIQUOT", p_prm) ->
          let p =
            parser
              [: `("ANTIQUOT", prm) when eq_before_colon p_prm prm :] ->
                after_colon prm
          in
          Some p
      | _ -> None ]
    ;
    value make () =
      let kwd_table = Hashtbl.create 301 in
      {func = func kwd_table; using = using_token kwd_table;
       removing = removing_token kwd_table; tparse = tparse; text = text}
    ;
  end
;

Pcaml.no_constructors_arity.val := True;

let odfa = Plexer.dollar_for_antiquotation.val in
do {
  Plexer.dollar_for_antiquotation.val := False;
  Grammar.Unsafe.reinit_gram gram (Plexer.make ());
  Plexer.dollar_for_antiquotation.val := odfa;
  Grammar.Unsafe.clear_entry interf;
  Grammar.Unsafe.clear_entry implem;
  Grammar.Unsafe.clear_entry top_phrase;
  Grammar.Unsafe.clear_entry use_file;
  Grammar.Unsafe.clear_entry module_type;
  Grammar.Unsafe.clear_entry module_expr;
  Grammar.Unsafe.clear_entry sig_item;
  Grammar.Unsafe.clear_entry str_item;
  Grammar.Unsafe.clear_entry expr;
  Grammar.Unsafe.clear_entry patt;
  Grammar.Unsafe.clear_entry ctyp;
  Grammar.Unsafe.clear_entry let_binding;
  Grammar.Unsafe.clear_entry class_type;
  Grammar.Unsafe.clear_entry class_expr;
  Grammar.Unsafe.clear_entry class_sig_item;
  Grammar.Unsafe.clear_entry class_str_item
};

Pcaml.parse_interf.val := Grammar.Entry.parse interf;
Pcaml.parse_implem.val := Grammar.Entry.parse implem;

value o2b =
  fun
  [ Some _ -> True
  | None -> False ]
;

value mkumin loc f arg =
  match arg with
  [ <:expr< $int:n$ >> when int_of_string n > 0 ->
      let n = "-" ^ n in
      <:expr< $int:n$ >>
  | <:expr< $flo:n$ >> when float_of_string n > 0.0 ->
      let n = "-" ^ n in
      <:expr< $flo:n$ >>
  | _ ->
      let f = "~" ^ f in
      <:expr< $lid:f$ $arg$ >> ]
;

external loc_of_node : 'a -> (int * int) = "%field0";

value mklistexp loc last =
  loop True where rec loop top =
    fun
    [ [] ->
        match last with
        [ Some e -> e
        | None -> <:expr< [] >> ]
    | [e1 :: el] ->
        let loc = if top then loc else (fst (loc_of_node e1), snd loc) in
        <:expr< [$e1$ :: $loop False el$] >> ]
;

value mklistpat loc last =
  loop True where rec loop top =
    fun
    [ [] ->
        match last with
        [ Some p -> p
        | None -> <:patt< [] >> ]
    | [p1 :: pl] ->
        let loc = if top then loc else (fst (loc_of_node p1), snd loc) in
        <:patt< [$p1$ :: $loop False pl$] >> ]
;

value lident_colon =
  Grammar.Entry.of_parser gram "lident_colon"
    (fun strm ->
       match Stream.npeek 2 strm with
       [ [("LIDENT", i); ("", ":")] ->
           do { Stream.junk strm; Stream.junk strm; i }
       | _ -> raise Stream.Failure ])
;

value symbolchar =
  let list =
    ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?';
     '@'; '^'; '|'; '~']
  in
  let rec loop s i =
    if i == String.length s then True
    else if List.mem s.[i] list then loop s (i + 1)
    else False
  in
  loop
;

value prefixop =
  let list = ['!'; '?'; '~'] in
  let excl = ["!="; "??"] in
  Grammar.Entry.of_parser gram "prefixop"
    (parser
       [: `("", x)
           when
             not (List.mem x excl) && String.length x >= 2 &&
             List.mem x.[0] list && symbolchar x 1 :] ->
         x)
;

value infixop0 =
  let list = ['='; '<'; '>'; '|'; '&'; '$'] in
  let excl = ["<-"; "||"; "&&"] in
  Grammar.Entry.of_parser gram "infixop0"
    (parser
       [: `("", x)
           when
             not (List.mem x excl) && String.length x >= 2 &&
             List.mem x.[0] list && symbolchar x 1 :] ->
         x)
;

value infixop1 =
  let list = ['@'; '^'] in
  Grammar.Entry.of_parser gram "infixop1"
    (parser
       [: `("", x)
           when
             String.length x >= 2 && List.mem x.[0] list &&
             symbolchar x 1 :] ->
         x)
;

value infixop2 =
  let list = ['+'; '-'] in
  Grammar.Entry.of_parser gram "infixop2"
    (parser
       [: `("", x)
           when
             x <> "->" && String.length x >= 2 && List.mem x.[0] list &&
             symbolchar x 1 :] ->
         x)
;

value infixop3 =
  let list = ['*'; '/'; '%'] in
  Grammar.Entry.of_parser gram "infixop3"
    (parser
       [: `("", x)
           when
             String.length x >= 2 && List.mem x.[0] list &&
             symbolchar x 1 :] ->
         x)
;

value infixop4 =
  Grammar.Entry.of_parser gram "infixop4"
    (parser
       [: `("", x)
           when
             String.length x >= 3 && x.[0] == '*' && x.[1] == '*' &&
             symbolchar x 2 :] ->
         x)
;

value prefix_lident =
  let str = "__prefix" in
  let len = String.length str in
  Grammar.Entry.of_parser gram "prefix_lident"
    (fun strm ->
       match Stream.peek strm with
       [ Some ("LIDENT", x) ->
           if String.length x > len
           && String.sub x (String.length x - len) len = str then do {
             let m = String.sub x 0 (String.length x - len) in
             Stream.junk strm;             
             match Stream.peek strm with
             [ Some ("", x) -> do { Stream.junk strm; m ^ "__" ^ x }
             | _ -> raise Stream.Failure ]
           }
           else do { Stream.junk strm; x }
       | _ -> raise Stream.Failure ])
;

value test_constr_decl =
  Grammar.Entry.of_parser gram "test_constr_decl"
    (fun strm ->
       match Stream.npeek 1 strm with
       [ [("UIDENT", _) | ("LIDENT", "ref" | "yyexit")] ->
           match Stream.npeek 2 strm with
           [ [_; ("", ".")] -> raise Stream.Failure
           | [_; ("", "(")] -> raise Stream.Failure
           | [_ :: _] -> ()
           | _ -> raise Stream.Failure ]
       | [("", "|")] -> ()
       | _ -> raise Stream.Failure ])
;

value stream_peek_nth n strm =
  loop n (Stream.npeek n strm) where rec loop n =
    fun
    [ [] -> None
    | [x] -> if n == 1 then Some x else None
    | [_ :: l] -> loop (n - 1) l ]
;

value constr_arity = ref [("Some", 1); ("Match_Failure", 1)];

value rec constr_expr_arity =
  fun
  [ <:expr< $uid:c$ >> ->
      try List.assoc c constr_arity.val with [ Not_found -> 0 ]
  | <:expr< $uid:_$.$e$ >> -> constr_expr_arity e
  | _ -> 1 ]
;

value rec constr_patt_arity =
  fun
  [ <:patt< $uid:c$ >> ->
      try List.assoc c constr_arity.val with [ Not_found -> 0 ]
  | <:patt< $uid:_$.$p$ >> -> constr_patt_arity p
  | _ -> 1 ]
;

value get_seq =
  fun
  [ <:expr< do { $list:el$ } >> -> el
  | e -> [e] ]
;

value choose_tvar tpl =
  let rec find_alpha v =
    let s = String.make 1 v in
    if List.mem_assoc s tpl then
      if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1))
    else Some (String.make 1 v)
  in
  let rec make_n n =
    let v = "a" ^ string_of_int n in
    if List.mem_assoc v tpl then make_n (succ n) else v
  in
  match find_alpha 'a' with
  [ Some x -> x
  | None -> make_n 1 ]
;

value rec patt_lid =
  fun
  [ <:patt< $lid:i$ $p$ >> -> Some (i, [p])
  | <:patt< $p1$ $p2$ >> ->
      match patt_lid p1 with
      [ Some (i, pl) -> Some (i, [p2 :: pl])
      | None -> None ]
  | _ -> None ]
;

value bigarray_get loc arr arg =
  let coords =
    match arg with
    [ <:expr< ($list:el$) >> -> el
    | _ -> [arg] ]
  in
  match coords with
  [ [c1] -> <:expr< Bigarray.Array1.get $arr$ $c1$ >>
  | [c1; c2] -> <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >>
  | [c1; c2; c3] -> <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >>
  | coords -> <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ]
;

value bigarray_set loc var newval =
  match var with
  [ <:expr< Bigarray.Array1.get $arr$ $c1$ >> ->
      Some <:expr< Bigarray.Array1.set $arr$ $c1$ $newval$ >>
  | <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> ->
      Some <:expr< Bigarray.Array2.set $arr$ $c1$ $c2$ $newval$ >>
  | <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> ->
      Some <:expr< Bigarray.Array3.set $arr$ $c1$ $c2$ $c3$ $newval$ >>
  | <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ->
      Some <:expr< Bigarray.Genarray.set $arr$ [| $list:coords$ |] $newval$ >>
  | _ -> None ]
;

value conv_expr_ident loc x = x;
value conv_patt_ident loc x = x;
value conv_type_ident loc x = x;

value is_current_module m =
  let bn =
    if Filename.check_suffix input_file.val ".mli" then
      Filename.chop_suffix input_file.val ".mli"
    else if Filename.check_suffix input_file.val ".ml" then
      Filename.chop_suffix input_file.val ".ml"
    else ""
  in
  m = bn
;

value compiling_ml () =
  Filename.check_suffix input_file.val ".ml"
;

value expr_id loc v =
  if String.length v > 0 then
    match v.[0] with
    [ 'A'..'Z' -> <:expr< $uid:v$ >>
    | _ -> <:expr< $lid:v$ >> ]
  else <:expr< aaaa >>
;

value patt_id loc v =
  if String.length v > 0 then
    match v.[0] with
    [ 'A'..'Z' -> <:patt< $uid:v$ >>
    | _ -> <:patt< $lid:v$ >> ]
  else <:patt< aaaa >>
;

value split_expr_module loc id =
  loop 0 where rec loop i =
    if i + 1 >= String.length id then expr_id loc id
    else if id.[i] = '_' && id.[i + 1] = '_' then
      let m = String.sub id 0 i in
      let v = String.sub id (i + 2) (String.length id - i - 2) in
      if is_current_module m then expr_id loc v
      else <:expr< $uid:String.capitalize m$ . $expr_id loc v$ >>
    else loop (i + 1)
;

value split_patt_module loc id =
  loop 0 where rec loop i =
    if i + 1 >= String.length id then patt_id loc id
    else if id.[i] = '_' && id.[i + 1] = '_' then
      let m = String.sub id 0 i in
      let v = String.sub id (i + 2) (String.length id - i - 2) in
      if is_current_module m then <:patt< $uid:v$ >>
      else <:patt< $uid:String.capitalize m$ . $uid:v$ >>
    else loop (i + 1)
;

value split_ctyp_module loc id =
  loop 0 where rec loop i =
    if i + 1 >= String.length id then
      let id = if id = "vect" then "array" else id in
      <:ctyp< $lid:id$ >>
    else if id.[i] = '_' && id.[i + 1] = '_' then
      let m = String.sub id 0 i in
      let v = String.sub id (i + 2) (String.length id - i - 2) in
      if is_current_module m then <:ctyp< $lid:v$ >>
      else <:ctyp< $uid:String.capitalize m$ . $lid:v$ >>
    else loop (i + 1)
;

value rename_label s =
  if s = "val" then "x__val"
  else if s = "" then s
  else
    match s.[0] with
    [ 'A'..'Z' -> "x" ^ s
    | _ -> s ]
;

value no_libcl = ref False;
value interface_read = ref False;
value libcl_opened = ref False;

value not_impl name x =
  let desc =
    if Obj.is_block (Obj.repr x) then
      "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
    else "int_val = " ^ string_of_int (Obj.magic x)
  in
  do {
    print_newline (); failwith ("pa_cl: not impl " ^ name ^ " " ^ desc)
  }
;

value is_abstract_definition (_, pl, ct, _) =
  match ct with
  [ <:ctyp< '$x$ >> -> not (List.exists (fun (y, _) -> x = y) pl)
  | _ -> False ]
;

value rec implem_of_interf (si, loc) sil =
  let loc = (0, 0) in
  match si with
  [ <:sig_item< value $_$ : $_$ >> ->
      sil
  | <:sig_item< exception $c$ of $list:tl$ >> ->
      [(<:str_item< exception $c$ of $list:tl$ >>, loc) :: sil]
  | <:sig_item< type $list:tdl$ >> ->
      let tdl = List.filter (fun td -> not (is_abstract_definition td)) tdl in
      if tdl = [] then sil
      else [(<:str_item< type $list:tdl$ >>, loc) :: sil]
  | <:sig_item< open $d$ >> ->
      [(<:str_item< open $d$ >>, loc) :: sil]
  | <:sig_item< declare $list:sil1$ end >> ->
      let sil1 =
        List.fold_right (fun si sil -> implem_of_interf (si, loc) sil)
          sil1 []
      in
      let sil1 = List.map fst sil1 in
      if sil1 = [] then sil
      else [(<:str_item< declare $list:sil1$ end >>, loc) :: sil]
  | <:sig_item< external $i$ : $t$ = $f$ >> ->
      let si = <:str_item< value $lid:i$ : $t$ = Clruntime.$lid:f$ >> in
      [(si, loc) :: sil]
  | x -> not_impl "implem_of_interf" x ]
;

value compile_file n =
  let camlp4 = "camlp4 pa_cl.cmo pr_dump.cmo" in
  let comm =
    "ocamlc -c -pp \"" ^ camlp4 ^ "\" -I +camlp4 " ^ n
  in
  let _ = do { Printf.eprintf "compiling %s...\n" n; flush stderr; } in
  let r = Sys.command comm in
  if r = 0 then () else failwith "compilation aborted"
;

value remove_infix loc s =
  do {
    try DELETE_RULE expr: SELF; $s$; SELF END with [ Not_found -> () ];
    <:str_item< declare end >>
  }
;

value add_infix loc s =
  do {
    try DELETE_RULE expr: SELF; $s$; SELF END with [ Not_found -> () ];
    EXTEND
      expr: LEVEL "*"
        [ [ e1 = SELF; $s$; e2 = SELF -> <:expr< $lid:s$ $e1$ $e2$ >> ] ]
      ;
    END;
    <:str_item< declare end >>
  }
;

value type_parameter = Grammar.Entry.create gram "type_parameter";
value fun_def = Grammar.Entry.create gram "fun_def";
value fun_binding = Grammar.Entry.create gram "fun_binding";
value mod_ident = Grammar.Entry.create gram "mod_ident";

EXTEND
  GLOBAL: interf implem top_phrase use_file sig_item str_item ctyp patt expr
    module_type module_expr let_binding type_parameter fun_def fun_binding
    mod_ident;
  (* Main entry points *)
  interf:
    [ [ si1 = add_open_libcl; si = sig_item_semi; (sil, stopped) = SELF ->
          (si1 @ [si :: sil], stopped)
      | EOI -> ([], False) ] ]
  ;
  add_open_libcl:
    [ [ ->
          if not libcl_opened.val && not no_libcl.val then do {
            libcl_opened.val := True;
            [(<:sig_item< open Libcl >>, (0, 0))]
          }
          else [] ] ]
  ;
  sig_item_semi:
    [ [ si = sig_item; ";;" -> (si, loc) ] ]
  ;
  implem:
    [ [ intf = read_interface; si = str_item_semi; (sil, stopped) = SELF ->
          (intf @ [si :: sil], stopped)
      | EOI -> ([], False) ] ]
  ;
  read_interface:
    [ [ ->
          if not interface_read.val then do {
            interface_read.val := True;
            let r =
              if Filename.check_suffix input_file.val ".ml" then
                let fname = input_file.val ^ "i" in
                match
                  try Some (open_in fname) with [ Sys_error _ -> None ]
                with
                [ Some ic ->
                    let f = input_file.val in
                    let r =
                      let strm = Stream.of_channel ic in
                      try
                        let (sil, _) = Grammar.Entry.parse interf strm in
                        List.fold_right implem_of_interf sil []
                      with e -> do { close_in ic; raise e }
                    in
                    do { input_file.val := f; close_in ic; r }
                | None -> [] ]
              else []
            in
            if not libcl_opened.val && not no_libcl.val then do {
              libcl_opened.val := True;
              [(<:str_item< open Libcl >>, (0, 0)) :: r]
            }
            else r
          }
          else [] ] ]
  ;
  str_item_semi:
    [ [ si = str_item; ";;" -> (si, loc) ] ]
  ;
  top_phrase:
    [ [ ph = phrase; ";;" -> Some ph
      | EOI -> None ] ]
  ;
  use_file:
    [ [ "#"; LIDENT "infix"; s = STRING; ";;" -> ([add_infix loc s], True)
      | "#"; LIDENT "uninfix"; s = STRING -> ([remove_infix loc s], True)
      | "#"; LIDENT "open"; i = STRING; ";;"; (sil, stopped) = SELF ->
          let si = <:str_item< open $[String.capitalize i]$ >> in
          ([si :: sil], stopped)
      | d = directive; ";;" -> ([d], True)
      | si = str_item; ";;"; (sil, stopped) = SELF ->
          ([si :: sil], stopped)
      | EOI -> ([], False) ] ]
  ;
  phrase:
    [ [ "#"; LIDENT "infix"; s = STRING -> add_infix loc s
      | "#"; LIDENT "uninfix"; s = STRING -> remove_infix loc s
      | "#"; LIDENT "open"; i = STRING ->
          <:str_item< open $[String.capitalize i]$ >>
      | d = directive -> d
      | sti = str_item -> sti ] ]
  ;
  directive:
    [ [ LIDENT "compile"; n = STRING ->
          do {
            compile_file n;
            <:str_item< () >>
          }
      | LIDENT "include"; s = STRING ->
          let s =
            if Filename.check_suffix s ".ml" then s
            else s ^ ".ml"
          in
          <:str_item< # use $str:s$ >>
      | LIDENT "load_object"; s = STRING ->
          let n =
            if Filename.check_suffix s ".zo" then
              Filename.chop_suffix s ".zo" ^ ".cmo"
            else if Filename.check_suffix s ".cmo" then s
            else if Filename.check_suffix s ".cma" then s
            else s ^ ".cmo"
          in
          <:str_item< # load $str:n$ >>
      | LIDENT "load"; s = STRING ->
          do {
            let n =
              if Filename.check_suffix s ".ml" then
                Filename.chop_suffix s ".ml"
              else s
            in
            compile_file (n ^ ".ml");
            <:str_item< # load $str:n ^ ".cmo"$ >>;
          } ] ]
  ;
  module_expr:
    [ [ "struct"; st = LIST0 [ s = str_item; ";;" -> s ]; "end" ->
          <:module_expr< struct $list:st$ end >> ] ]
  ;
  str_item:
    [ "top"
      [ "exception"; cdl = LIST1 exception_declaration SEP "and" ->
          match cdl with
          [ [((_, c, tl), b)] ->
              <:str_item< exception $c$ of $list:tl$ = $b$ >>
          | _ ->
              let dl =
                List.map
                  (fun ((_, c, tl), b) ->
                     <:str_item< exception $c$ of $list:tl$ = $b$ >>)
                  cdl
              in
              <:str_item< declare $list:dl$ end >> ]
      | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
          <:str_item< external $i$ : $t$ = $list:pd$ >>
      | "external"; "prefix"; i = ANY; ":"; t = ctyp; "=";
        pd = LIST1 STRING ->
          <:str_item< external $i$ : $t$ = $list:pd$ >>
      | "module"; i = UIDENT; mb = module_binding ->
          <:str_item< module $i$ = $mb$ >>
      | "#"; LIDENT "open"; i = STRING ->
          <:str_item< open $[String.capitalize i]$ >>
      | "type"; tdl = LIST1 type_declaration SEP "and" ->
          match <:str_item< type $list:tdl$ >> with
          [ <:str_item< type in_channel = '$_$ and out_channel = '$_$ >>
            when input_file.val = "io.ml" ->
              <:str_item<
                type in_channel = Pervasives.in_channel
                 and out_channel = Pervasives.out_channel
             >>
          | x -> x ]
      | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
        x = expr ->
          let e = <:expr< let $rec:o2b r$ $list:l$ in $x$ >> in
          <:str_item< $exp:e$ >>
      | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" ->
          match l with
          [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >>
          | _ -> <:str_item< value $rec:o2b r$ $list:l$ >> ]
      | e = expr -> <:str_item< $exp:e$ >> ] ]
  ;
  exception_declaration:
    [ [ cd = constructor_declaration; b = rebind_exn -> (cd, b) ] ]
  ;
  rebind_exn:
    [ [ "="; sl = mod_ident -> sl
      | -> [] ] ]
  ;
  module_binding:
    [ RIGHTA
      [ "="; me = module_expr -> <:module_expr< $me$ >> ] ]
  ;
  sig_item:
    [ "top"
      [ "exception"; cdl = LIST1 constructor_declaration SEP "and" ->
          match cdl with
          [ [(_, c, tl)] -> <:sig_item< exception $c$ of $list:tl$ >>
          | _ ->
              let dl =
                List.map
                  (fun (_, c, tl) ->
                     <:sig_item< exception $c$ of $list:tl$ >>)
                  cdl
              in
              <:sig_item< declare $list:dl$ end >> ]
      | "#"; LIDENT "open"; i = STRING ->
          <:sig_item< open $[String.capitalize i]$ >>
      | "type"; tdl = LIST1 type_declaration SEP "and" ->
          match <:sig_item< type $list:tdl$ >> with
          [ <:sig_item< type ref '$_$ = [ $uid:"ref"$ of '$_$ ] >> when
            input_file.val = "ref.mli" ->
              <:sig_item< type ref 'a = Pervasives.ref 'a >>
          | x -> x ]
      | "value"; vdl = LIST1 value_decl SEP "and" ->
          let mk (v, i, t) =
            match v with
            [ None -> <:sig_item< value $i$ : $t$ >>
            | Some f ->
                if compiling_ml () then <:sig_item< external $i$ : $t$ = $f$ >>
                else <:sig_item< value $i$ : $t$ >> ]
          in
          match vdl with
          [ [vd] -> mk vd
          | _ ->
              let dl = List.map mk vdl in
              <:sig_item< declare $list:dl$ end >> ] ] ]
  ;
  value_decl:
    [ [ i = value_ident; ":"; t = ctyp -> (None, i, t)
      | i = value_ident; ":"; t = ctyp; "="; INT; f = STRING ->
          (Some f, i, t) ] ]
  ;
  value_ident:
    [ [ i = LIDENT -> i
      | "prefix"; i = ANY -> i ] ]
  ;
  (* Core expressions *)
  expr:
    [ "top" RIGHTA
      [ e1 = SELF; ";"; e2 = SELF ->
          <:expr< do { $list:[e1 :: get_seq e2]$ } >>
      | e1 = SELF; ";" -> e1 ]
    | "expr1"
      [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
        x = expr LEVEL "top" ->
          <:expr< let $rec:o2b o$ $list:l$ in $x$ >>
      | "function"; OPT "|"; l = LIST1 match_case SEP "|" ->
          <:expr< fun [ $list:l$ ] >>
      | "fun"; OPT "|"; l = LIST1 fun_match_case SEP "|" ->
          match l with
          [ [([p], w, e) :: _] ->
              let l =
                List.map
                  (fun (pl, w, e) ->
                     match pl with
                     [ [p] -> (p, w, e)
                     | [_; p :: _] ->
                         let loc = MLast.loc_of_patt p in
                         raise_with_loc loc (Stream.Error "-> expected")
                     | _ -> assert False ])
                  l
              in
              <:expr< fun [ $list:l$ ] >>
          | [(pl, w, e) :: _] ->
              let len = List.length pl in
              let (idl, _) =
                List.fold_left
                  (fun (idl, cnt) _ ->
                     let id = "xxx_" ^ string_of_int cnt in
                     ([id :: idl], cnt + 1))
                  ([], 1) pl
              in
              let idl = List.rev idl in
              let pl = List.map (fun id -> <:patt< $lid:id$ >>) idl in
              let el = List.map (fun id -> <:expr< $lid:id$ >>) idl in
              let pel =
                List.map (fun (pl, w, e) -> (<:patt< ($list:pl$) >>, w, e)) l
              in
              let e = <:expr< match ($list:el$) with [ $list:pel$ ] >> in
              List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl e
          | _ -> assert False ]
      | "match"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" ->
          <:expr< match $e$ with [ $list:l$ ] >>
      | "try"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" ->
          <:expr< try $e$ with [ $list:l$ ] >>
      | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1"; "else";
        e3 = expr LEVEL "expr1" ->
          <:expr< if $e1$ then $e2$ else $e3$ >>
      | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1" ->
          <:expr< if $e1$ then $e2$ else () >>
      | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
        "do"; e = SELF; "done" ->
          <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:get_seq e$ } >>
      | "while"; e1 = SELF; "do"; e2 = SELF; "done" ->
          <:expr< while $e1$ do { $list:get_seq e2$ } >> ]
    | [ e = SELF; "where"; rf = OPT "rec"; lbs = LIST1 let_binding SEP "and" ->
          <:expr< let $rec:o2b rf$ $list:lbs$ in $e$ >> ]
    | [ e = SELF; ","; el = LIST1 NEXT SEP "," ->
          <:expr< ( $list:[e :: el]$ ) >> ]
    | ":=" NONA
      [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" ->
          <:expr< $e1$.val := $e2$ >>
      | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" ->
          match bigarray_set loc e1 e2 with
          [ Some e -> e
          | None ->
              match e1 with
              [ <:expr< nth_char $x$ $y$ >> ->
                  <:expr< set_nth_char $x$ $y$ $e2$ >>
              | _ -> <:expr< $e1$ := $e2$ >> ] ] ]
    | "||" RIGHTA
      [ e1 = SELF; "or"; e2 = SELF -> <:expr< $lid:"or"$ $e1$ $e2$ >>
      | e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ]
    | "&&" RIGHTA
      [ e1 = SELF; "&"; e2 = SELF -> <:expr< $lid:"&"$ $e1$ $e2$ >>
      | e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ]
    | "<" LEFTA
      [ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >>
      | e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >>
      | e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >>
      | e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >>
      | e1 = SELF; ">=."; e2 = SELF -> <:expr< $e1$ >= $e2$ >>
      | e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >>
      | e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >>
      | e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >>
      | e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >>
      | e1 = SELF; "$"; e2 = SELF -> <:expr< $lid:"\$"$ $e1$ $e2$ >>
      | e1 = SELF; op = infixop0; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
    | "^" RIGHTA
      [ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >>
      | e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >>
      | e1 = SELF; op = infixop1; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
    | RIGHTA
      [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ]
    | "+" LEFTA
      [ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >>
      | e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >>
      | e1 = SELF; "+."; e2 = SELF -> <:expr< $e1$ +. $e2$ >>
      | e1 = SELF; "-."; e2 = SELF -> <:expr< $e1$ -. $e2$ >>
      | e1 = SELF; op = infixop2; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
    | "*" LEFTA
      [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >>
      | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >>
      | e1 = SELF; "*."; e2 = SELF -> <:expr< $e1$ *. $e2$ >>
      | e1 = SELF; "/."; e2 = SELF -> <:expr< $e1$ /. $e2$ >>
      | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >>
      | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >>
      | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >>
      | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >>
      | e1 = SELF; op = infixop3; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
    | "**" RIGHTA
      [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >>
      | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >>
      | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >>
      | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >>
      | e1 = SELF; op = infixop4; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
    | "unary minus" NONA
      [ "-"; e = SELF -> <:expr< $mkumin loc "-" e$ >>
      | "-."; e = SELF -> <:expr< $mkumin loc "-." e$ >>
      | "not"; e = SELF -> <:expr< not $e$ >> ]
    | "apply" LEFTA
      [ e1 = SELF; e2 = SELF ->
          match constr_expr_arity e1 with
          [ 1 -> <:expr< $e1$ $e2$ >>
          | _ ->
              match e2 with
              [ <:expr< ( $list:el$ ) >> ->
                  List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el
              | _ -> <:expr< $e1$ $e2$ >> ] ]
      | "assert"; e = SELF ->
          let f = <:expr< $str:input_file.val$ >> in
          let bp = <:expr< $int:string_of_int (fst loc)$ >> in
          let ep = <:expr< $int:string_of_int (snd loc)$ >> in
          let raiser = <:expr< raise (Assert_failure ($f$, $bp$, $ep$)) >> in
          match e with
          [ <:expr< False >> -> raiser
          | _ ->
              if no_assert.val then <:expr< () >>
              else <:expr< if $e$ then () else $raiser$ >> ]
      | "lazy"; e = SELF ->
          <:expr< Pervasives.ref (Lazy.Delayed (fun () -> $e$)) >> ]
    | "." LEFTA
      [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >>
      | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< nth_char $e1$ $e2$ >>
      | e1 = SELF; "."; "{"; e2 = SELF; "}" -> bigarray_get loc e1 e2
      | e1 = SELF; "."; e2 = SELF ->
          match e1 with
          [ <:expr< $uid:_$ >> ->
              raise (Stream.Error "lowercase identifier expected")
          | _ ->
              let e2 =
                match e2 with
                [ <:expr< $uid:s$ >> | <:expr< $lid:s$ >> ->
                    <:expr< $lid:rename_label s$ >>
                | e2 -> e2 ]
              in
              <:expr< $e1$ . $e2$ >> ] ]
    | "~-" NONA
      [ "!"; e = SELF -> <:expr< $e$.val >>
      | "~-"; e = SELF -> <:expr< ~- $e$ >>
      | "~-."; e = SELF -> <:expr< ~-. $e$ >>
      | f = prefixop; e = SELF -> <:expr< $lid:f$ $e$ >> ]
    | "simple" LEFTA
      [ s = INT -> <:expr< $int:s$ >>
      | s = FLOAT -> <:expr< $flo:s$ >>
      | s = STRING -> <:expr< $str:s$ >>
      | c = CHAR -> <:expr< $chr:c$ >>
      | UIDENT "True" -> <:expr< $uid:" True"$ >>
      | UIDENT "False" -> <:expr< $uid:" False"$ >>
      | i = expr_ident -> conv_expr_ident loc i
      | s = "false" -> <:expr< False >>
      | s = "true" -> <:expr< True >>
      | "["; "]" -> <:expr< [] >>
      | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >>
      | "[|"; "|]" -> <:expr< [| |] >>
      | "[|"; el = expr1_semi_list; "|]" -> <:expr< [| $list:el$ |] >>
      | "{"; lel = lbl_expr_list; "}" -> <:expr< { $list:lel$ } >>
      | "("; ")" -> <:expr< () >>
      | "prefix"; op = ANY -> <:expr< $lid:op$ >>
      | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >>
      | "("; e = SELF; ")" -> <:expr< $e$ >>
      | "begin"; e = SELF; "end" -> <:expr< $e$ >>
      | x = LOCATE ->
          let x =
            try
              let i = String.index x ':' in
              (int_of_string (String.sub x 0 i),
               String.sub x (i + 1) (String.length x - i - 1))
            with
            [ Not_found | Failure _ -> (0, x) ]
          in
          Pcaml.handle_expr_locate loc x
      | x = QUOTATION ->
          let x =
            try
              let i = String.index x ':' in
              (String.sub x 0 i,
               String.sub x (i + 1) (String.length x - i - 1))
            with
            [ Not_found -> ("", x) ]
          in
          Pcaml.handle_expr_quotation loc x ] ]
  ;
  let_binding:
    [ [ p = patt; e = fun_binding ->
          match patt_lid p with
          [ Some (i, pl) ->
              let e =
                List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl
              in
              (<:patt< $lid:i$ >>, e)
          | None -> (p, e) ] ] ]
  ;
  fun_binding:
    [ RIGHTA
      [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >>
      | "="; e = expr -> <:expr< $e$ >>
      | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ]
  ;
  match_case:
    [ [ x1 = patt; w = OPT [ "when"; e = expr -> e ]; "->"; x2 = expr ->
          let x1 =
            match x1 with
            [ <:patt< $lid:x$ $y$ >> -> <:patt< $uid:x$ $y$ >>
            | _ -> x1 ]
          in
          (x1, w, x2) ] ]
  ;
  fun_match_case:
    [ [ pl = LIST1 patt LEVEL "simple"; w = OPT [ "when"; e = expr -> e ];
        "->"; x2 = expr ->
          (pl, w, x2) ] ]
  ;
  lbl_expr_list:
    [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel]
      | le = lbl_expr; ";" -> [le]
      | le = lbl_expr -> [le] ] ]
  ;
  lbl_expr:
    [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ]
  ;
  expr1_semi_list:
    [ [ e = expr LEVEL "expr1"; ";"; el = SELF -> [e :: el]
      | e = expr LEVEL "expr1"; ";" -> [e]
      | e = expr LEVEL "expr1" -> [e] ] ]
  ;
  fun_def:
    [ RIGHTA
      [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >>
      | "->"; e = expr -> <:expr< $e$ >> ] ]
  ;
  expr_ident:
    [ [ id = prefix_lident -> split_expr_module loc id
      | id = UIDENT -> <:expr< $uid:id$ >> ] ]
  ;
  (* Patterns *)
  patt:
    [ LEFTA
      [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ]
    | LEFTA
      [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ]
    | [ p = SELF; ","; pl = LIST1 NEXT SEP "," ->
          <:patt< ( $list:[p :: pl]$) >> ]
    | NONA
      [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ]
    | RIGHTA
      [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ]
    | LEFTA
      [ p1 = SELF; p2 = SELF ->
          match constr_patt_arity p1 with
          [ 1 ->
              match p1 with
              [ <:patt< ref >> -> <:patt< { val = $p2$ } >>
              | _ -> <:patt< $p1$ $p2$ >> ]
          | n ->
              let p2 =
                match p2 with
                [ <:patt< _ >> when n > 1 ->
                    let pl =
                      loop n where rec loop n =
                        if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)]
                    in
                    <:patt< ( $list:pl$ ) >>
                | _ -> p2 ]
              in
              match p2 with
              [ <:patt< ( $list:pl$ ) >> ->
                  List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl
              | _ -> <:patt< $p1$ $p2$ >> ] ] ]
    | LEFTA
      [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
    | "simple"
      [ id = LIDENT -> split_patt_module loc id
      | s = UIDENT -> conv_patt_ident loc <:patt< $uid:s$ >>
      | s = INT -> <:patt< $int:s$ >>
      | "-"; s = INT -> <:patt< $int:"-" ^ s$ >>
      | "-"; s = FLOAT -> <:patt< $flo:"-" ^ s$ >>
      | s = FLOAT -> <:patt< $flo:s$ >>
      | s = STRING -> <:patt< $str:s$ >>
      | s = CHAR -> <:patt< $chr:s$ >>
      | s = "false" -> <:patt< False >>
      | s = "true" -> <:patt< True >>
      | "["; "]" -> <:patt< [] >>
      | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >>
      | "[|"; "|]" -> <:patt< [| |] >>
      | "[|"; pl = patt_semi_list; "|]" -> <:patt< [| $list:pl$ |] >>
      | "{"; lpl = lbl_patt_list; "}" -> <:patt< { $list:lpl$ } >>
      | "("; ")" -> <:patt< () >>
      | "prefix"; op = ANY -> <:patt< $lid:op$ >>
      | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
      | "("; p = SELF; ")" -> <:patt< $p$ >>
      | "_" -> <:patt< _ >>
      | x = LOCATE ->
          let x =
            try
              let i = String.index x ':' in
              (int_of_string (String.sub x 0 i),
               String.sub x (i + 1) (String.length x - i - 1))
            with
            [ Not_found | Failure _ -> (0, x) ]
          in
          Pcaml.handle_patt_locate loc x
      | x = QUOTATION ->
          let x =
            try
              let i = String.index x ':' in
              (String.sub x 0 i,
               String.sub x (i + 1) (String.length x - i - 1))
            with
            [ Not_found -> ("", x) ]
          in
          Pcaml.handle_patt_quotation loc x ] ]
  ;
  patt_semi_list:
    [ [ p = patt; ";"; pl = SELF -> [p :: pl]
      | p = patt; ";" -> [p]
      | p = patt -> [p] ] ]
  ;
  lbl_patt_list:
    [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel]
      | le = lbl_patt; ";" -> [le]
      | le = lbl_patt -> [le]
      | "_" -> [] ] ]
  ;
  lbl_patt:
    [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ]
  ;
  patt_label_ident:
    [ [ i = UIDENT -> <:patt< $lid:rename_label i$ >>
      | i = LIDENT -> <:patt< $lid:rename_label i$ >> ] ]
  ;
  (* Type declaration *)
  type_declaration:
    [ [ tpl = type_parameters; n = type_patt; "="; tk = type_kind ->
          (n, tpl, tk, [])
      | tpl = type_parameters; n = type_patt; "=="; tk = type_kind ->
          (n, tpl, tk, [])
      | tpl = type_parameters; n = type_patt ->
          (n, tpl, <:ctyp< '$choose_tvar tpl$ >>, []) ] ]
  ;
  type_patt:
    [ [ n = LIDENT -> (loc, n) ] ]
  ;
  type_kind:
    [ [ test_constr_decl; OPT "|";
        cdl = LIST1 constructor_declaration SEP "|" ->
          <:ctyp< [ $list:cdl$ ] >>
      | t = ctyp -> <:ctyp< $t$ >>
      | t = ctyp; "="; "{"; ldl = label_declarations; "}" ->
          <:ctyp< $t$ == { $list:ldl$ } >>
      | t = ctyp; "="; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" ->
          <:ctyp< $t$ == [ $list:cdl$ ] >>
      | "{"; ldl = label_declarations; "}" -> <:ctyp< { $list:ldl$ } >> ] ]
  ;
  type_parameters:
    [ [ -> (* empty *) []
      | tp = type_parameter -> [tp]
      | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ]
  ;
  type_parameter:
    [ [ "'"; i = ident -> (i, (False, False))
      | "+"; "'"; i = ident -> (i, (True, False))
      | "-"; "'"; i = ident -> (i, (False, True)) ] ]
  ;
  constructor_declaration:
    [ [ ci = constr_ident; "of"; OPT "mutable"; cal = LIST1 ctyp1 SEP "*" ->
          (loc, ci, cal)
      | ci = constr_ident -> (loc, ci, []) ] ]
  ;
  constr_ident:
    [ [ i = UIDENT -> i
      | i = LIDENT "ref" -> i
      | i = LIDENT "yyexit" -> i ] ]
  ;
  ctyp1:
    [ RIGHTA
      [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ]
    | [ t = ctyp LEVEL "ctyp1" -> t ] ]
  ;
  label_declarations:
    [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl]
      | ld = label_declaration; ";" -> [ld]
      | ld = label_declaration -> [ld] ] ]
  ;
  label_declaration:
    [ [ i = label_ident; ":"; t = ctyp -> (loc, i, False, t)
      | "mutable"; i = label_ident; ":"; t = ctyp ->
          (loc, i, True, t) ] ]
  ;
  label_ident:
    [ [ i = LIDENT -> rename_label i
      | i = UIDENT -> rename_label i ] ]
  ;
  (* Core types *)
  ctyp:
    [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ]
    | "arrow" RIGHTA
      [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ]
    | [ t = SELF; "*"; tl = LIST1 ctyp LEVEL "ctyp1" SEP "*" ->
          <:ctyp< ( $list:[t :: tl]$ ) >> ]
    | "ctyp1"
      [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ]
    | "ctyp2"
      [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >>
      | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ]
    | "simple"
      [ "'"; i = ident -> <:ctyp< '$i$ >>
      | "_" -> <:ctyp< _ >>
      | id = LIDENT -> split_ctyp_module loc id
      | i = UIDENT -> <:ctyp< $uid:i$ >>
      | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")";
        i = ctyp LEVEL "ctyp2" ->
          List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl]
      | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ]
  ;
  (* Identifiers *)
  ident:
    [ [ i = LIDENT -> i
      | i = UIDENT -> i ] ]
  ;
  mod_ident:
    [ [ i = LIDENT ->
          match split_expr_module loc i with
          [ <:expr< $uid:m$ . $lid:v$ >> -> [m; v]
          | <:expr< $uid:m$ . $uid:v$ >> -> [m; v]
          | <:expr< $lid:v$ >> -> [v]
          | _ -> raise (Stream.Error "bad identifier") ]
      | i = UIDENT -> [i] ] ]
  ;
  (* Miscellaneous *)
  direction_flag:
    [ [ "to" -> True
      | "downto" -> False ] ]
  ;
END;

(* Objects and Classes *)

value rec class_type_of_ctyp loc t =
  match t with
  [ <:ctyp< $lid:i$ >> -> <:class_type< $list:[i]$ >>
  | <:ctyp< $uid:m$.$t$ >> -> <:class_type< $list:[m :: type_id_list t]$ >>
  | _ -> raise_with_loc loc (Stream.Error "lowercase identifier expected") ]
and type_id_list =
  fun
  [ <:ctyp< $uid:m$.$t$ >> -> [m :: type_id_list t]
  | <:ctyp< $lid:i$ >> -> [i]
  | t ->
      raise_with_loc (loc_of_node t)
        (Stream.Error "lowercase identifier expected") ]
;

type spat_comp =
  [ SpTrm of MLast.loc and MLast.patt and option MLast.expr
  | SpNtr of MLast.loc and MLast.patt and MLast.expr
  | SpStr of MLast.loc and MLast.patt ]
;
type sexp_comp =
  [ SeTrm of MLast.loc and MLast.expr
  | SeNtr of MLast.loc and MLast.expr ]
;

value strm_n = "strm__";
value peek_fun loc = <:expr< stream_peek >>;
value junk_fun loc = <:expr< stream_junk >>;

(* Parsers. *)
(* In syntax generated, many cases are optimisations. *)

value rec pattern_eq_expression p e =
  match (p, e) with
  [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b
  | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b
  | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) ->
      pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2
  | _ -> False ]
;

value is_raise e =
  match e with
  [ <:expr< raise $_$ >> -> True
  | _ -> False ]
;

value is_raise_failure e =
  match e with
  [ <:expr< raise Parse_failure >> -> True
  | _ -> False ]
;

value rec handle_failure e =
  match e with
  [ <:expr< try $te$ with [ Parse_failure -> $e$] >> -> handle_failure e
  | <:expr< match $me$ with [ $list:pel$ ] >> ->
      handle_failure me &&
      List.for_all
        (fun
         [ (_, None, e) -> handle_failure e
         | _ -> False ])
        pel
  | <:expr< let $list:pel$ in $e$ >> ->
      List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e
  | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> |
    <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> ->
      True
  | <:expr< raise $e$ >> ->
      match e with
      [ <:expr< Parse_failure >> -> False
      | _ -> True ]
  | <:expr< $f$ $x$ >> ->
      is_constr_apply f && handle_failure f && handle_failure x
  | _ -> False ]
and is_constr_apply =
  fun
  [ <:expr< $uid:_$ >> -> True
  | <:expr< $lid:_$ >> -> False
  | <:expr< $x$ $_$ >> -> is_constr_apply x
  | _ -> False ]
;

value rec subst v e =
  let loc = MLast.loc_of_expr e in
  match e with
  [ <:expr< $lid:x$ >> ->
      let x = if x = v then strm_n else x in
      <:expr< $lid:x$ >>
  | <:expr< $uid:_$ >> -> e
  | <:expr< $int:_$ >> -> e
  | <:expr< $chr:_$ >> -> e
  | <:expr< $str:_$ >> -> e
  | <:expr< $_$ . $_$ >> -> e
  | <:expr< let $rec:rf$ $list:pel$ in $e$ >> ->
      <:expr< let $rec:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >>
  | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >>
  | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >>
  | _ -> raise Not_found ]
and subst_pe v (p, e) =
  match p with
  [ <:patt< $lid:v'$ >> -> if v = v' then (p, e) else (p, subst v e)
  | _ -> raise Not_found ]
;

value stream_pattern_component skont ckont =
  fun
  [ SpTrm loc p wo ->
      <:expr< match $peek_fun loc$ $lid:strm_n$ with
              [ Some $p$ $when:wo$ ->
                  do { $junk_fun loc$ $lid:strm_n$; $skont$ }
              | _ -> $ckont$ ] >>
  | SpNtr loc p e ->
      let e =
        match e with
        [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n ->
            e
        | _ -> <:expr< $e$ $lid:strm_n$ >> ]
      in
      if pattern_eq_expression p skont then
        if is_raise_failure ckont then e
        else if handle_failure e then e
        else <:expr< try $e$ with [ Parse_failure -> $ckont$ ] >>
      else if is_raise_failure ckont then <:expr< let $p$ = $e$ in $skont$ >>
      else if pattern_eq_expression <:patt< Some $p$ >> skont then
        <:expr< try Some $e$ with [ Parse_failure -> $ckont$ ] >>
      else if is_raise ckont then
        let tst =
          if handle_failure e then e
          else <:expr< try $e$ with [ Parse_failure -> $ckont$ ] >>
        in
        <:expr< let $p$ = $tst$ in $skont$ >>
      else
        <:expr< match try Some $e$ with [ Parse_failure -> None ] with
                [ Some $p$ -> $skont$
                | _ -> $ckont$ ] >>
  | SpStr loc p ->
      try
        match p with
        [ <:patt< $lid:v$ >> -> subst v skont
        | _ -> raise Not_found ]
      with
      [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ]
;

value rec stream_pattern loc epo e ekont =
  fun
  [ [] ->
      match epo with
      [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >>
      | _ -> e ]
  | [(spc, err) :: spcl] ->
      let skont =
        let ekont err =
          let str =
            match err with
            [ Some estr -> estr
            | _ -> <:expr< "" >> ]
          in
          <:expr< raise (Parse_error) >>
        in
        stream_pattern loc epo e ekont spcl
      in
      let ckont = ekont err in
      stream_pattern_component skont ckont spc ]
;

value stream_patterns_term loc ekont tspel =
  let pel =
    List.map
      (fun (p, w, loc, spcl, epo, e) ->
         let p = <:patt< Some $p$ >> in
         let e =
           let ekont err =
             let str =
               match err with
               [ Some estr -> estr
               | _ -> <:expr< "" >> ]
             in
             <:expr< raise (Parse_error) >>
           in
           let skont = stream_pattern loc epo e ekont spcl in
           <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >>
         in
         (p, w, e))
      tspel
  in
  let pel = pel @ [(<:patt< _ >>, None, ekont ())] in
  <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >>
;

value rec group_terms =
  fun
  [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] ->
      let (tspel, spel) = group_terms spel in
      ([(p, w, loc, spcl, epo, e) :: tspel], spel)
  | spel -> ([], spel) ]
;

value rec parser_cases loc =
  fun
  [ [] -> <:expr< raise Parse_failure >>
  | spel ->
      match group_terms spel with
      [ ([], [(spcl, epo, e) :: spel]) ->
          stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl
      | (tspel, spel) ->
          stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ]
;

value cparser loc bpo pc =
  let e = parser_cases loc pc in
  let e =
    match bpo with
    [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >>
    | None -> e ]
  in
  let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in
  <:expr< fun $p$ -> $e$ >>
;

value cparser_match loc me bpo pc =
  let pc = parser_cases loc pc in
  let e =
    match bpo with
    [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
    | None -> pc ]
  in
  <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >>
;

(* streams *)

value rec not_computing =
  fun
  [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> |
    <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> ->
      True
  | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y
  | _ -> False ]
and is_cons_apply_not_computing =
  fun
  [ <:expr< $uid:_$ >> -> True
  | <:expr< $lid:_$ >> -> False
  | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y
  | _ -> False ]
;

value slazy loc e =
  match e with
  [ <:expr< $f$ () >> ->
      match f with
      [ <:expr< $lid:_$ >> -> f
      | _ -> <:expr< fun _ -> $e$ >> ]
  | _ -> <:expr< fun _ -> $e$ >> ]
;

value rec cstream gloc =
  fun
  [ [] ->
      let loc = gloc in
      <:expr< Stream.sempty >>
  | [SeTrm loc e] ->
      if not_computing e then <:expr< Stream.ising $e$ >>
      else <:expr< Stream.lsing $slazy loc e$ >>
  | [SeTrm loc e :: secl] ->
      if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >>
      else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >>
  | [SeNtr loc e] ->
      if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >>
  | [SeNtr loc e :: secl] ->
      if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >>
      else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ]
;

(* Syntax extensions in Ocaml grammar *)

EXTEND
  GLOBAL: expr;
  expr: LEVEL "expr1"
    [ [ "function"; OPT "|"; pcl = LIST1 parser_case SEP "|" ->
          let po = None in
          <:expr< $cparser loc po pcl$ >>
      | "match"; e = SELF; "with"; OPT "|"; pcl = LIST1 parser_case SEP "|" ->
          <:expr< $cparser_match loc e None pcl$ >> ] ]
  ;
  parser_case:
    [ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr ->
          (sp, po, e) ] ]
  ;
  stream_patt:
    [ [ spc = stream_patt_comp -> [(spc, None)]
      | spc = stream_patt_comp; ";" -> [(spc, None)]
      | spc = stream_patt_comp; ";"; sp = stream_patt_comp_err_list ->
          [(spc, None) :: sp]
      | -> (* empty *) [] ] ]
  ;
  stream_patt_comp_err_list:
    [ [ spc = stream_patt_comp_err -> [spc]
      | spc = stream_patt_comp_err; ";" -> [spc]
      | spc = stream_patt_comp_err; ";"; sp = SELF -> [spc :: sp] ] ]
  ;
  stream_patt_comp:
    [ [ "'"; p = patt; eo = OPT [ "when"; e = expr LEVEL "expr1" -> e ] ->
          SpTrm loc p eo
      | e = expr LEVEL "simple"; p = patt -> SpNtr loc p e
      | e = expr LEVEL "simple" ->
          match e with
          [ <:expr< $lid:i$ >> -> SpStr loc <:patt< $lid:i$ >>
          | _ -> raise_with_loc loc (Stream.Error "pattern expected") ] ] ]
  ;
  stream_patt_comp_err:
    [ [ spc = stream_patt_comp;
        eo = OPT [ "??"; e = expr LEVEL "expr1" -> e ] ->
          (spc, eo) ] ]
  ;
  ipatt:
    [ [ i = LIDENT -> <:patt< $lid:i$ >>
      | "_" -> <:patt< _ >> ] ]
  ;
  expr: LEVEL "simple"
    [ [ "[<"; ">]" -> <:expr< $cstream loc []$ >>
      | "[<"; sel = stream_expr_comp_list; ">]" ->
          <:expr< $cstream loc sel$ >> ] ]
  ;
  stream_expr_comp_list:
    [ [ se = stream_expr_comp; ";"; sel = SELF -> [se :: sel]
      | se = stream_expr_comp; ";" -> [se]
      | se = stream_expr_comp -> [se] ] ]
  ;
  stream_expr_comp:
    [ [ "'"; e = expr LEVEL "expr1" -> SeTrm loc e
      | e = expr LEVEL "expr1" -> SeNtr loc e ] ]
  ;
END;

Pcaml.add_option "-nolibcl" (Arg.Set no_libcl)
  " Don't open Libcl at beginning of compilations";