ocaml/camlp4/etc/pa_lispr.ml

(* camlp4 pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *)
(* File generated by pretty print; do not edit! *)

open Pcaml;
open Stdpp;

type choice 'a 'b =
  [ Left of 'a
  | Right of 'b ]
;

(* Buffer *)

module Buff =
  struct
    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 get len = String.sub buff.val 0 len;
  end
;

(* Lexer *)

value rec skip_to_eol =
  parser
  [ [: `'\n' | '\r' :] -> ()
  | [: `_; s :] -> skip_to_eol s ]
;

value no_ident = ['('; ')'; ' '; '\t'; '\n'; '\r'; ';'];

value rec ident len =
  parser
  [ [: `x when not (List.mem x no_ident); s :] -> ident (Buff.store len x) s
  | [: :] -> Buff.get len ]
;

value rec string len =
  parser
  [ [: `'"' :] -> Buff.get len
  | [: `'\\'; `c; s :] -> string (Buff.store (Buff.store len '\\') c) s
  | [: `x; s :] -> string (Buff.store len x) s ]
;

value rec number len =
  parser
  [ [: `('0'..'9' as c); s :] -> number (Buff.store len c) s
  | [: :] -> ("INT", Buff.get len) ]
;

value char_or_quote_id x =
  parser
  [ [: `''' :] -> ("CHAR", String.make 1 x)
  | [: s :] ->
      let len = Buff.store (Buff.store 0 ''') x in
      ("LIDENT", ident len s) ]
;

value rec char len =
  parser
  [ [: `''' :] -> len
  | [: `x; s :] -> char (Buff.store len x) s ]
;

value quote =
  parser
  [ [: `'\\'; len = char (Buff.store 0 '\\') :] -> ("CHAR", Buff.get len)
  | [: `x; s :] -> char_or_quote_id x s ]
;

value rec lexer kwt =
  parser bp
  [ [: `' ' | '\t' | '\n' | '\r'; s :] -> lexer kwt s
  | [: `';'; a = semi kwt bp :] -> a
  | [: `'(' :] -> (("", "("), (bp, bp + 1))
  | [: `')' :] -> (("", ")"), (bp, bp + 1))
  | [: `'"'; s = string 0 :] ep -> (("STRING", s), (bp, ep))
  | [: `'''; tok = quote :] ep -> (tok, (bp, ep))
  | [: `'<'; tok = less :] ep -> (tok, (bp, ep))
  | [: `('0'..'9' as c); n = number (Buff.store 0 c) :] ep -> (n, (bp, ep))
  | [: `x; s = ident (Buff.store 0 x) :] ep ->
      let con =
        try do { (Hashtbl.find kwt s : unit); "" } with
        [ Not_found ->
            match x with
            [ 'A'..'Z' -> "UIDENT"
            | _ -> "LIDENT" ] ]
      in
      ((con, s), (bp, ep))
  | [: :] -> (("EOI", ""), (bp, bp + 1)) ]
and semi kwt bp =
  parser
  [ [: `';'; _ = skip_to_eol; s :] -> lexer kwt s
  | [: :] ep -> (("", ";"), (bp, ep)) ]
and less =
  parser
  [ [: `':'; lab = label 0; `'<' ? "'<' expected"; q = quotation 0 :] ->
      ("QUOT", lab ^ ":" ^ q)
  | [: :] -> ("LIDENT", "<") ]
and label len =
  parser
  [ [: `('a'..'z' | 'A'..'Z' | '_' as c); s :] -> label (Buff.store len c) s
  | [: :] -> Buff.get len ]
and quotation len =
  parser
  [ [: `'>'; s :] -> quotation_greater len s
  | [: `x; s :] -> quotation (Buff.store len x) s
  | [: :] -> failwith "quotation not terminated" ]
and quotation_greater len =
  parser
  [ [: `'>' :] -> Buff.get len
  | [: a = quotation (Buff.store len '>') :] -> a ]
;

value lexer_using kwt (con, prm) =
  match con with
  [ "CHAR" | "EOI" | "INT" | "LIDENT" | "QUOT" | "STRING" | "UIDENT" -> ()
  | "ANTIQUOT" -> ()
  | "" ->
      try Hashtbl.find kwt prm with [ Not_found -> Hashtbl.add kwt prm () ]
  | _ ->
      raise
        (Token.Error
           ("the constructor \"" ^ con ^ "\" is not recognized by Plexer")) ]
;

value lexer_text (con, prm) =
  if con = "" then "'" ^ prm ^ "'"
  else if prm = "" then con
  else con ^ " \"" ^ prm ^ "\""
;

value lexer_make () =
  let kwt = Hashtbl.create 89 in
  {Token.func = Token.lexer_func_of_parser (lexer kwt);
   Token.using = lexer_using kwt; Token.removing = fun [];
   Token.tparse _ = None; Token.text = lexer_text}
;

(* Building AST *)

type sexpr =
  [ Sexpr of MLast.loc and list sexpr
  | Satom of MLast.loc and atom and string
  | Squot of MLast.loc and string and string ]
and atom =
  [ Alid
  | Auid
  | Aint
  | Achar
  | Astring ]
;

value error_loc loc err =
  raise_with_loc loc (Stream.Error (err ^ " expected"))
;
value error se err =
  let loc =
    match se with [ Satom loc _ _ | Sexpr loc _ | Squot loc _ _ -> loc ]
  in
  error_loc loc err
;

value expr_id loc s =
  match s.[0] with
  [ 'A'..'Z' -> <:expr< $uid:s$ >>
  | _ -> <:expr< $lid:s$ >> ]
;

value patt_id loc s =
  match s.[0] with
  [ 'A'..'Z' -> <:patt< $uid:s$ >>
  | _ -> <:patt< $lid:s$ >> ]
;

value ctyp_id loc s =
  match s.[0] with
  [ ''' ->
      let s = String.sub s 1 (String.length s - 1) in
      <:ctyp< '$s$ >>
  | 'A'..'Z' -> <:ctyp< $uid:s$ >>
  | _ -> <:ctyp< $lid:s$ >> ]
;

value strm_n = "strm__";
value peek_fun loc = <:expr< Stream.peek >>;
value junk_fun loc = <:expr< Stream.junk >>;

value rec module_expr_se =
  fun
  [ Sexpr loc [Satom _ Alid "struct" :: sl] ->
      let mel = List.map str_item_se sl in
      <:module_expr< struct $list:mel$ end >>
  | Satom loc Auid s -> <:module_expr< $uid:s$ >>
  | se -> error se "module expr" ]
and str_item_se se =
  match se with
  [ Satom loc _ _ | Squot loc _ _ ->
      let e = expr_se se in
      <:str_item< $exp:e$ >>
  | Sexpr loc [Satom _ Alid "module"; Satom _ Auid i; se] ->
      let mb = module_binding_se se in
      <:str_item< module $i$ = $mb$ >>
  | Sexpr loc [Satom _ Alid "open"; Satom _ Auid s] ->
      let s = [s] in
      <:str_item< open $s$ >>
  | Sexpr loc [Satom _ Alid "type" :: sel] ->
      let tdl = type_declaration_list_se sel in
      <:str_item< type $list:tdl$ >>
  | Sexpr loc [Satom _ Alid "value" :: sel] ->
      let (r, sel) =
        match sel with
        [ [Satom _ Alid "rec" :: sel] -> (True, sel)
        | _ -> (False, sel) ]
      in
      let lbs = value_binding_se sel in
      <:str_item< value $rec:r$ $list:lbs$ >>
  | Sexpr loc _ ->
      let e = expr_se se in
      <:str_item< $exp:e$ >> ]
and value_binding_se =
  fun
  [ [se1; se2 :: sel] -> [(ipatt_se se1, expr_se se2) :: value_binding_se sel]
  | [] -> []
  | [se :: _] -> error se "value_binding" ]
and module_binding_se se = module_expr_se se
and expr_se =
  fun
  [ Satom loc (Alid | Auid) s -> expr_ident_se loc s
  | Satom loc Aint s -> <:expr< $int:s$ >>
  | Satom loc Achar s -> <:expr< $chr:s$ >>
  | Satom loc Astring s -> <:expr< $str:s$ >>
  | Sexpr loc [] -> <:expr< () >>
  | Sexpr loc [Satom _ Alid "if"; se; se1] ->
      let e = expr_se se in
      let e1 = expr_se se1 in
      <:expr< if $e$ then $e1$ else () >>
  | Sexpr loc [Satom _ Alid "if"; se; se1; se2] ->
      let e = expr_se se in
      let e1 = expr_se se1 in
      let e2 = expr_se se2 in
      <:expr< if $e$ then $e1$ else $e2$ >>
  | Sexpr loc [Satom loc1 Alid "lambda"] -> <:expr< fun [] >>
  | Sexpr loc [Satom loc1 Alid "lambda"; sep :: sel] ->
      let e = progn_se loc1 sel in
      match ipatt_opt_se sep with
      [ Left p -> <:expr< fun $p$ -> $e$ >>
      | Right (se, sel) ->
          List.fold_right
            (fun se e ->
               let p = ipatt_se se in
               <:expr< fun $p$ -> $e$ >>)
            [se :: sel] e ]
  | Sexpr loc [Satom _ Alid "lambda_match" :: sel] ->
      let pel = List.map (match_case loc) sel in
      <:expr< fun [ $list:pel$ ] >>
  | Sexpr loc [Satom _ Alid "let" :: sel] ->
      let (r, sel) =
        match sel with
        [ [Satom _ Alid "rec" :: sel] -> (True, sel)
        | _ -> (False, sel) ]
      in
      match sel with
      [ [Sexpr _ sel1 :: sel2] ->
          let lbs = List.map let_binding_se sel1 in
          let e = progn_se loc sel2 in
          <:expr< let $rec:r$ $list:lbs$ in $e$ >>
      | [se :: _] -> error se "let_binding"
      | _ -> error_loc loc "let_binding" ]
  | Sexpr loc [Satom _ Alid "let*" :: sel] ->
      match sel with
      [ [Sexpr _ sel1 :: sel2] ->
          List.fold_right
            (fun se ek ->
               let (p, e) = let_binding_se se in
               <:expr< let $p$ = $e$ in $ek$ >>)
            sel1 (progn_se loc sel2)
      | [se :: _] -> error se "let_binding"
      | _ -> error_loc loc "let_binding" ]
  | Sexpr loc [Satom _ Alid "match"; se :: sel] ->
      let e = expr_se se in
      let pel = List.map (match_case loc) sel in
      <:expr< match $e$ with [ $list:pel$ ] >>
  | Sexpr loc [Satom _ Alid "parser" :: sel] ->
      let e =
        match sel with
        [ [(Satom _ _ _ as se) :: sel] ->
            let p = patt_se se in
            let pc = parser_cases_se loc sel in
            <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>
        | _ -> parser_cases_se loc sel ]
      in
      <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>
  | Sexpr loc [Satom _ Alid "try"; se :: sel] ->
      let e = expr_se se in
      let pel = List.map (match_case loc) sel in
      <:expr< try $e$ with [ $list:pel$ ] >>
  | Sexpr loc [Satom _ Alid "progn" :: sel] ->
      let el = List.map expr_se sel in
      <:expr< do { $list:el$ } >>
  | Sexpr loc [Satom _ Alid "while"; se :: sel] ->
      let e = expr_se se in
      let el = List.map expr_se sel in
      <:expr< while $e$ do { $list:el$ } >>
  | Sexpr loc [Satom _ Alid ":="; se1; se2] ->
      let e2 = expr_se se2 in
      match expr_se se1 with
      [ <:expr< $uid:"()"$ $e1$ $i$ >> -> <:expr< $e1$.($i$) := $e2$ >>
      | e1 -> <:expr< $e1$ := $e2$ >> ]
  | Sexpr loc [Satom _ Alid "[]"; se1; se2] ->
      let e1 = expr_se se1 in
      let e2 = expr_se se2 in
      <:expr< $e1$.[$e2$] >>
  | Sexpr loc [Satom _ Alid "," :: sel] ->
      let el = List.map expr_se sel in
      <:expr< ( $list:el$ ) >>
  | Sexpr loc [Satom _ Alid "{}" :: sel] ->
      let lel = List.map (label_expr_se loc) sel in
      <:expr< { $list:lel$ } >>
  | Sexpr loc [Satom _ Alid ":"; se1; se2] ->
      let e = expr_se se1 in
      let t = ctyp_se se2 in
      <:expr< ( $e$ : $t$ ) >>
  | Sexpr loc [Satom _ Alid "list" :: sel] ->
      let rec loop =
        fun
        [ [] -> <:expr< [] >>
        | [se1; Satom _ Alid "::"; se2] ->
            let e = expr_se se1 in
            let el = expr_se se2 in
            <:expr< [$e$ :: $el$] >>
        | [se :: sel] ->
            let e = expr_se se in
            let el = loop sel in
            <:expr< [$e$ :: $el$] >> ]
      in
      loop sel
  | Sexpr loc [se :: sel] ->
      List.fold_left
        (fun e se ->
           let e1 = expr_se se in
           <:expr< $e$ $e1$ >>)
        (expr_se se) sel
  | Squot loc typ txt -> Pcaml.handle_expr_quotation loc (typ, txt) ]
and progn_se loc =
  fun
  [ [] -> <:expr< () >>
  | [se] -> expr_se se
  | sel ->
      let el = List.map expr_se sel in
      <:expr< do { $list:el$ } >> ]
and let_binding_se =
  fun
  [ Sexpr loc [se1; se2] -> (ipatt_se se1, expr_se se2)
  | se -> error se "let_binding" ]
and match_case loc =
  fun
  [ Sexpr _ [se1; se2] -> (patt_se se1, None, expr_se se2)
  | Sexpr _ [se1; sew; se2] -> (patt_se se1, Some (expr_se sew), expr_se se2)
  | se -> error se "match_case" ]
and label_expr_se loc =
  fun
  [ Sexpr _ [se1; se2] -> (patt_se se1, expr_se se2)
  | se -> error se "label_expr" ]
and expr_ident_se loc s =
  if s.[0] = '<' then <:expr< $lid:s$ >>
  else
    let rec loop ibeg i =
      if i = String.length s then
        if i > ibeg then expr_id loc (String.sub s ibeg (i - ibeg))
        else
          raise_with_loc (fst loc + i - 1, fst loc + i)
            (Stream.Error "expr expected")
      else if s.[i] = '.' then
        if i > ibeg then
          let e1 = expr_id loc (String.sub s ibeg (i - ibeg)) in
          let e2 = loop (i + 1) (i + 1) in
          <:expr< $e1$ . $e2$ >>
        else
          raise_with_loc (fst loc + i - 1, fst loc + i + 1)
            (Stream.Error "expr expected")
      else loop ibeg (i + 1)
    in
    loop 0 0
and parser_cases_se loc =
  fun
  [ [] -> <:expr< raise Stream.Failure >>
  | [Sexpr loc [Sexpr _ spsel :: act] :: sel] ->
      let ekont _ = parser_cases_se loc sel in
      let act =
        match act with
        [ [se] -> expr_se se
        | [sep; se] ->
            let p = patt_se sep in
            let e = expr_se se in
            <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>
        | _ -> error_loc loc "parser_case" ]
      in
      stream_pattern_se loc act ekont spsel
  | [se :: _] -> error se "parser_case" ]
and stream_pattern_se loc act ekont =
  fun
  [ [] -> act
  | [se :: sel] ->
      let ckont err = <:expr< raise (Stream.Error $err$) >> in
      let skont = stream_pattern_se loc act ckont sel in
      stream_pattern_component skont ekont <:expr< "" >> se ]
and stream_pattern_component skont ekont err =
  fun
  [ Sexpr loc [Satom _ Alid "`"; se :: wol] ->
      let wo =
        match wol with
        [ [se] -> Some (expr_se se)
        | [] -> None
        | _ -> error_loc loc "stream_pattern_component" ]
      in
      let e = peek_fun loc in
      let p = patt_se se in
      let j = junk_fun loc in
      let k = ekont err in
      <:expr< match $e$ $lid:strm_n$ with
       [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ }
       | _ -> $k$ ] >>
  | Sexpr loc [se1; se2] ->
      let p = patt_se se1 in
      let e =
        let e = expr_se se2 in
        <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>
      in
      let k = ekont err in
      <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>
  | Sexpr loc [Satom _ Alid "?"; se1; se2] ->
      stream_pattern_component skont ekont (expr_se se2) se1
  | Satom loc Alid s -> <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>
  | se -> error se "stream_pattern_component" ]
and patt_se =
  fun
  [ Satom loc Alid "_" -> <:patt< _ >>
  | Satom loc (Alid | Auid) s -> patt_ident_se loc s
  | Satom loc Aint s -> <:patt< $int:s$ >>
  | Satom loc Achar s -> <:patt< $chr:s$ >>
  | Satom loc Astring s -> <:patt< $str:s$ >>
  | Sexpr loc [Satom _ Alid "or"; se :: sel] ->
      List.fold_left
        (fun p se ->
           let p1 = patt_se se in
           <:patt< $p$ | $p1$ >>)
        (patt_se se) sel
  | Sexpr loc [Satom _ Alid "range"; se1; se2] ->
      let p1 = patt_se se1 in
      let p2 = patt_se se2 in
      <:patt< $p1$ .. $p2$ >>
  | Sexpr loc [Satom _ Alid "," :: sel] ->
      let pl = List.map patt_se sel in
      <:patt< ( $list:pl$ ) >>
  | Sexpr loc [Satom _ Alid "as"; se1; se2] ->
      let p1 = patt_se se1 in
      let p2 = patt_se se2 in
      <:patt< ($p1$ as $p2$) >>
  | Sexpr loc [Satom _ Alid "list" :: sel] ->
      let rec loop =
        fun
        [ [] -> <:patt< [] >>
        | [se1; Satom _ Alid "::"; se2] ->
            let p = patt_se se1 in
            let pl = patt_se se2 in
            <:patt< [$p$ :: $pl$] >>
        | [se :: sel] ->
            let p = patt_se se in
            let pl = loop sel in
            <:patt< [$p$ :: $pl$] >> ]
      in
      loop sel
  | Sexpr loc [se :: sel] ->
      List.fold_left
        (fun p se ->
           let p1 = patt_se se in
           <:patt< $p$ $p1$ >>)
        (patt_se se) sel
  | Sexpr loc [] -> <:patt< () >>
  | Squot loc typ txt -> Pcaml.handle_patt_quotation loc (typ, txt) ]
and patt_ident_se loc s =
  loop 0 0 where rec loop ibeg i =
    if i = String.length s then
      if i > ibeg then patt_id loc (String.sub s ibeg (i - ibeg))
      else
        raise_with_loc (fst loc + i - 1, fst loc + i)
          (Stream.Error "patt expected")
    else if s.[i] = '.' then
      if i > ibeg then
        let p1 = patt_id loc (String.sub s ibeg (i - ibeg)) in
        let p2 = loop (i + 1) (i + 1) in
        <:patt< $p1$ . $p2$ >>
      else
        raise_with_loc (fst loc + i - 1, fst loc + i + 1)
          (Stream.Error "patt expected")
    else loop ibeg (i + 1)
and ipatt_se se =
  match ipatt_opt_se se with
  [ Left p -> p
  | Right (se, _) -> error se "ipatt" ]
and ipatt_opt_se =
  fun
  [ Satom loc Alid "_" -> Left <:patt< _ >>
  | Satom loc Alid s -> Left <:patt< $lid:s$ >>
  | Sexpr loc [Satom _ Alid "," :: sel] ->
      let pl = List.map ipatt_se sel in
      Left <:patt< ( $list:pl$ ) >>
  | Sexpr loc [] -> Left <:patt< () >>
  | Sexpr loc [se :: sel] -> Right (se, sel)
  | se -> error se "ipatt" ]
and type_declaration_list_se =
  fun
  [ [se1; se2 :: sel] ->
      let (n1, loc1, tpl) =
        match se1 with
        [ Sexpr _ [Satom loc Alid n :: sel] ->
            (n, loc, List.map type_parameter_se sel)
        | Satom loc Alid n -> (n, loc, [])
        | se -> error se "type declaration" ]
      in
      [((loc1, n1), tpl, ctyp_se se2, []) :: type_declaration_list_se sel]
  | [] -> []
  | [se :: _] -> error se "type_declaration" ]
and type_parameter_se =
  fun
  [ Satom _ Alid s when String.length s >= 2 && s.[0] = ''' ->
      (String.sub s 1 (String.length s - 1), (False, False))
  | se -> error se "type_parameter" ]
and ctyp_se =
  fun
  [ Sexpr loc [Satom _ Alid "sum" :: sel] ->
      let cdl = List.map constructor_declaration_se sel in
      <:ctyp< [ $list:cdl$ ] >>
  | Sexpr loc [se :: sel] ->
      List.fold_left
        (fun t se ->
           let t2 = ctyp_se se in
           <:ctyp< $t$ $t2$ >>)
        (ctyp_se se) sel
  | Satom loc (Alid | Auid) s -> ctyp_ident_se loc s
  | se -> error se "ctyp" ]
and ctyp_ident_se loc s =
  loop 0 0 where rec loop ibeg i =
    if i = String.length s then
      if i > ibeg then ctyp_id loc (String.sub s ibeg (i - ibeg))
      else
        raise_with_loc (fst loc + i - 1, fst loc + i)
          (Stream.Error "ctyp expected")
    else if s.[i] = '.' then
      if i > ibeg then
        let t1 = ctyp_id loc (String.sub s ibeg (i - ibeg)) in
        let t2 = loop (i + 1) (i + 1) in
        <:ctyp< $t1$ . $t2$ >>
      else
        raise_with_loc (fst loc + i - 1, fst loc + i + 1)
          (Stream.Error "ctyp expected")
    else loop ibeg (i + 1)
and constructor_declaration_se =
  fun
  [ Sexpr loc [Satom _ Auid ci :: sel] -> (ci, List.map ctyp_se sel)
  | se -> error se "constructor_declaration" ]
;

value top_phrase_se se =
  match se with
  [ Satom loc _ _ | Squot loc _ _ -> str_item_se se
  | Sexpr loc [Satom _ Alid s :: sl] ->
      if s.[0] = '#' then
        let n = String.sub s 1 (String.length s - 1) in
        match sl with
        [ [Satom _ Astring s] -> MLast.StDir loc n (Some <:expr< $str:s$ >>)
        | _ -> match () with [] ]
      else str_item_se se
  | Sexpr loc _ -> str_item_se se ]
;

(* Parser *)

value phony_quot = ref False;
Pcaml.add_option "-phony_quot" (Arg.Set phony_quot) "phony quotations";

Pcaml.no_constructors_arity.val := False;

do {
  Grammar.Unsafe.reinit_gram gram (lexer_make ());
  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
};

value sexpr = Grammar.Entry.create gram "sexpr";
value atom = Grammar.Entry.create gram "atom";

EXTEND
  implem:
    [ [ st = LIST0 [ s = str_item -> (s, loc) ]; EOI -> (st, False) ] ]
  ;
  top_phrase:
    [ [ se = sexpr -> Some (top_phrase_se se)
      | EOI -> None ] ]
  ;
  use_file:
    [ [ l = LIST0 sexpr; EOI -> (List.map top_phrase_se l, False) ] ]
  ;
  str_item:
    [ [ se = sexpr -> str_item_se se
      | e = expr -> <:str_item< $exp:e$ >> ] ]
  ;
  expr:
    [ "top"
      [ se = sexpr -> expr_se se ] ]
  ;
  patt:
    [ [ se = sexpr -> patt_se se ] ]
  ;
  sexpr:
    [ [ "("; sl = LIST0 sexpr; ")" -> Sexpr loc sl
      | a = atom -> Satom loc Alid a
      | s = LIDENT -> Satom loc Alid s
      | s = UIDENT -> Satom loc Auid s
      | s = INT -> Satom loc Aint s
      | s = CHAR -> Satom loc Achar s
      | s = STRING -> Satom loc Astring s
      | s = QUOT ->
          let i = String.index s ':' in
          let typ = String.sub s 0 i in
          let txt = String.sub s (i + 1) (String.length s - i - 1) in
          if phony_quot.val then
            Satom loc Alid ("<:" ^ typ ^ "<" ^ txt ^ ">>")
          else Squot loc typ txt ] ]
  ;
  atom:
    [ [ "_" -> "_"
      | "," -> ","
      | "=" -> "="
      | ":" -> ":"
      | "." -> "." ] ]
  ;
END;