Notes on Unicon's grammar.

bench/good/ocaml.mly

 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -10,8 +10,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: parser.mly,v 1.121 2004/10/06 13:06:11 garrigue Exp $ */
-
 /* The parser definition */
 
 %{
@@ -19,40 +17,41 @@ open Location
 open Asttypes
 open Longident
 open Parsetree
-
-let mktyp d =
-  { ptyp_desc = d; ptyp_loc = symbol_rloc() }
-let mkpat d =
-  { ppat_desc = d; ppat_loc = symbol_rloc() }
-let mkexp d =
-  { pexp_desc = d; pexp_loc = symbol_rloc() }
-let mkmty d =
-  { pmty_desc = d; pmty_loc = symbol_rloc() }
-let mksig d =
-  { psig_desc = d; psig_loc = symbol_rloc() }
-let mkmod d =
-  { pmod_desc = d; pmod_loc = symbol_rloc() }
-let mkstr d =
-  { pstr_desc = d; pstr_loc = symbol_rloc() }
-let mkfield d =
-  { pfield_desc = d; pfield_loc = symbol_rloc() }
-let mkclass d =
-  { pcl_desc = d; pcl_loc = symbol_rloc() }
-let mkcty d =
-  { pcty_desc = d; pcty_loc = symbol_rloc() }
+open Ast_helper
+open Docstrings
+
+let mktyp d = Typ.mk ~loc:(symbol_rloc()) d
+let mkpat d = Pat.mk ~loc:(symbol_rloc()) d
+let mkexp d = Exp.mk ~loc:(symbol_rloc()) d
+let mkmty d = Mty.mk ~loc:(symbol_rloc()) d
+let mksig d = Sig.mk ~loc:(symbol_rloc()) d
+let mkmod d = Mod.mk ~loc:(symbol_rloc()) d
+let mkstr d = Str.mk ~loc:(symbol_rloc()) d
+let mkclass d = Cl.mk ~loc:(symbol_rloc()) d
+let mkcty d = Cty.mk ~loc:(symbol_rloc()) d
+let mkctf ?attrs ?docs d =
+  Ctf.mk ~loc:(symbol_rloc()) ?attrs ?docs d
+let mkcf ?attrs ?docs d =
+  Cf.mk ~loc:(symbol_rloc()) ?attrs ?docs d
+
+let mkrhs rhs pos = mkloc rhs (rhs_loc pos)
 
 let reloc_pat x = { x with ppat_loc = symbol_rloc () };;
 let reloc_exp x = { x with pexp_loc = symbol_rloc () };;
 
 let mkoperator name pos =
-  { pexp_desc = Pexp_ident(Lident name); pexp_loc = rhs_loc pos }
+  let loc = rhs_loc pos in
+  Exp.mk ~loc (Pexp_ident(mkloc (Lident name) loc))
+
+let mkpatvar name pos =
+  Pat.mk ~loc:(rhs_loc pos) (Ppat_var (mkrhs name pos))
 
 (*
   Ghost expressions and patterns:
-  expressions and patterns that do not appear explicitely in the
+  expressions and patterns that do not appear explicitly in the
   source file they have the loc_ghost flag set to true.
   Then the profiler will not try to instrument them and the
-  -stypes option will not try to display their type.
+  -annot option will not try to display their type.
 
   Every grammar rule that generates an element with a location must
   make at most one non-ghost element, the topmost one.
@@ -64,19 +63,17 @@ let mkoperator name pos =
   AST node, then the location must be real; in all other cases,
   it must be ghost.
 *)
-let ghexp d = { pexp_desc = d; pexp_loc = symbol_gloc () };;
-let ghpat d = { ppat_desc = d; ppat_loc = symbol_gloc () };;
-let ghtyp d = { ptyp_desc = d; ptyp_loc = symbol_gloc () };;
+let ghexp d = Exp.mk ~loc:(symbol_gloc ()) d
+let ghpat d = Pat.mk ~loc:(symbol_gloc ()) d
+let ghtyp d = Typ.mk ~loc:(symbol_gloc ()) d
+let ghloc d = { txt = d; loc = symbol_gloc () }
+let ghstr d = Str.mk ~loc:(symbol_gloc()) d
 
-let mkassert e =
-  match e with
-  | {pexp_desc = Pexp_construct (Lident "false", None, false) } ->
-         mkexp (Pexp_assertfalse)
-  | _ -> mkexp (Pexp_assert (e))
-;;
+let ghunit () =
+  ghexp (Pexp_construct (mknoloc (Lident "()"), None))
 
 let mkinfix arg1 name arg2 =
-  mkexp(Pexp_apply(mkoperator name 2, ["", arg1; "", arg2]))
+  mkexp(Pexp_apply(mkoperator name 2, [Nolabel, arg1; Nolabel, arg2]))
 
 let neg_float_string f =
   if String.length f > 0 && f.[0] = '-'
@@ -93,50 +90,68 @@ let mkuminus name arg =
       mkexp(Pexp_constant(Const_int64(Int64.neg n)))
   | "-", Pexp_constant(Const_nativeint n) ->
       mkexp(Pexp_constant(Const_nativeint(Nativeint.neg n)))
-  | _, Pexp_constant(Const_float f) ->
+  | ("-" | "-."), Pexp_constant(Const_float f) ->
       mkexp(Pexp_constant(Const_float(neg_float_string f)))
   | _ ->
-      mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg]))
+      mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg]))
+
+let mkuplus name arg =
+  let desc = arg.pexp_desc in
+  match name, desc with
+  | "+", Pexp_constant(Const_int _)
+  | "+", Pexp_constant(Const_int32 _)
+  | "+", Pexp_constant(Const_int64 _)
+  | "+", Pexp_constant(Const_nativeint _)
+  | ("+" | "+."), Pexp_constant(Const_float _) -> mkexp desc
+  | _ ->
+      mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg]))
 
-let rec mktailexp = function
+let mkexp_cons consloc args loc =
+  Exp.mk ~loc (Pexp_construct(mkloc (Lident "::") consloc, Some args))
+
+let mkpat_cons consloc args loc =
+  Pat.mk ~loc (Ppat_construct(mkloc (Lident "::") consloc, Some args))
+
+let rec mktailexp nilloc = function
     [] ->
-      ghexp(Pexp_construct(Lident "[]", None, false))
+      let loc = { nilloc with loc_ghost = true } in
+      let nil = { txt = Lident "[]"; loc = loc } in
+      Exp.mk ~loc (Pexp_construct (nil, None))
   | e1 :: el ->
-      let exp_el = mktailexp el in
-      let l = {loc_start = e1.pexp_loc.loc_start;
+      let exp_el = mktailexp nilloc el in
+      let loc = {loc_start = e1.pexp_loc.loc_start;
                loc_end = exp_el.pexp_loc.loc_end;
                loc_ghost = true}
       in
-      let arg = {pexp_desc = Pexp_tuple [e1; exp_el]; pexp_loc = l} in
-      {pexp_desc = Pexp_construct(Lident "::", Some arg, false); pexp_loc = l}
+      let arg = Exp.mk ~loc (Pexp_tuple [e1; exp_el]) in
+      mkexp_cons {loc with loc_ghost = true} arg loc
 
-let rec mktailpat = function
+let rec mktailpat nilloc = function
     [] ->
-      ghpat(Ppat_construct(Lident "[]", None, false))
+      let loc = { nilloc with loc_ghost = true } in
+      let nil = { txt = Lident "[]"; loc = loc } in
+      Pat.mk ~loc (Ppat_construct (nil, None))
   | p1 :: pl ->
-      let pat_pl = mktailpat pl in
-      let l = {loc_start = p1.ppat_loc.loc_start;
+      let pat_pl = mktailpat nilloc pl in
+      let loc = {loc_start = p1.ppat_loc.loc_start;
                loc_end = pat_pl.ppat_loc.loc_end;
                loc_ghost = true}
       in
-      let arg = {ppat_desc = Ppat_tuple [p1; pat_pl]; ppat_loc = l} in
-      {ppat_desc = Ppat_construct(Lident "::", Some arg, false); ppat_loc = l}
+      let arg = Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in
+      mkpat_cons {loc with loc_ghost = true} arg loc
 
-let ghstrexp e =
-  { pstr_desc = Pstr_eval e; pstr_loc = {e.pexp_loc with loc_ghost = true} }
+let mkstrexp e attrs =
+  { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc }
 
-let array_function str name =
-  Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name))
+let mkexp_constraint e (t1, t2) =
+  match t1, t2 with
+  | Some t, None -> ghexp(Pexp_constraint(e, t))
+  | _, Some t -> ghexp(Pexp_coerce(e, t1, t))
+  | None, None -> assert false
 
-let rec deep_mkrangepat c1 c2 =
-  if c1 = c2 then ghpat(Ppat_constant(Const_char c1)) else
-  ghpat(Ppat_or(ghpat(Ppat_constant(Const_char c1)),
-                deep_mkrangepat (Char.chr(Char.code c1 + 1)) c2))
-
-let rec mkrangepat c1 c2 =
-  if c1 > c2 then mkrangepat c2 c1 else
-  if c1 = c2 then mkpat(Ppat_constant(Const_char c1)) else
-  reloc_pat (deep_mkrangepat c1 c2)
+let array_function par assign=
+  let op = if assign then par^"<-" else par in
+  ghloc ( Lident op )
 
 let syntax_error () =
   raise Syntaxerr.Escape_error
@@ -145,44 +160,244 @@ let unclosed opening_name opening_num closing_name closing_num =
   raise(Syntaxerr.Error(Syntaxerr.Unclosed(rhs_loc opening_num, opening_name,
                                            rhs_loc closing_num, closing_name)))
 
-let bigarray_function str name =
-  Ldot(Ldot(Lident "Bigarray", str), name)
+let expecting pos nonterm =
+    raise Syntaxerr.(Error(Expecting(rhs_loc pos, nonterm)))
+
+let not_expecting pos nonterm =
+    raise Syntaxerr.(Error(Not_expecting(rhs_loc pos, nonterm)))
+
+let bigarray_function order assign =
+  let op =
+    match order with
+      | 1 -> ".{}"
+      | 2 -> ".{,}"
+      | 3 -> ".{,,}"
+      | _ -> ".{,..,}"
+  in
+  let op= if assign then op^"<-" else op in
+  ghloc ( Lident op )
 
 let bigarray_untuplify = function
-    { pexp_desc = Pexp_tuple explist} -> explist
+    { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist
   | exp -> [exp]
 
 let bigarray_get arr arg =
+  let get order = bigarray_function order false in
   match bigarray_untuplify arg with
     [c1] ->
-      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" "get")),
-                       ["", arr; "", c1]))
+      mkexp(Pexp_apply(ghexp(Pexp_ident(get 1)),
+                       [Nolabel, arr; Nolabel, c1]))
   | [c1;c2] ->
-      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" "get")),
-                       ["", arr; "", c1; "", c2]))
+      mkexp(Pexp_apply(ghexp(Pexp_ident(get 2)),
+                       [Nolabel, arr; Nolabel, c1; Nolabel, c2]))
   | [c1;c2;c3] ->
-      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" "get")),
-                       ["", arr; "", c1; "", c2; "", c3]))
+      mkexp(Pexp_apply(ghexp(Pexp_ident(get 3)),
+                       [Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3]))
   | coords ->
-      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")),
-                       ["", arr; "", ghexp(Pexp_array coords)]))
+      mkexp(Pexp_apply(ghexp(Pexp_ident(get 0)),
+                       [Nolabel, arr; Nolabel, ghexp(Pexp_array coords)]))
 
 let bigarray_set arr arg newval =
+  let set order = bigarray_function order true in
   match bigarray_untuplify arg with
     [c1] ->
-      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" "set")),
-                       ["", arr; "", c1; "", newval]))
+      mkexp(Pexp_apply(ghexp(Pexp_ident(set 1)),
+                       [Nolabel, arr; Nolabel, c1; Nolabel, newval]))
   | [c1;c2] ->
-      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" "set")),
-                       ["", arr; "", c1; "", c2; "", newval]))
+      mkexp(Pexp_apply(ghexp(Pexp_ident(set 2)),
+                       [Nolabel, arr; Nolabel, c1; Nolabel, c2;
+                        Nolabel, newval]))
   | [c1;c2;c3] ->
-      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" "set")),
-                       ["", arr; "", c1; "", c2; "", c3; "", newval]))
+      mkexp(Pexp_apply(ghexp(Pexp_ident(set 3)),
+                       [Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3;
+                        Nolabel, newval]))
   | coords ->
-      mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")),
-                       ["", arr; 
-                        "", ghexp(Pexp_array coords);
-                        "", newval]))
+      mkexp(Pexp_apply(ghexp(Pexp_ident(set 0)),
+                       [Nolabel, arr;
+                        Nolabel, ghexp(Pexp_array coords);
+                        Nolabel, newval]))
+
+let lapply p1 p2 =
+  if !Clflags.applicative_functors
+  then Lapply(p1, p2)
+  else raise (Syntaxerr.Error(Syntaxerr.Applicative_path (symbol_rloc())))
+
+let exp_of_label lbl pos =
+  mkexp (Pexp_ident(mkrhs (Lident(Longident.last lbl)) pos))
+
+let pat_of_label lbl pos =
+  mkpat (Ppat_var (mkrhs (Longident.last lbl) pos))
+
+let check_variable vl loc v =
+  if List.mem v vl then
+    raise Syntaxerr.(Error(Variable_in_scope(loc,v)))
+
+let varify_constructors var_names t =
+  let rec loop t =
+    let desc =
+      match t.ptyp_desc with
+      | Ptyp_any -> Ptyp_any
+      | Ptyp_var x ->
+          check_variable var_names t.ptyp_loc x;
+          Ptyp_var x
+      | Ptyp_arrow (label,core_type,core_type') ->
+          Ptyp_arrow(label, loop core_type, loop core_type')
+      | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
+      | Ptyp_constr( { txt = Lident s }, []) when List.mem s var_names ->
+          Ptyp_var s
+      | Ptyp_constr(longident, lst) ->
+          Ptyp_constr(longident, List.map loop lst)
+      | Ptyp_object (lst, o) ->
+          Ptyp_object
+            (List.map (fun (s, attrs, t) -> (s, attrs, loop t)) lst, o)
+      | Ptyp_class (longident, lst) ->
+          Ptyp_class (longident, List.map loop lst)
+      | Ptyp_alias(core_type, string) ->
+          check_variable var_names t.ptyp_loc string;
+          Ptyp_alias(loop core_type, string)
+      | Ptyp_variant(row_field_list, flag, lbl_lst_option) ->
+          Ptyp_variant(List.map loop_row_field row_field_list,
+                       flag, lbl_lst_option)
+      | Ptyp_poly(string_lst, core_type) ->
+          List.iter (check_variable var_names t.ptyp_loc) string_lst;
+          Ptyp_poly(string_lst, loop core_type)
+      | Ptyp_package(longident,lst) ->
+          Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
+      | Ptyp_extension (s, arg) ->
+          Ptyp_extension (s, arg)
+    in
+    {t with ptyp_desc = desc}
+  and loop_row_field  =
+    function
+      | Rtag(label,attrs,flag,lst) ->
+          Rtag(label,attrs,flag,List.map loop lst)
+      | Rinherit t ->
+          Rinherit (loop t)
+  in
+  loop t
+
+let mk_newtypes newtypes exp =
+  List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp)))
+    newtypes exp
+
+let wrap_type_annotation newtypes core_type body =
+  let exp = mkexp(Pexp_constraint(body,core_type)) in
+  let exp = mk_newtypes newtypes exp in
+  (exp, ghtyp(Ptyp_poly(newtypes,varify_constructors newtypes core_type)))
+
+let wrap_exp_attrs body (ext, attrs) =
+  (* 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 d attrs =
+  wrap_exp_attrs (mkexp d) attrs
+
+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))]
+
+let extra_text text pos items =
+  let pre_extras = rhs_pre_extra_text pos in
+  let post_extras = rhs_post_extra_text pos in
+    text pre_extras @ items @ text post_extras
+
+let extra_str pos items = extra_text Str.text pos items
+let extra_sig pos items = extra_text Sig.text pos items
+let extra_cstr pos items = extra_text Cf.text pos items
+let extra_csig pos items = extra_text Ctf.text pos items
+let extra_def pos items =
+  extra_text (fun txt -> [Ptop_def (Str.text txt)]) pos items
+
+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_attributes: attributes;
+    lbs_loc: Location.t }
+
+let mklb (p, e) attrs =
+  { lb_pattern = p;
+    lb_expression = e;
+    lb_attributes = attrs;
+    lb_docs = symbol_docs_lazy ();
+    lb_text = symbol_text_lazy ();
+    lb_loc = symbol_rloc (); }
+
+let mklbs (ext, attrs) rf lb =
+  { lbs_bindings = [lb];
+    lbs_rec = rf;
+    lbs_extension = ext ;
+    lbs_attributes = attrs;
+    lbs_loc = symbol_rloc (); }
+
+let addlb lbs lb =
+  { lbs with lbs_bindings = lb :: lbs.lbs_bindings }
+
+let val_of_let_bindings lbs =
+  let str =
+    match lbs.lbs_bindings with
+    | [ {lb_pattern = { ppat_desc = Ppat_any; ppat_loc = _ }; _} as lb ] ->
+        let exp = wrap_exp_attrs lb.lb_expression
+                    (None, lbs.lbs_attributes) in
+        mkstr (Pstr_eval (exp, lb.lb_attributes))
+    | bindings ->
+        if lbs.lbs_attributes <> [] then
+          raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "attributes")));
+        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)
+            bindings
+        in
+        mkstr(Pstr_value(lbs.lbs_rec, List.rev bindings))
+  in
+  match lbs.lbs_extension with
+  | None -> str
+  | Some id -> ghstr (Pstr_extension((id, PStr [str]), []))
+
+let expr_of_let_bindings lbs body =
+  let bindings =
+    List.map
+      (fun lb ->
+         if lb.lb_attributes <> [] then
+           raise Syntaxerr.(Error(Not_expecting(lb.lb_loc, "item attribute")));
+         Vb.mk ~loc:lb.lb_loc lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+    mkexp_attrs (Pexp_let(lbs.lbs_rec, List.rev bindings, body))
+      (lbs.lbs_extension, lbs.lbs_attributes)
+
+let class_of_let_bindings lbs body =
+  let bindings =
+    List.map
+      (fun lb ->
+         if lb.lb_attributes <> [] then
+           raise Syntaxerr.(Error(Not_expecting(lb.lb_loc, "item attribute")));
+         Vb.mk ~loc:lb.lb_loc lb.lb_pattern lb.lb_expression)
+      lbs.lbs_bindings
+  in
+    if lbs.lbs_extension <> None then
+      raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "extension")));
+    if lbs.lbs_attributes <> [] then
+      raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "attributes")));
+    mkclass(Pcl_let (lbs.lbs_rec, List.rev bindings, body))
+
 %}
 
 /* Tokens */
@@ -193,6 +408,7 @@ let bigarray_set arr arg newval =
 %token AS
 %token ASSERT
 %token BACKQUOTE
+%token BANG
 %token BAR
 %token BARBAR
 %token BARRBRACKET
@@ -246,11 +462,16 @@ let bigarray_set arr arg newval =
 %token LBRACKETBAR
 %token LBRACKETLESS
 %token LBRACKETGREATER
+%token LBRACKETPERCENT
+%token LBRACKETPERCENTPERCENT
 %token LESS
 %token LESSMINUS
 %token LET
 %token <string> LIDENT
 %token LPAREN
+%token LBRACKETAT
+%token LBRACKETATAT
+%token LBRACKETATATAT
 %token MATCH
 %token METHOD
 %token MINUS
@@ -260,17 +481,20 @@ let bigarray_set arr arg newval =
 %token MUTABLE
 %token <nativeint> NATIVEINT
 %token NEW
+%token NONREC
 %token OBJECT
 %token OF
 %token OPEN
 %token <string> OPTLABEL
 %token OR
 /* %token PARSER */
+%token PERCENT
 %token PLUS
+%token PLUSDOT
+%token PLUSEQ
 %token <string> PREFIXOP
 %token PRIVATE
 %token QUESTION
-%token QUESTIONQUESTION
 %token QUOTE
 %token RBRACE
 %token RBRACKET
@@ -279,9 +503,10 @@ let bigarray_set arr arg newval =
 %token SEMI
 %token SEMISEMI
 %token SHARP
+%token <string> SHARPOP
 %token SIG
 %token STAR
-%token <string> STRING
+%token <string * string option> STRING
 %token STRUCT
 %token THEN
 %token TILDE
@@ -296,6 +521,10 @@ let bigarray_set arr arg newval =
 %token WHEN
 %token WHILE
 %token WITH
+%token <string * Location.t> COMMENT
+%token <Docstrings.docstring> DOCSTRING
+
+%token EOL
 
 /* Precedences and associativities.
 
@@ -341,21 +570,26 @@ The precedences must be listed from low to high.
 %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
+%nonassoc LBRACKETATAT
 %right    COLONCOLON                    /* expr (e :: e :: e) */
-%left     INFIXOP2 PLUS MINUS MINUSDOT  /* expr (e OP e OP e) */
-%left     INFIXOP3 STAR                 /* expr (e OP e OP 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              /* unary - */
+%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_SHARP
 %nonassoc SHARP                         /* simple_expr/toplevel_directive */
+%left     SHARPOP
 %nonassoc below_DOT
 %nonassoc DOT
 /* Finally, the first tokens of simple_expr are above everything else. */
-%nonassoc BACKQUOTE BEGIN CHAR FALSE FLOAT INT INT32 INT64
+%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT INT32 INT64
           LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN
           NEW NATIVEINT PREFIXOP STRING TRUE UIDENT
+          LBRACKETPERCENT LBRACKETPERCENTPERCENT
 
 
 /* Entry points */
@@ -368,54 +602,109 @@ The precedences must be listed from low to high.
 %type <Parsetree.toplevel_phrase> toplevel_phrase
 %start use_file                         /* for the #use directive */
 %type <Parsetree.toplevel_phrase list> use_file
-
+%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
 %%
 
 /* Entry points */
 
 implementation:
-    structure EOF                        { $1 }
+    structure EOF                        { extra_str 1 $1 }
 ;
 interface:
-    signature EOF                        { List.rev $1 }
+    signature EOF                        { extra_sig 1 $1 }
 ;
 toplevel_phrase:
-    top_structure SEMISEMI               { Ptop_def $1 }
-  | seq_expr SEMISEMI                    { Ptop_def[ghstrexp $1] }
+    top_structure SEMISEMI               { Ptop_def (extra_str 1 $1) }
   | toplevel_directive SEMISEMI          { $1 }
   | EOF                                  { raise End_of_file }
 ;
 top_structure:
-    structure_item                       { [$1] }
-  | structure_item top_structure         { $1 :: $2 }
+    seq_expr post_item_attributes
+      { (text_str 1) @ [mkstrexp $1 $2] }
+  | top_structure_tail
+      { $1 }
+;
+top_structure_tail:
+    /* empty */                          { [] }
+  | structure_item top_structure_tail    { (text_str 1) @ $1 :: $2 }
 ;
 use_file:
+    use_file_body                        { extra_def 1 $1 }
+;
+use_file_body:
     use_file_tail                        { $1 }
-  | seq_expr use_file_tail               { Ptop_def[ghstrexp $1] :: $2 }
+  | seq_expr post_item_attributes use_file_tail
+      { (text_def 1) @ Ptop_def[mkstrexp $1 $2] :: $3 }
 ;