/* */

/* OCaml */

/* */

/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */

/* */

/* Copyright 1996 Institut National de Recherche en Informatique et */

/* en Automatique. */

/* */

/* All rights reserved. This file is distributed under the terms of */

/* the GNU Lesser General Public License version 2.1, with the */

/* special exception on linking described in the file LICENSE. */

/* */

/* The parser definition */

/* The commands [make list-parse-errors] and [make generate-parse-errors]

run Menhir on a modified copy of the parser where every block of

text comprised between the markers [BEGIN AVOID] and -----------

[END AVOID] has been removed. This file should be formatted in

such a way that this results in a clean removal of certain

symbols, productions, or declarations. */

%{

open Asttypes

open Longident

open Parsetree

open Ast_helper

open Docstrings

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 ?attrs d = Typ.mk ~loc:(make_loc loc) ?attrs 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 pstr_typext (te, ext) =

(Pstr_typext te, ext)

let pstr_primitive (vd, ext) =

(Pstr_primitive vd, ext)

let pstr_type ((nr, ext), tys) =

(Pstr_type (nr, tys), ext)

let pstr_exception (te, ext) =

(Pstr_exception te, ext)

let pstr_include (body, ext) =

(Pstr_include body, ext)

let pstr_recmodule (ext, bindings) =

(Pstr_recmodule bindings, ext)

let psig_typext (te, ext) =

(Psig_typext te, ext)

let psig_value (vd, ext) =

(Psig_value vd, ext)

let psig_type ((nr, ext), tys) =

(Psig_type (nr, tys), ext)

let psig_typesubst ((nr, ext), tys) =

assert (nr = Recursive); (* see [no_nonrec_flag] *)

(Psig_typesubst tys, ext)

let psig_exception (te, ext) =

(Psig_exception te, ext)

let psig_include (body, ext) =

(Psig_include body, ext)

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 push_loc x acc =

if x.Location.loc_ghost

then acc

else x :: acc

let reloc_pat ~loc x =

{ x with ppat_loc = make_loc loc;

ppat_loc_stack = push_loc x.ppat_loc x.ppat_loc_stack };;

let reloc_exp ~loc x =

{ x with pexp_loc = make_loc loc;

pexp_loc_stack = push_loc x.pexp_loc x.pexp_loc_stack };;

let reloc_typ ~loc x =

{ x with ptyp_loc = make_loc loc;

ptyp_loc_stack = push_loc x.ptyp_loc x.ptyp_loc_stack };;

let mkexpvar ~loc (name : string) =

mkexp ~loc (Pexp_ident(mkrhs (Lident name) loc))

let mkoperator =

mkexpvar

let mkpatvar ~loc name =

mkpat ~loc (Ppat_var (mkrhs name loc))

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

let mkinfix arg1 op arg2 =

Pexp_apply(op, [Nolabel, arg1; Nolabel, arg2])

let neg_string f =

if String.length f > 0 && f.[0] = '-'

then String.sub f 1 (String.length f - 1)

else "-" ^ f

let mkuminus ~oploc name arg =

match name, arg.pexp_desc with

| "-", 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))

| _ ->

Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])

let mkuplus ~oploc name arg =

let desc = arg.pexp_desc in

match name, desc with

| "+", Pexp_constant(Pconst_integer _)

| ("+" | "+."), Pexp_constant(Pconst_float _) -> desc

| _ ->

Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])

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)

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)

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

[] ->

let nil = ghloc ~loc:nilloc (Lident "[]") in

Pexp_construct (nil, None), nilloc

| e1 :: el ->

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

let rec mktailpat nilloc = let open Location in function

[] ->

let nil = ghloc ~loc:nilloc (Lident "[]") in

Ppat_construct (nil, None), nilloc

| p1 :: pl ->

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

let mkstrexp e attrs =

{ pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc }

let mkexp_constraint ~loc e (t1, t2) =

match t1, t2 with

| Some t, None -> ghexp ~loc (Pexp_constraint(e, t))

| _, Some t -> ghexp ~loc (Pexp_coerce(e, t1, t))

| None, None -> assert false

let mkexp_opt_constraint ~loc e = function

| None -> e

| Some constraint_ -> mkexp_constraint ~loc e constraint_

let mkpat_opt_constraint ~loc p = function

| None -> p

| Some typ -> ghpat ~loc (Ppat_constraint(p, typ))

let syntax_error () =

raise Syntaxerr.Escape_error

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)))

let expecting loc nonterm =

raise Syntaxerr.(Error(Expecting(make_loc loc, nonterm)))

let not_expecting loc nonterm =

raise Syntaxerr.(Error(Not_expecting(make_loc loc, nonterm)))

let dotop ~left ~right ~assign ~ext ~multi =

let assign = if assign then "<-" else "" in

let mid = if multi then ";.." else "" in

String.concat "" ["."; ext; left; mid; right; assign]

let paren = "(",")"

let brace = "{", "}"

let bracket = "[", "]"

let lident x = Lident x

let ldot x y = Ldot(x,y)

let dotop_fun ~loc dotop =

ghexp ~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 multi_indices ~loc = function

| [a] -> false, a

| l -> true, mkexp ~loc (Pexp_array l)

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 path (left,right) ext array index =

let multi, index = multi_indices ~loc index in

index_get ~loc

(dotop_fun ~loc (path @@ dotop ~left ~right ~ext ~multi ~assign:false))

array index

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 path (left,right) ext array index value=

let multi, index = multi_indices ~loc index in

index_set ~loc

(dotop_fun ~loc (path @@ dotop ~left ~right ~ext ~multi ~assign:true))

array index value

let bigarray_function ~loc str name =

ghloc ~loc (Ldot(Ldot(Lident "Bigarray", str), name))

let bigarray_untuplify = function

{ pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist

| exp -> [exp]

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

match bigarray_untuplify arg with

[c1] ->

mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" get)),

[Nolabel, arr; Nolabel, c1]))

| [c1;c2] ->

mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" get)),

[Nolabel, arr; Nolabel, c1; Nolabel, c2]))

| [c1;c2;c3] ->

mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" get)),

[Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3]))

| coords ->

mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")),

[Nolabel, arr; Nolabel, ghexp(Pexp_array coords)]))

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

match bigarray_untuplify arg with

[c1] ->

mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" set)),

[Nolabel, arr; Nolabel, c1; Nolabel, newval]))

| [c1;c2] ->

mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" set)),

[Nolabel, arr; Nolabel, c1;

Nolabel, c2; Nolabel, newval]))

| [c1;c2;c3] ->

mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" set)),

[Nolabel, arr; Nolabel, c1;

Nolabel, c2; Nolabel, c3; Nolabel, newval]))

| coords ->

mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")),

[Nolabel, arr;

Nolabel, ghexp(Pexp_array coords);

Nolabel, newval]))

let lapply ~loc p1 p2 =

if !Clflags.applicative_functors

then Lapply(p1, p2)

else raise (Syntaxerr.Error(

Syntaxerr.Applicative_path (make_loc loc)))

let loc_map (f : 'a -> 'b) (x : 'a Location.loc) : 'b Location.loc =

{ x with txt = f x.txt }

let make_ghost x = { x with loc = { x.loc with loc_ghost = true }}

let loc_last (id : Longident.t Location.loc) : string Location.loc =

loc_map Longident.last id

let loc_lident (id : string Location.loc) : Longident.t Location.loc =

loc_map (fun x -> Lident x) id

let exp_of_longident ~loc lid =

let lid = make_ghost (loc_map (fun id -> Lident (Longident.last id)) lid) in

ghexp ~loc (Pexp_ident lid)

let exp_of_label ~loc lbl =

mkexp ~loc (Pexp_ident (loc_lident lbl))

let pat_of_label lbl =

Pat.mk ~loc:lbl.loc (Ppat_var (loc_last lbl))

let mk_newtypes ~loc newtypes exp =

let mkexp = mkexp ~loc in

List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp)))

newtypes exp

let wrap_type_annotation ~loc newtypes core_type body =

let mkexp, ghtyp = mkexp ~loc, ghtyp ~loc in

let mk_newtypes = mk_newtypes ~loc in

let exp = mkexp(Pexp_constraint(body,core_type)) in

let exp = mk_newtypes newtypes exp in

(exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type)))

let wrap_exp_attrs ~loc body (ext, attrs) =

let ghexp = ghexp ~loc in

(* 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 []]))

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:_ attrs body =

{body with pmod_attributes = attrs @ body.pmod_attributes}

let wrap_mty_attrs ~loc:_ attrs body =

{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_mkstr_ext ~loc (item, ext) =

wrap_str_ext ~loc (mkstr ~loc item) ext

let wrap_sig_ext ~loc body ext =

match ext with

| None -> body

| Some id -> ghsig ~loc (Psig_extension ((id, PSig [body]), []))

let wrap_mksig_ext ~loc (item, ext) =

wrap_sig_ext ~loc (mksig ~loc item) ext

let mk_quotedext ~loc (id, idloc, str, strloc, delim) =

let exp_id = mkloc id idloc in

let e = ghexp ~loc (Pexp_constant (Pconst_string (str, strloc, delim))) in

(exp_id, PStr [mkstrexp e []])

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 =

List.map (fun def -> Ptop_def [def]) (Str.text (rhs_text pos))

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 -> List.map (fun def -> Ptop_def [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 }

type let_binding =

{ lb_pattern: pattern;

lb_expression: expression;

lb_is_pun: bool;

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 }

let mklb first ~loc (p, e, is_pun) attrs =

{

lb_pattern = p;

lb_expression = e;

lb_is_pun = is_pun;

lb_attributes = attrs;

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 addlb lbs lb =

if lb.lb_is_pun && lbs.lbs_extension = None then syntax_error ();

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

let mklbs ~loc ext rf lb =

let lbs = {

lbs_bindings = [];

lbs_rec = rf;

lbs_extension = ext ;

lbs_loc = make_loc loc;

} in

addlb lbs lb

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

in

let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in

match lbs.lbs_extension with

| None -> str

| Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), []))

let expr_of_let_bindings ~loc lbs body =

let bindings =

List.map

(fun lb ->

Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes

lb.lb_pattern lb.lb_expression)

lbs.lbs_bindings

in

mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body))

(lbs.lbs_extension, [])

let class_of_let_bindings ~loc lbs body =

let bindings =

List.map

(fun lb ->

Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes

lb.lb_pattern lb.lb_expression)

lbs.lbs_bindings

in

(* Our use of let_bindings(no_ext) guarantees the following: *)

assert (lbs.lbs_extension = None);

mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body))

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.pmty_attributes)

| {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} ->

(lid, List.map map_cstr cstrs, pmty.pmty_attributes)

| _ ->

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;

}

%}

/* Tokens */

/* The alias that follows each token is used by Menhir when it needs to

produce a sentence (that is, a sequence of tokens) in concrete syntax. */

/* Some tokens represent multiple concrete strings. In most cases, an

arbitrary concrete string can be chosen. In a few cases, one must

be careful: e.g., in PREFIXOP and INFIXOP2, one must choose a concrete

string that will not trigger a syntax error; see how [not_expecting]

is used in the definition of [type_variance]. */

%token AMPERAMPER "&&"

%token AMPERSAND "&"

%token AND "and"

%token AS "as"

%token ASSERT "assert"

%token BACKQUOTE "`"

%token BANG "!"

%token BAR "|"

%token BARBAR "||"

%token BARRBRACKET "|]"

%token BEGIN "begin"

%token <char> CHAR "'a'" (* just an example *)

%token CLASS "class"

%token COLON ":"

%token COLONCOLON "::"

%token COLONEQUAL ":="

%token COLONGREATER ":>"

%token COMMA ","

%token CONSTRAINT "constraint"

%token DO "do"

%token DONE "done"

%token DOT "."

%token DOTDOT ".."

%token DOWNTO "downto"

%token ELSE "else"

%token END "end"

%token EOF ""

%token EQUAL "="

%token EXCEPTION "exception"

%token EXTERNAL "external"

%token FALSE "false"

%token <string * char option> FLOAT "42.0" (* just an example *)

%token FOR "for"

%token FUN "fun"

%token FUNCTION "function"

%token FUNCTOR "functor"

%token GREATER ">"

%token GREATERRBRACE ">}"

%token GREATERRBRACKET ">]"

%token IF "if"

%token IN "in"

%token INCLUDE "include"

%token <string> INFIXOP0 "!=" (* just an example *)

%token <string> INFIXOP1 "@" (* just an example *)

%token <string> INFIXOP2 "+!" (* chosen with care; see above *)

%token <string> INFIXOP3 "land" (* just an example *)

%token <string> INFIXOP4 "**" (* just an example *)

%token <string> DOTOP ".+"

%token <string> LETOP "let*" (* just an example *)

%token <string> ANDOP "and*" (* just an example *)

%token INHERIT "inherit"

%token INITIALIZER "initializer"

%token <string * char option> INT "42" (* just an example *)

%token <string> LABEL "~label:" (* just an example *)

%token LAZY "lazy"

%token LBRACE "{"

%token LBRACELESS "{<"

%token LBRACKET "["

%token LBRACKETBAR "[|"

%token LBRACKETLESS "[<"

%token LBRACKETGREATER "[>"

%token LBRACKETPERCENT "[%"

%token LBRACKETPERCENTPERCENT "[%%"

%token LESS "<"

%token LESSMINUS "<-"

%token LET "let"

%token <string> LIDENT "lident" (* just an example *)

%token LPAREN "("

%token LBRACKETAT "[@"

%token LBRACKETATAT "[@@"

%token LBRACKETATATAT "[@@@"

%token MATCH "match"

%token METHOD "method"

%token MINUS "-"

%token MINUSDOT "-."

%token MINUSGREATER "->"

%token MODULE "module"

%token MUTABLE "mutable"

%token NEW "new"

%token NONREC "nonrec"

%token OBJECT "object"

%token OF "of"

%token OPEN "open"

%token <string> OPTLABEL "?label:" (* just an example *)

%token OR "or"

/* %token PARSER "parser" */

%token PERCENT "%"

%token PLUS "+"

%token PLUSDOT "+."

%token PLUSEQ "+="

%token <string> PREFIXOP "!+" (* chosen with care; see above *)

%token PRIVATE "private"

%token QUESTION "?"

%token QUOTE "'"

%token RBRACE "}"

%token RBRACKET "]"

%token REC "rec"

%token RPAREN ")"

%token SEMI ";"

%token SEMISEMI ";;"

%token HASH "#"

%token <string> HASHOP "##" (* just an example *)

%token SIG "sig"

%token STAR "*"

%token <string * Location.t * string option>

STRING "\"hello\"" (* just an example *)

%token <string * Location.t * string * Location.t * string option>

QUOTED_STRING_EXPR "{%hello|world|}" (* just an example *)

%token <string * Location.t * string * Location.t * string option>

QUOTED_STRING_ITEM "{%%hello|world|}" (* just an example *)

%token STRUCT "struct"

%token THEN "then"

%token TILDE "~"

%token TO "to"

%token TRUE "true"

%token TRY "try"

%token TYPE "type"

%token <string> UIDENT "UIdent" (* just an example *)

%token UNDERSCORE "_"

%token VAL "val"

%token VIRTUAL "virtual"

%token WHEN "when"

%token WHILE "while"

%token WITH "with"

%token <string * Location.t> COMMENT "(* comment *)"

%token <Docstrings.docstring> DOCSTRING "(** documentation *)"

%token EOL "\\n" (* not great, but EOL is unused *)

/* Precedences and associativities.

Tokens and rules have precedences. A reduce/reduce conflict is resolved

in favor of the first rule (in source file order). A shift/reduce conflict

is resolved by comparing the precedence and associativity of the token to

be shifted with those of the rule to be reduced.

By default, a rule has the precedence of its rightmost terminal (if any).

When there is a shift/reduce conflict between a rule and a token that

have the same precedence, it is resolved using the associativity:

if the token is left-associative, the parser will reduce; if

right-associative, the parser will shift; if non-associative,

the parser will declare a syntax error.

We will only use associativities with operators of the kind x * x -> x

for example, in the rules of the form expr: expr BINOP expr

in all other cases, we define two precedences if needed to resolve

conflicts.

The precedences must be listed from low to high.

*/

%nonassoc IN

%nonassoc below_SEMI

%nonassoc SEMI /* below EQUAL ({lbl=...; lbl=...}) */

%nonassoc LET /* above SEMI ( ...; let ... in ...) */

%nonassoc below_WITH

%nonassoc FUNCTION WITH /* below BAR (match ... with ...) */

%nonassoc AND /* above WITH (module rec A: SIG with ... and ...) */

%nonassoc THEN /* below ELSE (if ... then ...) */

%nonassoc ELSE /* (if ... then ... else ...) */

%nonassoc LESSMINUS /* below COLONEQUAL (lbl <- x := e) */

%right COLONEQUAL /* expr (e := e := e) */

%nonassoc AS

%left BAR /* pattern (p|p|p) */

%nonassoc below_COMMA

%left COMMA /* expr/expr_comma_list (e,e,e) */

%right MINUSGREATER /* function_type (t -> t -> t) */

%right OR BARBAR /* expr (e || e || e) */

%right AMPERSAND AMPERAMPER /* expr (e && e && e) */

%nonassoc below_EQUAL

%left INFIXOP0 EQUAL LESS GREATER /* expr (e OP e OP e) */

%right INFIXOP1 /* expr (e OP e OP e) */

%nonassoc below_LBRACKETAT

%nonassoc LBRACKETAT

%right COLONCOLON /* expr (e :: e :: e) */

%left INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT PLUSEQ /* expr (e OP e OP e) */

%left PERCENT INFIXOP3 STAR /* expr (e OP e OP e) */

%right INFIXOP4 /* expr (e OP e OP e) */

%nonassoc prec_unary_minus prec_unary_plus /* unary - */

%nonassoc prec_constant_constructor /* cf. simple_expr (C versus C x) */

%nonassoc prec_constr_appl /* above AS BAR COLONCOLON COMMA */

%nonassoc below_HASH

%nonassoc HASH /* simple_expr/toplevel_directive */

%left HASHOP

%nonassoc below_DOT

%nonassoc DOT DOTOP

/* Finally, the first tokens of simple_expr are above everything else. */

%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT

LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN

NEW PREFIXOP STRING TRUE UIDENT

LBRACKETPERCENT QUOTED_STRING_EXPR

/* Entry points */

/* Several start symbols are marked with AVOID so that they are not used by

[make generate-parse-errors]. The three start symbols that we keep are

[implementation], [use_file], and [toplevel_phrase]. The latter two are

of marginal importance; only [implementation] really matters, since most

states in the automaton are reachable from it. */

%start implementation /* for implementation files */

%type <Parsetree.structure> implementation

/* BEGIN AVOID */

%start interface /* for interface files */

%type <Parsetree.signature> interface

/* END AVOID */

%start toplevel_phrase /* for interactive use */

%type <Parsetree.toplevel_phrase> toplevel_phrase

%start use_file /* for the #use directive */

%type <Parsetree.toplevel_phrase list> use_file

/* BEGIN AVOID */

%start parse_core_type

%type <Parsetree.core_type> parse_core_type

%start parse_expression

%type <Parsetree.expression> parse_expression

%start parse_pattern

%type <Parsetree.pattern> parse_pattern

%start parse_constr_longident

%type <Longident.t> parse_constr_longident

%start parse_val_longident

%type <Longident.t> parse_val_longident

%start parse_mty_longident

%type <Longident.t> parse_mty_longident

%start parse_mod_ext_longident

%type <Longident.t> parse_mod_ext_longident

%start parse_mod_longident

%type <Longident.t> parse_mod_longident

%start parse_any_longident

%type <Longident.t> parse_any_longident

/* END AVOID */

%%

/* macros */

%inline extra_str(symb): symb { extra_str $startpos $endpos $1 };

%inline extra_sig(symb): symb { extra_sig $startpos $endpos $1 };

%inline extra_cstr(symb): symb { extra_cstr $startpos $endpos $1 };

%inline extra_csig(symb): symb { extra_csig $startpos $endpos $1 };

%inline extra_def(symb): symb { extra_def $startpos $endpos $1 };

%inline extra_text(symb): symb { extra_text $startpos $endpos $1 };

%inline extra_rhs(symb): symb { extra_rhs_core_type $1 ~pos:$endpos($1) };

%inline mkrhs(symb): symb

{ mkrhs $1 $sloc }

;

%inline text_str(symb): symb

{ text_str $startpos @ [$1] }

%inline text_str_SEMISEMI: SEMISEMI

{ text_str $startpos }

%inline text_sig(symb): symb

{ text_sig $startpos @ [$1] }

%inline text_sig_SEMISEMI: SEMISEMI

{ text_sig $startpos }

%inline text_def(symb): symb

{ text_def $startpos @ [$1] }

%inline top_def(symb): symb

{ Ptop_def [$1] }

%inline text_cstr(symb): symb

{ text_cstr $startpos @ [$1] }

%inline text_csig(symb): symb

{ text_csig $startpos @ [$1] }

%inline mark_rhs_docs(symb): symb

{ mark_rhs_docs $startpos $endpos;

%inline op(symb): symb

{ mkoperator ~loc:$sloc $1 }

%inline mkloc(symb): symb

{ mkloc $1 (make_loc $sloc) }

%inline mkexp(symb): symb

{ mkexp ~loc:$sloc $1 }

%inline mkpat(symb): symb

{ mkpat ~loc:$sloc $1 }

%inline mktyp(symb): symb

{ mktyp ~loc:$sloc $1 }

%inline mkstr(symb): symb

{ mkstr ~loc:$sloc $1 }

%inline mksig(symb): symb

{ mksig ~loc:$sloc $1 }

%inline mkmod(symb): symb

{ mkmod ~loc:$sloc $1 }

%inline mkmty(symb): symb

{ mkmty ~loc:$sloc $1 }

%inline mkcty(symb): symb

{ mkcty ~loc:$sloc $1 }

%inline mkctf(symb): symb

{ mkctf ~loc:$sloc $1 }

%inline mkcf(symb): symb

{ mkcf ~loc:$sloc $1 }

%inline mkclass(symb): symb

{ mkclass ~loc:$sloc $1 }

%inline wrap_mkstr_ext(symb): symb

{ wrap_mkstr_ext ~loc:$sloc $1 }

%inline wrap_mksig_ext(symb): symb

{ wrap_mksig_ext ~loc:$sloc $1 }

%inline mk_directive_arg(symb): symb

{ mk_directive_arg ~loc:$sloc $1 }

/* Generic definitions */

%inline iloption(X):

/* nothing */

{ [] }

| x = X

{ x }

reversed_llist(X):

/* empty */

{ [] }

| xs = reversed_llist(X) x = X

{ x :: xs }

%inline llist(X):

xs = rev(reversed_llist(X))

{ xs }

reversed_nonempty_llist(X):

x = X

{ [ x ] }

| xs = reversed_nonempty_llist(X) x = X

{ x :: xs }

%inline nonempty_llist(X):

xs = rev(reversed_nonempty_llist(X))

{ xs }

%inline inline_reversed_separated_nonempty_llist(separator, X):

x = X

{ [ x ] }

| xs = reversed_separated_nonempty_llist(separator, X)

separator

x = X

{ x :: xs }

reversed_separated_nonempty_llist(separator, X):

xs = inline_reversed_separated_nonempty_llist(separator, X)

{ xs }

%inline separated_nonempty_llist(separator, X):

xs = rev(reversed_separated_nonempty_llist(separator, X))

{ xs }

%inline inline_separated_nonempty_llist(separator, X):

xs = rev(inline_reversed_separated_nonempty_llist(separator, X))

{ xs }