ocaml.opp.exp 324 KB
Newer Older
1
%{
POTTIER Francois's avatar
POTTIER Francois committed
2 3 4 5 6 7 8
module Pervasives = Stdlib
(* In 4.08+dev, 'Pervasives' is deprecated in favor of Stdlib. We need
   to disable the deprecation warning not because of any OCaml code
   below, but because Menhir generates code using Pervasives (in the
   interpretation of $symbolstartpos). Yes, this is ugly, but right now
   we don't see an easier way.  *)

9 10 11
open Asttypes
open Longident
open Parsetree
12 13
open Ast_helper
open Docstrings
POTTIER Francois's avatar
POTTIER Francois committed
14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57
open Docstrings.WithMenhir

let mkloc = Location.mkloc
let mknoloc = Location.mknoloc

let make_loc (startpos, endpos) = {
  Location.loc_start = startpos;
  Location.loc_end = endpos;
  Location.loc_ghost = false;
}

let ghost_loc (startpos, endpos) = {
  Location.loc_start = startpos;
  Location.loc_end = endpos;
  Location.loc_ghost = true;
}

let mktyp ~loc d = Typ.mk ~loc:(make_loc loc) d
let mkpat ~loc d = Pat.mk ~loc:(make_loc loc) d
let mkexp ~loc d = Exp.mk ~loc:(make_loc loc) d
let mkmty ~loc ?attrs d = Mty.mk ~loc:(make_loc loc) ?attrs d
let mksig ~loc d = Sig.mk ~loc:(make_loc loc) d
let mkmod ~loc ?attrs d = Mod.mk ~loc:(make_loc loc) ?attrs d
let mkstr ~loc d = Str.mk ~loc:(make_loc loc) d
let mkclass ~loc ?attrs d = Cl.mk ~loc:(make_loc loc) ?attrs d
let mkcty ~loc ?attrs d = Cty.mk ~loc:(make_loc loc) ?attrs d

let mkctf ~loc ?attrs ?docs d =
  Ctf.mk ~loc:(make_loc loc) ?attrs ?docs d
let mkcf ~loc ?attrs ?docs d =
  Cf.mk ~loc:(make_loc loc) ?attrs ?docs d

let mkrhs rhs loc = mkloc rhs (make_loc loc)
let ghrhs rhs loc = mkloc rhs (ghost_loc loc)

let reloc_pat ~loc x = { x with ppat_loc = make_loc loc };;
let reloc_exp ~loc x = { x with pexp_loc = make_loc loc };;
let reloc_typ ~loc x = { x with ptyp_loc = make_loc loc };;

let mkoperator ~loc name =
  mkexp ~loc (Pexp_ident(mkrhs (Lident name) loc))

let mkpatvar ~loc name =
  mkpat ~loc (Ppat_var (mkrhs name loc))
58 59 60

(*
  Ghost expressions and patterns:
61
  expressions and patterns that do not appear explicitly in the
62 63
  source file they have the loc_ghost flag set to true.
  Then the profiler will not try to instrument them and the
64
  -annot option will not try to display their type.
65 66 67 68 69 70 71 72 73 74 75

  Every grammar rule that generates an element with a location must
  make at most one non-ghost element, the topmost one.

  How to tell whether your location must be ghost:
  A location corresponds to a range of characters in the source file.
  If the location contains a piece of code that is syntactically
  valid (according to the documentation), and corresponds to the
  AST node, then the location must be real; in all other cases,
  it must be ghost.
*)
POTTIER Francois's avatar
POTTIER Francois committed
76 77 78 79 80 81
let ghexp ~loc d = Exp.mk ~loc:(ghost_loc loc) d
let ghpat ~loc d = Pat.mk ~loc:(ghost_loc loc) d
let ghtyp ~loc d = Typ.mk ~loc:(ghost_loc loc) d
let ghloc ~loc d = { txt = d; loc = ghost_loc loc }
let ghstr ~loc d = Str.mk ~loc:(ghost_loc loc) d
let ghsig ~loc d = Sig.mk ~loc:(ghost_loc loc) d
82

POTTIER Francois's avatar
POTTIER Francois committed
83 84
let mkinfix arg1 op arg2 =
  Pexp_apply(op, [Nolabel, arg1; Nolabel, arg2])
85

POTTIER Francois's avatar
POTTIER Francois committed
86
let neg_string f =
87 88 89 90
  if String.length f > 0 && f.[0] = '-'
  then String.sub f 1 (String.length f - 1)
  else "-" ^ f

POTTIER Francois's avatar
POTTIER Francois committed
91
let mkuminus ~oploc name arg =
92
  match name, arg.pexp_desc with
POTTIER Francois's avatar
POTTIER Francois committed
93 94 95 96
  | "-", Pexp_constant(Pconst_integer (n,m)) ->
      Pexp_constant(Pconst_integer(neg_string n,m))
  | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) ->
      Pexp_constant(Pconst_float(neg_string f, m))
97
  | _ ->
POTTIER Francois's avatar
POTTIER Francois committed
98
      Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])
99

POTTIER Francois's avatar
POTTIER Francois committed
100
let mkuplus ~oploc name arg =
101 102
  let desc = arg.pexp_desc in
  match name, desc with
POTTIER Francois's avatar
POTTIER Francois committed
103 104
  | "+", Pexp_constant(Pconst_integer _)
  | ("+" | "+."), Pexp_constant(Pconst_float _) -> desc
105
  | _ ->
POTTIER Francois's avatar
POTTIER Francois committed
106 107 108 109 110
      Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])

(* TODO define an abstraction boundary between locations-as-pairs
   and locations-as-Location.t; it should be clear when we move from
   one world to the other *)
111

POTTIER Francois's avatar
POTTIER Francois committed
112 113 114 115
let mkexp_cons_desc consloc args =
  Pexp_construct(mkrhs (Lident "::") consloc, Some args)
let mkexp_cons ~loc consloc args =
  mkexp ~loc (mkexp_cons_desc consloc args)
116

POTTIER Francois's avatar
POTTIER Francois committed
117 118 119 120
let mkpat_cons_desc consloc args =
  Ppat_construct(mkrhs (Lident "::") consloc, Some args)
let mkpat_cons ~loc consloc args =
  mkpat ~loc (mkpat_cons_desc consloc args)
121

POTTIER Francois's avatar
POTTIER Francois committed
122 123 124 125 126 127
let ghexp_cons_desc consloc args =
  Pexp_construct(ghrhs (Lident "::") consloc, Some args)
let ghpat_cons_desc consloc args =
  Ppat_construct(ghrhs (Lident "::") consloc, Some args)

let rec mktailexp nilloc = let open Location in function
128
    [] ->
POTTIER Francois's avatar
POTTIER Francois committed
129 130
      let nil = ghloc ~loc:nilloc (Lident "[]") in
      Pexp_construct (nil, None), nilloc
131
  | e1 :: el ->
POTTIER Francois's avatar
POTTIER Francois committed
132 133 134 135
      let exp_el, el_loc = mktailexp nilloc el in
      let loc = (e1.pexp_loc.loc_start, snd el_loc) in
      let arg = ghexp ~loc (Pexp_tuple [e1; ghexp ~loc:el_loc exp_el]) in
      ghexp_cons_desc loc arg, loc
136

POTTIER Francois's avatar
POTTIER Francois committed
137
let rec mktailpat nilloc = let open Location in function
138
    [] ->
POTTIER Francois's avatar
POTTIER Francois committed
139 140
      let nil = ghloc ~loc:nilloc (Lident "[]") in
      Ppat_construct (nil, None), nilloc
141
  | p1 :: pl ->
POTTIER Francois's avatar
POTTIER Francois committed
142 143 144 145
      let pat_pl, el_loc = mktailpat nilloc pl in
      let loc = (p1.ppat_loc.loc_start, snd el_loc) in
      let arg = ghpat ~loc (Ppat_tuple [p1; ghpat ~loc:el_loc pat_pl]) in
      ghpat_cons_desc loc arg, loc
146

147 148
let mkstrexp e attrs =
  { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc }
149

POTTIER Francois's avatar
POTTIER Francois committed
150
let mkexp_constraint ~loc e (t1, t2) =
151
  match t1, t2 with
POTTIER Francois's avatar
POTTIER Francois committed
152 153
  | Some t, None -> ghexp ~loc (Pexp_constraint(e, t))
  | _, Some t -> ghexp ~loc (Pexp_coerce(e, t1, t))
154
  | None, None -> assert false
155

POTTIER Francois's avatar
POTTIER Francois committed
156
let mkexp_opt_constraint ~loc e = function
157
  | None -> e
POTTIER Francois's avatar
POTTIER Francois committed
158
  | Some constraint_ -> mkexp_constraint ~loc e constraint_
159

POTTIER Francois's avatar
POTTIER Francois committed
160
let mkpat_opt_constraint ~loc p = function
161
  | None -> p
POTTIER Francois's avatar
POTTIER Francois committed
162
  | Some typ -> mkpat ~loc (Ppat_constraint(p, typ))
163 164 165 166

let syntax_error () =
  raise Syntaxerr.Escape_error

POTTIER Francois's avatar
POTTIER Francois committed
167 168 169
let unclosed opening_name opening_loc closing_name closing_loc =
  raise(Syntaxerr.Error(Syntaxerr.Unclosed(make_loc opening_loc, opening_name,
                                           make_loc closing_loc, closing_name)))
170

POTTIER Francois's avatar
POTTIER Francois committed
171 172
let expecting loc nonterm =
    raise Syntaxerr.(Error(Expecting(make_loc loc, nonterm)))
173

POTTIER Francois's avatar
POTTIER Francois committed
174 175
let not_expecting loc nonterm =
    raise Syntaxerr.(Error(Not_expecting(make_loc loc, nonterm)))
176

POTTIER Francois's avatar
POTTIER Francois committed
177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213
let dotop_fun ~loc dotop =
  (* We could use ghexp here, but sticking to mkexp for parser.mly
     compatibility. TODO improve parser.mly *)
  mkexp ~loc (Pexp_ident (ghloc ~loc dotop))

let array_function ~loc str name =
  ghloc ~loc (Ldot(Lident str,
                   (if !Clflags.unsafe then "unsafe_" ^ name else name)))

let array_get_fun ~loc =
  ghexp ~loc (Pexp_ident(array_function ~loc "Array" "get"))
let string_get_fun ~loc =
  ghexp ~loc (Pexp_ident(array_function ~loc "String" "get"))

let array_set_fun ~loc =
  ghexp ~loc (Pexp_ident(array_function ~loc "Array" "set"))
let string_set_fun ~loc =
  ghexp ~loc (Pexp_ident(array_function ~loc "String" "set"))

let index_get ~loc get_fun array index =
  let args = [Nolabel, array; Nolabel, index] in
   mkexp ~loc (Pexp_apply(get_fun, args))

let index_set ~loc set_fun array index value =
  let args = [Nolabel, array; Nolabel, index; Nolabel, value] in
   mkexp ~loc (Pexp_apply(set_fun, args))

let array_get ~loc = index_get ~loc (array_get_fun ~loc)
let string_get ~loc = index_get ~loc (string_get_fun ~loc)
let dotop_get ~loc dotop = index_get ~loc (dotop_fun ~loc dotop)

let array_set ~loc = index_set ~loc (array_set_fun ~loc)
let string_set ~loc = index_set ~loc (string_set_fun ~loc)
let dotop_set ~loc dotop = index_set ~loc (dotop_fun ~loc dotop)

let bigarray_function ~loc str name =
  ghloc ~loc (Ldot(Ldot(Lident "Bigarray", str), name))
214 215

let bigarray_untuplify = function
216
    { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist
217 218
  | exp -> [exp]

POTTIER Francois's avatar
POTTIER Francois committed
219 220 221 222
let bigarray_get ~loc arr arg =
  let mkexp, ghexp = mkexp ~loc, ghexp ~loc in
  let bigarray_function = bigarray_function ~loc in
  let get = if !Clflags.unsafe then "unsafe_get" else "get" in
223 224
  match bigarray_untuplify arg with
    [c1] ->
POTTIER Francois's avatar
POTTIER Francois committed
225
      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" get)),
226
                       [Nolabel, arr; Nolabel, c1]))
227
  | [c1;c2] ->
POTTIER Francois's avatar
POTTIER Francois committed
228
      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" get)),
229
                       [Nolabel, arr; Nolabel, c1; Nolabel, c2]))
230
  | [c1;c2;c3] ->
POTTIER Francois's avatar
POTTIER Francois committed
231
      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" get)),
232
                       [Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3]))
233
  | coords ->
POTTIER Francois's avatar
POTTIER Francois committed
234
      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")),
235
                       [Nolabel, arr; Nolabel, ghexp(Pexp_array coords)]))
236

POTTIER Francois's avatar
POTTIER Francois committed
237 238 239 240
let bigarray_set ~loc arr arg newval =
  let mkexp, ghexp = mkexp ~loc, ghexp ~loc in
  let bigarray_function = bigarray_function ~loc in
  let set = if !Clflags.unsafe then "unsafe_set" else "set" in
241 242
  match bigarray_untuplify arg with
    [c1] ->
POTTIER Francois's avatar
POTTIER Francois committed
243
      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" set)),
244
                       [Nolabel, arr; Nolabel, c1; Nolabel, newval]))
245
  | [c1;c2] ->
POTTIER Francois's avatar
POTTIER Francois committed
246 247 248
      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" set)),
                       [Nolabel, arr; Nolabel, c1;
                        Nolabel, c2; Nolabel, newval]))
249
  | [c1;c2;c3] ->
POTTIER Francois's avatar
POTTIER Francois committed
250 251 252
      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" set)),
                       [Nolabel, arr; Nolabel, c1;
                        Nolabel, c2; Nolabel, c3; Nolabel, newval]))
253
  | coords ->
POTTIER Francois's avatar
POTTIER Francois committed
254
      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")),
255 256 257 258
                       [Nolabel, arr;
                        Nolabel, ghexp(Pexp_array coords);
                        Nolabel, newval]))

POTTIER Francois's avatar
POTTIER Francois committed
259
let lapply ~loc p1 p2 =
260 261
  if !Clflags.applicative_functors
  then Lapply(p1, p2)
POTTIER Francois's avatar
POTTIER Francois committed
262 263 264 265 266 267 268 269
  else raise (Syntaxerr.Error(
                  Syntaxerr.Applicative_path (make_loc loc)))

let exp_of_longident ~loc lid =
  mkexp ~loc (Pexp_ident {lid with txt = Lident(Longident.last lid.txt)})

let exp_of_label ~loc lbl =
  mkexp ~loc (Pexp_ident lbl)
270

POTTIER Francois's avatar
POTTIER Francois committed
271 272 273 274 275
let pat_of_label ~loc lbl =
  mkpat ~loc (Ppat_var lbl)

let mk_newtypes ~loc newtypes exp =
  let mkexp = mkexp ~loc in
276 277 278
  List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp)))
    newtypes exp

POTTIER Francois's avatar
POTTIER Francois committed
279 280 281
let wrap_type_annotation ~loc newtypes core_type body =
  let mkexp, ghtyp = mkexp ~loc, ghtyp ~loc in
  let mk_newtypes = mk_newtypes ~loc in
282 283
  let exp = mkexp(Pexp_constraint(body,core_type)) in
  let exp = mk_newtypes newtypes exp in
POTTIER Francois's avatar
POTTIER Francois committed
284
  (exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type)))
285

POTTIER Francois's avatar
POTTIER Francois committed
286 287
let wrap_exp_attrs ~loc body (ext, attrs) =
  let ghexp = ghexp ~loc in
288 289 290 291 292 293
  (* todo: keep exact location for the entire attribute *)
  let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in
  match ext with
  | None -> body
  | Some id -> ghexp(Pexp_extension (id, PStr [mkstrexp body []]))

POTTIER Francois's avatar
POTTIER Francois committed
294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329
let mkexp_attrs ~loc d attrs =
  wrap_exp_attrs ~loc (mkexp ~loc d) attrs

let wrap_typ_attrs ~loc typ (ext, attrs) =
  (* todo: keep exact location for the entire attribute *)
  let typ = {typ with ptyp_attributes = attrs @ typ.ptyp_attributes} in
  match ext with
  | None -> typ
  | Some id -> ghtyp ~loc (Ptyp_extension (id, PTyp typ))

let wrap_pat_attrs ~loc pat (ext, attrs) =
  (* todo: keep exact location for the entire attribute *)
  let pat = {pat with ppat_attributes = attrs @ pat.ppat_attributes} in
  match ext with
  | None -> pat
  | Some id -> ghpat ~loc (Ppat_extension (id, PPat (pat, None)))

let mkpat_attrs ~loc d attrs =
  wrap_pat_attrs ~loc (mkpat ~loc d) attrs

let wrap_class_attrs ~loc:_ body attrs =
  {body with pcl_attributes = attrs @ body.pcl_attributes}
let wrap_mod_attrs ~loc:_ body attrs =
  {body with pmod_attributes = attrs @ body.pmod_attributes}
let wrap_mty_attrs ~loc:_ body attrs =
  {body with pmty_attributes = attrs @ body.pmty_attributes}

let wrap_str_ext ~loc body ext =
  match ext with
  | None -> body
  | Some id -> ghstr ~loc (Pstr_extension ((id, PStr [body]), []))

let wrap_sig_ext ~loc body ext =
  match ext with
  | None -> body
  | Some id -> ghsig ~loc (Psig_extension ((id, PSig [body]), []))
330 331 332 333 334 335 336

let text_str pos = Str.text (rhs_text pos)
let text_sig pos = Sig.text (rhs_text pos)
let text_cstr pos = Cf.text (rhs_text pos)
let text_csig pos = Ctf.text (rhs_text pos)
let text_def pos = [Ptop_def (Str.text (rhs_text pos))]

POTTIER Francois's avatar
POTTIER Francois committed
337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357
let extra_text startpos endpos text items =
  match items with
  | [] ->
      let post = rhs_post_text endpos in
      let post_extras = rhs_post_extra_text endpos in
      text post @ text post_extras
  | _ :: _ ->
      let pre_extras = rhs_pre_extra_text startpos in
      let post_extras = rhs_post_extra_text endpos in
        text pre_extras @ items @ text post_extras

let extra_str p1 p2 items = extra_text p1 p2 Str.text items
let extra_sig p1 p2 items = extra_text p1 p2 Sig.text items
let extra_cstr p1 p2 items = extra_text p1 p2 Cf.text items
let extra_csig p1 p2 items = extra_text p1 p2 Ctf.text  items
let extra_def p1 p2 items =
  extra_text p1 p2 (fun txt -> [Ptop_def (Str.text txt)]) items

let extra_rhs_core_type ct ~pos =
  let docs = rhs_info pos in
  { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes }
358 359 360 361 362 363 364 365 366 367 368 369 370 371 372

type let_binding =
  { lb_pattern: pattern;
    lb_expression: expression;
    lb_attributes: attributes;
    lb_docs: docs Lazy.t;
    lb_text: text Lazy.t;
    lb_loc: Location.t; }

type let_bindings =
  { lbs_bindings: let_binding list;
    lbs_rec: rec_flag;
    lbs_extension: string Asttypes.loc option;
    lbs_loc: Location.t }

POTTIER Francois's avatar
POTTIER Francois committed
373 374 375
let mklb first ~loc (p, e) attrs =
  {
    lb_pattern = p;
376 377
    lb_expression = e;
    lb_attributes = attrs;
POTTIER Francois's avatar
POTTIER Francois committed
378 379 380 381 382 383 384 385 386
    lb_docs = symbol_docs_lazy loc;
    lb_text = (if first then empty_text_lazy
               else symbol_text_lazy (fst loc));
    lb_loc = make_loc loc;
  }

let mklbs ~loc ext rf lb =
  {
    lbs_bindings = [lb];
387 388
    lbs_rec = rf;
    lbs_extension = ext ;
POTTIER Francois's avatar
POTTIER Francois committed
389 390
    lbs_loc = make_loc loc;
  }
391 392 393 394

let addlb lbs lb =
  { lbs with lbs_bindings = lb :: lbs.lbs_bindings }

POTTIER Francois's avatar
POTTIER Francois committed
395 396 397 398 399 400 401 402 403
let val_of_let_bindings ~loc lbs =
  let bindings =
    List.map
      (fun lb ->
         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
           ~docs:(Lazy.force lb.lb_docs)
           ~text:(Lazy.force lb.lb_text)
           lb.lb_pattern lb.lb_expression)
      lbs.lbs_bindings
404
  in
POTTIER Francois's avatar
POTTIER Francois committed
405
  let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in
406 407
  match lbs.lbs_extension with
  | None -> str
POTTIER Francois's avatar
POTTIER Francois committed
408
  | Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), []))
409

POTTIER Francois's avatar
POTTIER Francois committed
410
let expr_of_let_bindings ~loc lbs body =
411 412 413
  let bindings =
    List.map
      (fun lb ->
POTTIER Francois's avatar
POTTIER Francois committed
414 415
         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
           lb.lb_pattern lb.lb_expression)
416 417
      lbs.lbs_bindings
  in
POTTIER Francois's avatar
POTTIER Francois committed
418 419
    mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body))
      (lbs.lbs_extension, [])
420

POTTIER Francois's avatar
POTTIER Francois committed
421
let class_of_let_bindings ~loc lbs body =
422 423 424
  let bindings =
    List.map
      (fun lb ->
POTTIER Francois's avatar
POTTIER Francois committed
425 426
         Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes
           lb.lb_pattern lb.lb_expression)
427 428 429 430
      lbs.lbs_bindings
  in
    if lbs.lbs_extension <> None then
      raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "extension")));
POTTIER Francois's avatar
POTTIER Francois committed
431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480
    mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body))

(* Alternatively, we could keep the generic module type in the Parsetree
   and extract the package type during type-checking. In that case,
   the assertions below should be turned into explicit checks. *)
let package_type_of_module_type pmty =
  let err loc s =
    raise (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s)))
  in
  let map_cstr = function
    | Pwith_type (lid, ptyp) ->
        let loc = ptyp.ptype_loc in
        if ptyp.ptype_params <> [] then
          err loc "parametrized types are not supported";
        if ptyp.ptype_cstrs <> [] then
          err loc "constrained types are not supported";
        if ptyp.ptype_private <> Public then
          err loc "private types are not supported";

        (* restrictions below are checked by the 'with_constraint' rule *)
        assert (ptyp.ptype_kind = Ptype_abstract);
        assert (ptyp.ptype_attributes = []);
        let ty =
          match ptyp.ptype_manifest with
          | Some ty -> ty
          | None -> assert false
        in
        (lid, ty)
    | _ ->
        err pmty.pmty_loc "only 'with type t =' constraints are supported"
  in
  match pmty with
  | {pmty_desc = Pmty_ident lid} -> (lid, [])
  | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} ->
      (lid, List.map map_cstr cstrs)
  | _ ->
      err pmty.pmty_loc
        "only module type identifier and 'with type' constraints are supported"

let mk_directive_arg ~loc k =
  { pdira_desc = k;
    pdira_loc = make_loc loc;
  }

let mk_directive ~loc name arg =
  Ptop_dir {
      pdir_name = name;
      pdir_arg = arg;
      pdir_loc = make_loc loc;
    }
481

482 483 484
%}
%start implementation
%start interface
485 486 487
%start parse_core_type
%start parse_expression
%start parse_pattern
488 489
%start toplevel_phrase
%start use_file
490 491
%token AMPERAMPER
%token AMPERSAND
492 493
%token AND
%token AS
494 495 496
%token ASSERT
%token BACKQUOTE
%token BANG
497 498
%token BAR
%token BARBAR
499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514
%token BARRBRACKET
%token BEGIN
%token <char> CHAR
%token CLASS
%token COLON
%token COLONCOLON
%token COLONEQUAL
%token COLONGREATER
%token COMMA
%token <string * Location.t> COMMENT
%token CONSTRAINT
%token DO
%token <Docstrings.docstring> DOCSTRING
%token DONE
%token DOT
%token DOTDOT
POTTIER Francois's avatar
POTTIER Francois committed
515
%token <string> DOTOP
516 517 518 519 520
%token DOWNTO
%token ELSE
%token END
%token EOF
%token EOL
521
%token EQUAL
522 523 524
%token EXCEPTION
%token EXTERNAL
%token FALSE
POTTIER Francois's avatar
POTTIER Francois committed
525
%token <string * char option> FLOAT
526 527 528 529 530 531 532
%token FOR
%token FUN
%token FUNCTION
%token FUNCTOR
%token GREATER
%token GREATERRBRACE
%token GREATERRBRACKET
POTTIER Francois's avatar
POTTIER Francois committed
533 534
%token HASH
%token <string> HASHOP
535 536 537 538
%token IF
%token IN
%token INCLUDE
%token <string> INFIXOP0
539
%token <string> INFIXOP1
540 541 542 543 544
%token <string> INFIXOP2
%token <string> INFIXOP3
%token <string> INFIXOP4
%token INHERIT
%token INITIALIZER
POTTIER Francois's avatar
POTTIER Francois committed
545
%token <string * char option> INT
546 547 548 549 550
%token <string> LABEL
%token LAZY
%token LBRACE
%token LBRACELESS
%token LBRACKET
551 552
%token LBRACKETAT
%token LBRACKETATAT
553 554 555 556 557 558 559 560 561 562 563 564 565
%token LBRACKETATATAT
%token LBRACKETBAR
%token LBRACKETGREATER
%token LBRACKETLESS
%token LBRACKETPERCENT
%token LBRACKETPERCENTPERCENT
%token LESS
%token LESSMINUS
%token LET
%token <string> LIDENT
%token LPAREN
%token MATCH
%token METHOD
566
%token MINUS
567 568 569 570 571 572 573 574 575 576 577
%token MINUSDOT
%token MINUSGREATER
%token MODULE
%token MUTABLE
%token NEW
%token NONREC
%token OBJECT
%token OF
%token OPEN
%token <string> OPTLABEL
%token OR
578
%token PERCENT
579 580 581 582 583 584 585 586 587 588 589 590 591 592 593
%token PLUS
%token PLUSDOT
%token PLUSEQ
%token <string> PREFIXOP
%token PRIVATE
%token QUESTION
%token QUOTE
%token RBRACE
%token RBRACKET
%token REC
%token RPAREN
%token SEMI
%token SEMISEMI
%token SIG
%token STAR
594
%token <string * string option> STRING
595 596 597 598 599 600 601 602 603 604 605 606 607 608
%token STRUCT
%token THEN
%token TILDE
%token TO
%token TRUE
%token TRY
%token TYPE
%token <string> UIDENT
%token UNDERSCORE
%token VAL
%token VIRTUAL
%token WHEN
%token WHILE
%token WITH
609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638
%nonassoc IN
%nonassoc below_SEMI
%nonassoc SEMI
%nonassoc LET
%nonassoc below_WITH
%nonassoc FUNCTION WITH
%nonassoc AND
%nonassoc THEN
%nonassoc ELSE
%nonassoc LESSMINUS
%right COLONEQUAL
%nonassoc AS
%left BAR
%nonassoc below_COMMA
%left COMMA
%right MINUSGREATER
%right BARBAR OR
%right AMPERAMPER AMPERSAND
%nonassoc below_EQUAL
%left EQUAL GREATER INFIXOP0 LESS
%right INFIXOP1
%nonassoc below_LBRACKETAT
%nonassoc LBRACKETAT
%right COLONCOLON
%left INFIXOP2 MINUS MINUSDOT PLUS PLUSDOT PLUSEQ
%left INFIXOP3 PERCENT STAR
%right INFIXOP4
%nonassoc prec_unary_minus prec_unary_plus
%nonassoc prec_constant_constructor
%nonassoc prec_constr_appl
POTTIER Francois's avatar
POTTIER Francois committed
639 640 641
%nonassoc below_HASH
%nonassoc HASH
%left HASHOP
642
%nonassoc below_DOT
POTTIER Francois's avatar
POTTIER Francois committed
643 644
%nonassoc DOT DOTOP
%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT LBRACE LBRACELESS LBRACKET LBRACKETBAR LBRACKETPERCENT LIDENT LPAREN NEW PREFIXOP STRING TRUE UIDENT
645 646
%type <Parsetree.structure> implementation
%type <Parsetree.signature> interface
647 648 649
%type <Parsetree.core_type> parse_core_type
%type <Parsetree.expression> parse_expression
%type <Parsetree.pattern> parse_pattern
650 651 652 653
%type <Parsetree.toplevel_phrase> toplevel_phrase
%type <Parsetree.toplevel_phrase list> use_file
%%

POTTIER Francois's avatar
POTTIER Francois committed
654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669
reversed_separated_nonempty_list_COMMA_core_type_:
  x0 = core_type
    {let xs =
  let x = x0 in
      ( [ x ] )
in
    ( xs )}
| xs0 = reversed_separated_nonempty_list_COMMA_core_type_ _20 = COMMA x0 = core_type
    {let xs =
  let x = x0 in
  let _2 = _20 in
  let xs = xs0 in
      ( x :: xs )
in
    ( xs )}

670
implementation:
671
  _1 = structure _2 = EOF
POTTIER Francois's avatar
POTTIER Francois committed
672
    {                                         ( _1 )}
673 674

interface:
675
  _1 = signature _2 = EOF
POTTIER Francois's avatar
POTTIER Francois committed
676
    {                                         ( _1 )}
677 678

toplevel_phrase:
679
  _1 = top_structure _2 = SEMISEMI
POTTIER Francois's avatar
POTTIER Francois committed
680
    {                                         ( Ptop_def (_1) )}
681 682 683 684
| _1 = toplevel_directive _2 = SEMISEMI
    {                                         ( _1 )}
| _1 = EOF
    {                                         ( raise End_of_file )}
685 686

top_structure:
POTTIER Francois's avatar
POTTIER Francois committed
687 688 689 690 691 692 693 694 695 696 697 698
  _10 = top_structure_nodoc
    {let _1 =
  let _endpos__1_ = _endpos__10_ in
  let _startpos__1_ = _startpos__10_ in
  let _1 = _10 in
  let _endpos = _endpos__1_ in
  let _startpos = _startpos__1_ in
                                ( extra_str _startpos _endpos _1 )
in
                                              ( _1 )}

top_structure_nodoc:
699
  _1 = seq_expr _2 = post_item_attributes
POTTIER Francois's avatar
POTTIER Francois committed
700 701
    {      ( text_str _startpos__1_ @ [mkstrexp _1 _2] )}
| _1 = top_structure_tail_nodoc
702 703
    {      ( _1 )}

POTTIER Francois's avatar
POTTIER Francois committed
704
top_structure_tail_nodoc:
705
  
POTTIER Francois's avatar
POTTIER Francois committed
706 707 708
    {      ( [] )}
| _1 = structure_item _2 = top_structure_tail_nodoc
    {      ( text_str _startpos__1_ @ _1 :: _2 )}
709 710

use_file:
POTTIER Francois's avatar
POTTIER Francois committed
711 712 713 714 715 716 717 718 719 720
  _10 = use_file_body _2 = EOF
    {let _1 =
  let _endpos__1_ = _endpos__10_ in
  let _startpos__1_ = _startpos__10_ in
  let _1 = _10 in
  let _endpos = _endpos__1_ in
  let _startpos = _startpos__1_ in
                                ( extra_def _startpos _endpos _1 )
in
                                         ( _1 )}
721 722

use_file_body:
723
  _1 = use_file_tail
724
    {                                         ( _1 )}
725
| _1 = seq_expr _2 = post_item_attributes _3 = use_file_tail
POTTIER Francois's avatar
POTTIER Francois committed
726
    {      ( text_def _startpos__1_ @ Ptop_def[mkstrexp _1 _2] :: _3 )}
727 728

use_file_tail:
POTTIER Francois's avatar
POTTIER Francois committed
729
  
730
    {      ( [] )}
POTTIER Francois's avatar
POTTIER Francois committed
731 732
| _1 = SEMISEMI _2 = use_file_body
    {      ( _2 )}
733
| _1 = structure_item _2 = use_file_tail
POTTIER Francois's avatar
POTTIER Francois committed
734
    {      ( text_def _startpos__1_ @ Ptop_def[_1] :: _2 )}
735
| _1 = toplevel_directive _2 = use_file_tail
POTTIER Francois's avatar
POTTIER Francois committed
736 737
    {      ( mark_rhs_docs _startpos__1_ _endpos__1_;
        text_def _startpos__1_ @ _1 :: _2 )}
738 739

parse_core_type:
740
  _1 = core_type _2 = EOF
741 742 743
    {                  ( _1 )}

parse_expression:
744
  _1 = seq_expr _2 = EOF
745 746 747
    {                 ( _1 )}

parse_pattern:
748
  _1 = pattern _2 = EOF
749 750 751
    {                ( _1 )}

functor_arg:
POTTIER Francois's avatar
POTTIER Francois committed
752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797
  _100 = LPAREN _200 = RPAREN
    {let _1 =
  let _endpos__20_ = _endpos__200_ in
  let _startpos__10_ = _startpos__100_ in
  let _20 = _200 in
  let _10 = _100 in
  let _1 =
    let _2 = _20 in
    let _1 = _10 in
                            ("*")
  in
  let _endpos__1_ = _endpos__20_ in
  let _startpos__1_ = _startpos__10_ in
  let _endpos = _endpos__1_ in
  let _startpos = _startpos__1_ in
  let _loc = (_startpos, _endpos) in
      (
      (* Semantically we could use $symbolstartpos instead of $startpos
         here, but the code comes from calls to (Parsing.rhs_loc p) for
         some position p, which rather corresponds to
         $startpos, so we kept it for compatibility.

         I do not know if mkrhs is ever used in a situation where $startpos
         and $symbolpos do not coincide.  *)
      mkrhs _1 _loc )
in
      ( _1, None )}
| _1 = LPAREN _10 = functor_arg_name _3 = COLON _4 = module_type _5 = RPAREN
    {let _2 =
  let _endpos__1_ = _endpos__10_ in
  let _startpos__1_ = _startpos__10_ in
  let _1 = _10 in
  let _endpos = _endpos__1_ in
  let _startpos = _startpos__1_ in
  let _loc = (_startpos, _endpos) in
      (
      (* Semantically we could use $symbolstartpos instead of $startpos
         here, but the code comes from calls to (Parsing.rhs_loc p) for
         some position p, which rather corresponds to
         $startpos, so we kept it for compatibility.

         I do not know if mkrhs is ever used in a situation where $startpos
         and $symbolpos do not coincide.  *)
      mkrhs _1 _loc )
in
      ( _2, Some _4 )}
798 799

functor_arg_name:
800
  _1 = UIDENT
801 802 803 804 805
    {               ( _1 )}
| _1 = UNDERSCORE
    {               ( "_" )}

functor_args:
806
  _1 = functor_args _2 = functor_arg
807 808 809
    {      ( _2 :: _1 )}
| _1 = functor_arg
    {      ( [ _1 ] )}
810 811

module_expr:
POTTIER Francois's avatar
POTTIER Francois committed
812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959
  _1 = STRUCT _2 = attributes _3 = structure _4 = END
    {let _endpos = _endpos__4_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( mkmod ~loc:_sloc ~attrs:_2 (Pmod_structure(_3)) )}
| _1 = STRUCT _2 = attributes _3 = structure _4 = error
    {let _loc__4_ = (_startpos__4_, _endpos__4_) in
let _loc__1_ = (_startpos__1_, _endpos__1_) in
      ( unclosed "struct" _loc__1_ "end" _loc__4_ )}
| _1 = FUNCTOR _2 = attributes _3 = functor_args _4 = MINUSGREATER _5 = module_expr
    {let _endpos = _endpos__5_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( let modexp =
          List.fold_left
            (fun acc (n, t) -> mkmod ~loc:_sloc (Pmod_functor(n, t, acc)))
            _5 _3
        in wrap_mod_attrs ~loc:_sloc modexp _2 )}
| _1 = paren_module_expr
    {      ( _1 )}
| _1 = module_expr _2 = attribute
    {      ( Mod.attr _1 _2 )}
| _1000 = mod_longident
    {let _1 =
  let _endpos__100_ = _endpos__1000_ in
  let _startpos__100_ = _startpos__1000_ in
  let _100 = _1000 in
  let _1 =
    let _endpos__10_ = _endpos__100_ in
    let _startpos__10_ = _startpos__100_ in
    let _10 = _100 in
    let _1 =
      let _endpos__1_ = _endpos__10_ in
      let _startpos__1_ = _startpos__10_ in
      let _1 = _10 in
      let _endpos = _endpos__1_ in
      let _startpos = _startpos__1_ in
      let _loc = (_startpos, _endpos) in
          (
      (* Semantically we could use $symbolstartpos instead of $startpos
         here, but the code comes from calls to (Parsing.rhs_loc p) for
         some position p, which rather corresponds to
         $startpos, so we kept it for compatibility.

         I do not know if mkrhs is ever used in a situation where $startpos
         and $symbolpos do not coincide.  *)
      mkrhs _1 _loc )
    in
        ( Pmod_ident _1 )
  in
  let _endpos__1_ = _endpos__100_ in
  let _startpos__1_ = _startpos__100_ in
  let _endpos = _endpos__1_ in
  let _symbolstartpos = _startpos__1_ in
  let _sloc = (_symbolstartpos, _endpos) in
      ( mkmod ~loc:_sloc _1 )
in
      ( _1 )}
| _100 = module_expr _200 = paren_module_expr
    {let _1 =
  let _endpos__20_ = _endpos__200_ in
  let _startpos__10_ = _startpos__100_ in
  let _20 = _200 in
  let _10 = _100 in
  let _1 =
    let _2 = _20 in
    let _1 = _10 in
        ( Pmod_apply(_1, _2) )
  in
  let _endpos__1_ = _endpos__20_ in
  let _startpos__1_ = _startpos__10_ in
  let _endpos = _endpos__1_ in
  let _symbolstartpos = _startpos__1_ in
  let _sloc = (_symbolstartpos, _endpos) in
      ( mkmod ~loc:_sloc _1 )
in
      ( _1 )}
| _100 = module_expr _200 = LPAREN _300 = RPAREN
    {let _1 =
  let _endpos__30_ = _endpos__300_ in
  let _startpos__10_ = _startpos__100_ in
  let _30 = _300 in
  let _20 = _200 in
  let _10 = _100 in
  let _1 =
    let _endpos__3_ = _endpos__30_ in
    let _startpos__1_ = _startpos__10_ in
    let _3 = _30 in
    let _2 = _20 in
    let _1 = _10 in
    let _endpos = _endpos__3_ in
    let _symbolstartpos = _startpos__1_ in
    let _sloc = (_symbolstartpos, _endpos) in
        ( (* TODO review mkmod location *)
      Pmod_apply(_1, mkmod ~loc:_sloc (Pmod_structure [])) )
  in
  let _endpos__1_ = _endpos__30_ in
  let _startpos__1_ = _startpos__10_ in
  let _endpos = _endpos__1_ in
  let _symbolstartpos = _startpos__1_ in
  let _sloc = (_symbolstartpos, _endpos) in
      ( mkmod ~loc:_sloc _1 )
in
      ( _1 )}
| _100 = extension
    {let _1 =
  let _endpos__10_ = _endpos__100_ in
  let _startpos__10_ = _startpos__100_ in
  let _10 = _100 in
  let _1 =
    let _1 = _10 in
        ( Pmod_extension _1 )
  in
  let _endpos__1_ = _endpos__10_ in
  let _startpos__1_ = _startpos__10_ in
  let _endpos = _endpos__1_ in
  let _symbolstartpos = _startpos__1_ in
  let _sloc = (_symbolstartpos, _endpos) in
      ( mkmod ~loc:_sloc _1 )
in
      ( _1 )}

paren_module_expr:
  _100 = LPAREN _200 = module_expr _300 = COLON _400 = module_type _500 = RPAREN
    {let _1 =
  let _endpos__50_ = _endpos__500_ in
  let _startpos__10_ = _startpos__100_ in
  let _50 = _500 in
  let _40 = _400 in
  let _30 = _300 in
  let _20 = _200 in
  let _10 = _100 in
  let _1 =
    let _5 = _50 in
    let _4 = _40 in
    let _3 = _30 in
    let _2 = _20 in
    let _1 = _10 in
          ( Pmod_constraint(_2, _4) )
  in
  let _endpos__1_ = _endpos__50_ in
  let _startpos__1_ = _startpos__10_ in
  let _endpos = _endpos__1_ in
  let _symbolstartpos = _startpos__1_ in
  let _sloc = (_symbolstartpos, _endpos) in
      ( mkmod ~loc:_sloc _1 )
in
      ( _1 )}
960
| _1 = LPAREN _2 = module_expr _3 = COLON _4 = module_type _5 = error
POTTIER Francois's avatar
POTTIER Francois committed
961 962 963
    {let _loc__5_ = (_startpos__5_, _endpos__5_) in
let _loc__1_ = (_startpos__1_, _endpos__1_) in
      ( unclosed "(" _loc__1_ ")" _loc__5_ )}
964
| _1 = LPAREN _2 = module_expr _3 = RPAREN
POTTIER Francois's avatar
POTTIER Francois committed
965
    {      ( _2 (* TODO consider reloc *) )}
966
| _1 = LPAREN _2 = module_expr _3 = error
POTTIER Francois's avatar
POTTIER Francois committed
967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010
    {let _loc__3_ = (_startpos__3_, _endpos__3_) in
let _loc__1_ = (_startpos__1_, _endpos__1_) in
      ( unclosed "(" _loc__1_ ")" _loc__3_ )}
| _1 = LPAREN _2 = VAL _3 = attributes _4 = expr _5 = RPAREN
    {let _endpos = _endpos__5_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( mkmod ~loc:_sloc ~attrs:_3 (Pmod_unpack _4))}
| _1 = LPAREN _2 = VAL _3 = attributes _4 = expr _5 = COLON _6 = package_type _7 = RPAREN
    {let _endpos = _endpos__7_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( let constr_loc = (_startpos__4_, _endpos__6_) in
        mkmod ~loc:_sloc ~attrs:_3
          (Pmod_unpack(
               ghexp ~loc:constr_loc (Pexp_constraint(_4, _6)))) )}
| _1 = LPAREN _2 = VAL _3 = attributes _4 = expr _5 = COLON _6 = package_type _7 = COLONGREATER _8 = package_type _9 = RPAREN
    {let _endpos = _endpos__9_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( let constr_loc = (_startpos__4_, _endpos__8_) in
        mkmod ~loc:_sloc ~attrs:_3
          (Pmod_unpack(
               ghexp ~loc:constr_loc (Pexp_coerce(_4, Some _6, _8)))) )}
| _1 = LPAREN _2 = VAL _3 = attributes _4 = expr _5 = COLONGREATER _6 = package_type _7 = RPAREN
    {let _endpos = _endpos__7_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( let constr_loc = (_startpos__4_, _endpos__6_) in
        mkmod ~loc:_sloc ~attrs:_3
          (Pmod_unpack(
               ghexp ~loc:constr_loc (Pexp_coerce(_4, None, _6)))) )}
| _1 = LPAREN _2 = VAL _3 = attributes _4 = expr _5 = COLON _6 = error
    {let _loc__6_ = (_startpos__6_, _endpos__6_) in
let _loc__1_ = (_startpos__1_, _endpos__1_) in
      ( unclosed "(" _loc__1_ ")" _loc__6_ )}
| _1 = LPAREN _2 = VAL _3 = attributes _4 = expr _5 = COLONGREATER _6 = error
    {let _loc__6_ = (_startpos__6_, _endpos__6_) in
let _loc__1_ = (_startpos__1_, _endpos__1_) in
      ( unclosed "(" _loc__1_ ")" _loc__6_ )}
| _1 = LPAREN _2 = VAL _3 = attributes _4 = expr _5 = error
    {let _loc__5_ = (_startpos__5_, _endpos__5_) in
let _loc__1_ = (_startpos__1_, _endpos__1_) in
      ( unclosed "(" _loc__1_ ")" _loc__5_ )}
1011 1012

structure:
POTTIER Francois's avatar
POTTIER Francois committed
1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031
  _10 = structure_nodoc
    {let _1 =
  let _endpos__1_ = _endpos__10_ in
  let _startpos__1_ = _startpos__10_ in
  let _1 = _10 in
  let _endpos = _endpos__1_ in
  let _startpos = _startpos__1_ in
                                ( extra_str _startpos _endpos _1 )
in
                                      ( _1 )}

structure_nodoc:
  _1 = seq_expr _2 = post_item_attributes _3 = structure_tail_nodoc
    {      ( mark_rhs_docs _startpos__1_ _endpos__2_;
        text_str _startpos__1_ @ mkstrexp _1 _2 :: _3 )}
| _1 = structure_tail_nodoc
    {                         ( _1 )}

structure_tail_nodoc:
1032
  
POTTIER Francois's avatar
POTTIER Francois committed
1033 1034 1035 1036 1037
    {                                        ( [] )}
| _1 = SEMISEMI _2 = structure_nodoc
    {                                        ( text_str _startpos__1_ @ _2 )}
| _1 = structure_item _2 = structure_tail_nodoc
    {                                        ( text_str _startpos__1_ @ _1 :: _2 )}
1038 1039

structure_item:
1040
  _1 = let_bindings
POTTIER Francois's avatar
POTTIER Francois committed
1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065
    {let _endpos = _endpos__1_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( val_of_let_bindings ~loc:_sloc _1 )}
| _1 = structure_item_with_ext
    {let _endpos = _endpos__1_ in
let _startpos = _startpos__1_ in
let _loc = (_startpos, _endpos) in
      ( let item, ext = _1 in
        wrap_str_ext ~loc:_loc (mkstr ~loc:_loc item) ext )}
| _1 = item_extension _2 = post_item_attributes
    {let _endpos = _endpos__2_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( let docs = symbol_docs _sloc in
        mkstr ~loc:_sloc (Pstr_extension (_1, (add_docs_attrs docs _2))) )}
| _1 = floating_attribute
    {let _endpos = _endpos__1_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( mkstr ~loc:_sloc (Pstr_attribute _1) )}

structure_item_with_ext:
  _1 = primitive_declaration
    {      ( let (body, ext) = _1 in (Pstr_primitive body, ext) )}
1066
| _1 = value_description
POTTIER Francois's avatar
POTTIER Francois committed
1067
    {      ( let (body, ext) = _1 in (Pstr_primitive body, ext) )}
1068
| _1 = type_declarations
POTTIER Francois's avatar
POTTIER Francois committed
1069
    {      ( let (nr, l, ext ) = _1 in (Pstr_type (nr, List.rev l), ext) )}
1070
| _1 = str_type_extension
POTTIER Francois's avatar
POTTIER Francois committed
1071
    {      ( let (l, ext) = _1 in (Pstr_typext l, ext) )}
1072
| _1 = str_exception_declaration
POTTIER Francois's avatar
POTTIER Francois committed
1073
    {      ( let (l, ext) = _1 in (Pstr_exception l, ext) )}
1074
| _1 = module_binding
POTTIER Francois's avatar
POTTIER Francois committed
1075
    {      ( let (body, ext) = _1 in (Pstr_module body, ext) )}
1076
| _1 = rec_module_bindings
POTTIER Francois's avatar
POTTIER Francois committed
1077
    {      ( let (l, ext) = _1 in (Pstr_recmodule (List.rev l), ext) )}
1078
| _1 = module_type_declaration
POTTIER Francois's avatar
POTTIER Francois committed
1079
    {      ( let (body, ext) = _1 in (Pstr_modtype body, ext) )}
1080
| _1 = open_statement
POTTIER Francois's avatar
POTTIER Francois committed
1081
    {      ( let (body, ext) = _1 in (Pstr_open body, ext) )}
1082
| _1 = class_declarations
POTTIER Francois's avatar
POTTIER Francois committed
1083
    {      ( let (l, ext) = _1 in (Pstr_class (List.rev l), ext) )}
1084
| _1 = class_type_declarations
POTTIER Francois's avatar
POTTIER Francois committed
1085
    {      ( let (l, ext) = _1 in (Pstr_class_type (List.rev l), ext) )}
1086
| _1 = str_include_statement
POTTIER Francois's avatar
POTTIER Francois committed
1087
    {      ( let (body, ext) = _1 in (Pstr_include body, ext) )}
1088 1089

str_include_statement:
POTTIER Francois's avatar
POTTIER Francois committed
1090 1091 1092 1093 1094 1095 1096
  _1 = INCLUDE _2 = ext_attributes _3 = module_expr _4 = post_item_attributes
    {let _endpos = _endpos__4_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( let (ext, attrs) = _2 in
        let docs = symbol_docs _sloc in
        Incl.mk _3 ~attrs:(attrs@_4) ~loc:(make_loc _sloc) ~docs, ext )}
1097 1098

module_binding_body:
1099
  _1 = EQUAL _2 = module_expr
1100
    {      ( _2 )}
POTTIER Francois's avatar
POTTIER Francois committed
1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142
| _100 = COLON _200 = module_type _300 = EQUAL _400 = module_expr
    {let _1 =
  let _endpos__40_ = _endpos__400_ in
  let _startpos__10_ = _startpos__100_ in
  let _40 = _400 in
  let _30 = _300 in
  let _20 = _200 in
  let _10 = _100 in
  let _1 =
    let _4 = _40 in
    let _3 = _30 in
    let _2 = _20 in
    let _1 = _10 in
            ( Pmod_constraint(_4, _2) )
  in
  let _endpos__1_ = _endpos__40_ in
  let _startpos__1_ = _startpos__10_ in
  let _endpos = _endpos__1_ in
  let _symbolstartpos = _startpos__1_ in
  let _sloc = (_symbolstartpos, _endpos) in
      ( mkmod ~loc:_sloc _1 )
in
    ( _1 )}
| _100 = functor_arg _200 = module_binding_body
    {let _1 =
  let _endpos__20_ = _endpos__200_ in
  let _startpos__10_ = _startpos__100_ in
  let _20 = _200 in
  let _10 = _100 in
  let _1 =
    let _2 = _20 in
    let _1 = _10 in
            ( Pmod_functor(fst _1, snd _1, _2) )
  in
  let _endpos__1_ = _endpos__20_ in
  let _startpos__1_ = _startpos__10_ in
  let _endpos = _endpos__1_ in
  let _symbolstartpos = _startpos__1_ in
  let _sloc = (_symbolstartpos, _endpos) in
      ( mkmod ~loc:_sloc _1 )
in
    ( _1 )}
1143

1144
module_binding:
POTTIER Francois's avatar
POTTIER Francois committed
1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168
  _1 = MODULE _2 = ext_attributes _10 = UIDENT _4 = module_binding_body _5 = post_item_attributes
    {let _3 =
  let _endpos__1_ = _endpos__10_ in
  let _startpos__1_ = _startpos__10_ in
  let _1 = _10 in
  let _endpos = _endpos__1_ in
  let _startpos = _startpos__1_ in
  let _loc = (_startpos, _endpos) in
      (
      (* Semantically we could use $symbolstartpos instead of $startpos
         here, but the code comes from calls to (Parsing.rhs_loc p) for
         some position p, which rather corresponds to
         $startpos, so we kept it for compatibility.

         I do not know if mkrhs is ever used in a situation where $startpos
         and $symbolpos do not coincide.  *)
      mkrhs _1 _loc )
in
let _endpos = _endpos__5_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( let (ext, attrs) = _2 in
        let docs = symbol_docs _sloc in
        Mb.mk _3 _4 ~attrs:(attrs@_5) ~loc:(make_loc _sloc) ~docs, ext )}
1169 1170

rec_module_bindings:
1171
  _1 = rec_module_binding
POTTIER Francois's avatar
POTTIER Francois committed
1172
    {      ( let (b, ext) = _1 in ([b], ext) )}
1173
| _1 = rec_module_bindings _2 = and_module_binding
POTTIER Francois's avatar
POTTIER Francois committed
1174
    {      ( let (l, ext) = _1 in (_2 :: l, ext) )}
1175 1176

rec_module_binding:
POTTIER Francois's avatar
POTTIER Francois committed
1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200
  _1 = MODULE _2 = ext_attributes _3 = REC _10 = UIDENT _5 = module_binding_body _6 = post_item_attributes
    {let _4 =
  let _endpos__1_ = _endpos__10_ in
  let _startpos__1_ = _startpos__10_ in
  let _1 = _10 in
  let _endpos = _endpos__1_ in
  let _startpos = _startpos__1_ in
  let _loc = (_startpos, _endpos) in
      (
      (* Semantically we could use $symbolstartpos instead of $startpos
         here, but the code comes from calls to (Parsing.rhs_loc p) for
         some position p, which rather corresponds to
         $startpos, so we kept it for compatibility.

         I do not know if mkrhs is ever used in a situation where $startpos
         and $symbolpos do not coincide.  *)
      mkrhs _1 _loc )
in
let _endpos = _endpos__6_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( let (ext, attrs) = _2 in
        let docs = symbol_docs _sloc in
        Mb.mk _4 _5 ~attrs:(attrs@_6) ~loc:(make_loc _sloc) ~docs, ext )}
1201

1202
and_module_binding:
POTTIER Francois's avatar
POTTIER Francois committed
1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226
  _1 = AND _2 = attributes _10 = UIDENT _4 = module_binding_body _5 = post_item_attributes
    {let _3 =
  let _endpos__1_ = _endpos__10_ in
  let _startpos__1_ = _startpos__10_ in
  let _1 = _10 in
  let _endpos = _endpos__1_ in
  let _startpos = _startpos__1_ in
  let _loc = (_startpos, _endpos) in
      (
      (* Semantically we could use $symbolstartpos instead of $startpos
         here, but the code comes from calls to (Parsing.rhs_loc p) for
         some position p, which rather corresponds to
         $startpos, so we kept it for compatibility.

         I do not know if mkrhs is ever used in a situation where $startpos
         and $symbolpos do not coincide.  *)
      mkrhs _1 _loc )
in
let _endpos = _endpos__5_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( let docs = symbol_docs _sloc in
        let text = symbol_text _symbolstartpos in
        Mb.mk _3 _4 ~attrs:(_2@_5) ~loc:(make_loc _sloc) ~text ~docs )}
1227 1228

module_type:
POTTIER Francois's avatar
POTTIER Francois committed
1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251
  _1 = SIG _2 = attributes _3 = signature _4 = END
    {let _endpos = _endpos__4_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( mkmty ~loc:_sloc ~attrs:_2 (Pmty_signature (_3)) )}
| _1 = SIG _2 = attributes _3 = signature _4 = error
    {let _loc__4_ = (_startpos__4_, _endpos__4_) in
let _loc__1_ = (_startpos__1_, _endpos__1_) in
      ( unclosed "sig" _loc__1_ "end" _loc__4_ )}
| _1 = FUNCTOR _2 = attributes _3 = functor_args _4 = MINUSGREATER _5 = module_type %prec below_WITH
    {let _endpos = _endpos__5_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( let mty =
          List.fold_left
            (fun acc (n, t) -> mkmty ~loc:_sloc (Pmty_functor(n, t, acc)))
            _5 _3
        in wrap_mty_attrs ~loc:_sloc mty _2 )}
| _1 = MODULE _2 = TYPE _3 = OF _4 = attributes _5 = module_expr %prec below_LBRACKETAT
    {let _endpos = _endpos__5_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( mkmty ~loc:_sloc ~attrs:_4 (Pmty_typeof _5) )}
1252 1253 1254
| _1 = LPAREN _2 = module_type _3 = RPAREN
    {      ( _2 )}
| _1 = LPAREN _2 = module_type _3 = error
POTTIER Francois's avatar
POTTIER Francois committed
1255 1256 1257
    {let _loc__3_ = (_startpos__3_, _endpos__3_) in
let _loc__1_ = (_startpos__1_, _endpos__1_) in
      ( unclosed "(" _loc__1_ ")" _loc__3_ )}
1258 1259
| _1 = module_type _2 = attribute
    {      ( Mty.attr _1 _2 )}
POTTIER Francois's avatar
POTTIER Francois committed
1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354
| _1000 = mty_longident
    {let _1 =
  let _endpos__100_ = _endpos__1000_ in
  let _startpos__100_ = _startpos__1000_ in
  let _100 = _1000 in
  let _1 =
    let _endpos__10_ = _endpos__100_ in
    let _startpos__10_ = _startpos__100_ in
    let _10 = _100 in
    let _1 =
      let _endpos__1_ = _endpos__10_ in
      let _startpos__1_ = _startpos__10_ in
      let _1 = _10 in
      let _endpos = _endpos__1_ in
      let _startpos = _startpos__1_ in
      let _loc = (_startpos, _endpos) in
          (
      (* Semantically we could use $symbolstartpos instead of $startpos
         here, but the code comes from calls to (Parsing.rhs_loc p) for
         some position p, which rather corresponds to
         $startpos, so we kept it for compatibility.

         I do not know if mkrhs is ever used in a situation where $startpos
         and $symbolpos do not coincide.  *)
      mkrhs _1 _loc )
    in
          ( Pmty_ident _1 )
  in
  let _endpos__1_ = _endpos__100_ in
  let _startpos__1_ = _startpos__100_ in
  let _endpos = _endpos__1_ in
  let _symbolstartpos = _startpos__1_ in
  let _sloc = (_symbolstartpos, _endpos) in
      ( mkmty ~loc:_sloc _1 )
in
      ( _1 )}
| _100 = module_type _200 = MINUSGREATER _300 = module_type %prec below_WITH
    {let _1 =
  let _endpos__30_ = _endpos__300_ in
  let _startpos__10_ = _startpos__100_ in
  let _30 = _300 in
  let _20 = _200 in
  let _10 = _100 in
  let _1 =
    let _3 = _30 in
    let _2 = _20 in
    let _1 = _10 in
          ( Pmty_functor(mknoloc "_", Some _1, _3) )
  in
  let _endpos__1_ = _endpos__30_ in
  let _startpos__1_ = _startpos__10_ in
  let _endpos = _endpos__1_ in
  let _symbolstartpos = _startpos__1_ in
  let _sloc = (_symbolstartpos, _endpos) in
      ( mkmty ~loc:_sloc _1 )
in
      ( _1 )}
| _100 = module_type _200 = WITH _300 = with_constraints
    {let _1 =
  let _endpos__30_ = _endpos__300_ in
  let _startpos__10_ = _startpos__100_ in
  let _30 = _300 in
  let _20 = _200 in
  let _10 = _100 in
  let _1 =
    let _3 = _30 in
    let _2 = _20 in
    let _1 = _10 in
          ( Pmty_with(_1, List.rev _3) )
  in
  let _endpos__1_ = _endpos__30_ in
  let _startpos__1_ = _startpos__10_ in
  let _endpos = _endpos__1_ in
  let _symbolstartpos = _startpos__1_ in
  let _sloc = (_symbolstartpos, _endpos) in
      ( mkmty ~loc:_sloc _1 )
in
      ( _1 )}
| _100 = extension
    {let _1 =
  let _endpos__10_ = _endpos__100_ in
  let _startpos__10_ = _startpos__100_ in
  let _10 = _100 in
  let _1 =
    let _1 = _10 in
          ( Pmty_extension _1 )
  in
  let _endpos__1_ = _endpos__10_ in
  let _startpos__1_ = _startpos__10_ in
  let _endpos = _endpos__1_ in
  let _symbolstartpos = _startpos__1_ in
  let _sloc = (_symbolstartpos, _endpos) in
      ( mkmty ~loc:_sloc _1 )
in
      ( _1 )}
1355 1356

signature:
POTTIER Francois's avatar
POTTIER Francois committed
1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368
  _10 = signature_nodoc
    {let _1 =
  let _endpos__1_ = _endpos__10_ in
  let _startpos__1_ = _startpos__10_ in
  let _1 = _10 in
  let _endpos = _endpos__1_ in
  let _startpos = _startpos__1_ in
                                ( extra_sig _startpos _endpos _1 )
in
                                      ( _1 )}

signature_nodoc:
1369
  
POTTIER Francois's avatar
POTTIER Francois committed
1370 1371 1372 1373 1374
    {                                   ( [] )}
| _1 = SEMISEMI _2 = signature_nodoc
    {                                   ( text_sig _startpos__1_ @ _2 )}
| _1 = signature_item _2 = signature_nodoc
    {                                   ( text_sig _startpos__1_ @ _1 :: _2 )}
1375 1376

signature_item:
POTTIER Francois's avatar
POTTIER Francois committed
1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409
  _1 = signature_item_with_ext
    {let _endpos = _endpos__1_ in
let _startpos = _startpos__1_ in
let _symbolstartpos = _startpos__1_ in
let _loc = (_startpos, _endpos) in
let _sloc = (_symbolstartpos, _endpos) in
      ( let item, ext = _1 in
        wrap_sig_ext ~loc:_loc (mksig ~loc:_sloc item) ext )}
| _1 = item_extension _2 = post_item_attributes
    {let _endpos = _endpos__2_ in
let _symbolstartpos = _startpos__1_ in
let _sloc = (_symbolstartpos, _endpos) in
      ( let docs = symbol_docs _sloc in
        mksig ~loc:_sloc (Psig_extension (_1, (add_docs_attrs docs _2))) )}
| _100 = floating_attribute
    {let _1 =
  let _endpos__10_ = _endpos__100_ in
  let _startpos__10_ = _startpos__100_ in
  let _10 = _100 in
  let _1 =
    let _1 = _10 in
          ( Psig_attribute _1 )
  in
  let _endpos__1_ = _endpos__10_ in
  let _startpos__1_ = _startpos__10_ in
  let _endpos = _endpos__1_ in
  let _symbolstartpos = _startpos__1_ in
  let _sloc = (_symbolstartpos, _endpos) in
      ( mksig ~loc:_sloc _1 )
in
      ( _1 )}

signature_item_with_ext:
1410
  _1 = value_description
POTTIER Francois's avatar
POTTIER Francois committed
1411
    {      ( let (body, ext) = _1 in (Psig_value body, ext) )}
1412
| _1 = primitive_declaration
POTTIER Francois's avatar
POTTIER Francois committed
1413
    {      ( let (body, ext) = _1 in (Psig_value body, ext) )}
1414
| _1 = type_declarations
POTTIER Francois's avatar
POTTIER Francois committed
1415
    {      ( let (nr, l, ext) = _1 in (Psig_type (nr, List.rev l), ext) )}
1416
| _1 = sig_type_extension
POTTIER Francois's avatar
POTTIER Francois committed
1417
    {      ( let (l, ext) = _1 in (Psig_typext l, ext) )}
1418
| _1 = sig_exception_declaration
POTTIER Francois's avatar
POTTIER Francois committed
1419
    {      ( let (l, ext) = _1 in (Psig_exception l, ext) )}
1420
| _1 = module_declaration
POTTIER Francois's avatar
POTTIER Francois committed
1421
    {      ( let (body, ext) = _1 in (Psig_module body, ext) )}
1422
| _1 = module_alias
POTTIER Francois's avatar
POTTIER Francois committed
1423
    {      ( let (body, ext) = _1 in (Psig_module body, ext) )}
1424
| _1 = rec_module_declarations
POTTIER Francois's avatar
POTTIER Francois committed
1425