Added parsing for OBJECT class_structure END expressions

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@6311 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
2004-05-19 15:00:47 +00:00 · 2004-05-19 15:00:47 +00:00 · 76c5955b80
parent ea4d1da556
commit 76c5955b80
11 changed files with 172 additions and 8 deletions
--- a/camlp4/camlp4/ast2pt.ml
+++ b/camlp4/camlp4/ast2pt.ml
@ -639,6 +639,14 @@ value rec expr =
  | ExLmd loc i me e -> mkexp loc (Pexp_letmodule i (module_expr me) (expr e))
  | ExMat loc e pel -> mkexp loc (Pexp_match (expr e) (List.map mkpwe pel))
  | ExNew loc id -> mkexp loc (Pexp_new (long_id_of_string_list loc id))
+  | ExObj loc po cfl -> 
+      let p =
+        match po with
+        [ Some p -> p
+        | None -> PaAny loc ]
+      in
+      let cil = List.fold_right class_str_item cfl [] in
+      mkexp loc (Pexp_object (patt p, cil))
  | ExOlb loc _ _ -> error loc "labeled expression not allowed here"
  | ExOvr loc iel -> mkexp loc (Pexp_override (List.map mkideexp iel))
  | ExRec loc lel eo ->
--- a/camlp4/camlp4/mLast.mli
+++ b/camlp4/camlp4/mLast.mli
@ -104,6 +104,7 @@ and expr =
  | ExLmd of loc and string and module_expr and expr
  | ExMat of loc and expr and list (patt * option expr * expr)
  | ExNew of loc and list string
+  | ExObj of loc and option patt and list class_str_item
  | ExOlb of loc and string and option expr
  | ExOvr of loc and list (string * expr)
  | ExRec of loc and list (patt * expr) and option expr
--- a/camlp4/camlp4/reloc.ml
+++ b/camlp4/camlp4/reloc.ml
@ -224,6 +224,9 @@ and expr floc sh =
                (patt floc sh x1, option_map self x2, self x3))
             x2)
    | ExNew loc x1 -> let nloc = floc loc in ExNew nloc x1
+    | ExObj loc x1 x2 ->
+        let nloc = floc loc in ExObj nloc (option_map (patt floc sh) x1)
+          (List.map (class_str_item floc sh) x2)
    | ExOlb loc x1 x2 -> let nloc = floc loc in ExOlb nloc x1 (option_map self x2)
    | ExOvr loc x1 ->
        let nloc = floc loc in
--- a/camlp4/etc/pa_o.ml
+++ b/camlp4/etc/pa_o.ml
@ -569,7 +569,10 @@ EXTEND
        "do"; e = SELF; "done" ->
          <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:get_seq e$ } >>
      | "while"; e1 = SELF; "do"; e2 = SELF; "done" ->
-          <:expr< while $e1$ do { $list:get_seq e2$ } >> ]
+          <:expr< while $e1$ do { $list:get_seq e2$ } >>
+      | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" ->
+          (* <:expr< object $opt:cspo$ $list:cf$ end >> *)
+          MLast.ExObj loc cspo cf ]
    | [ e = SELF; ","; el = LIST1 NEXT SEP "," ->
          <:expr< ( $list:[e :: el]$ ) >> ]
    | ":=" NONA
--- a/camlp4/meta/pa_r.ml
+++ b/camlp4/meta/pa_r.ml
@ -323,7 +323,10 @@ EXTEND
        "do"; "{"; seq = sequence; "}" ->
          <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:seq$ } >>
      | "while"; e = SELF; "do"; "{"; seq = sequence; "}" ->
-          <:expr< while $e$ do { $list:seq$ } >> ]
+          <:expr< while $e$ do { $list:seq$ } >>
+      | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" ->
+          (* <:expr< object $opt:cspo$ $list:cf$ end >> *)
+          MLast.ExObj loc cspo cf ]
    | "where"
      [ e = SELF; "where"; rf = OPT "rec"; lb = let_binding ->
          <:expr< let $opt:o2b rf$ $list:[lb]$ in $e$ >> ]
@ -392,9 +395,8 @@ EXTEND
          mklistexp loc last el
      | "[|"; el = LIST0 expr SEP ";"; "|]" -> <:expr< [| $list:el$ |] >>
      | "{"; lel = LIST1 label_expr SEP ";"; "}" -> <:expr< { $list:lel$ } >>
-      | "{"; "("; e = SELF; ")"; "with"; lel = LIST1 label_expr SEP ";";
-        "}" ->
-          <:expr< { ($e$) with $list:lel$ } >>
+      | "{"; "("; e = SELF; ")"; "with"; lel = LIST1 label_expr SEP ";"; "}"
+        -> <:expr< { ($e$) with $list:lel$ } >>
      | "("; ")" -> <:expr< () >>
      | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >>
      | "("; e = SELF; ","; el = LIST1 expr SEP ","; ")" ->
--- a/camlp4/meta/q_MLast.ml
+++ b/camlp4/meta/q_MLast.ml
@ -126,6 +126,9 @@ value a_opt = Grammar.Entry.create gram "a_opt";
 value a_UIDENT = Grammar.Entry.create gram "a_UIDENT";
 value a_LIDENT = Grammar.Entry.create gram "a_LIDENT";
 value a_INT = Grammar.Entry.create gram "a_INT";
+value a_INT32 = Grammar.Entry.create gram "a_INT32";
+value a_INT64 = Grammar.Entry.create gram "a_INT64";
+value a_NATIVEINT = Grammar.Entry.create gram "a__NATIVEINT";
 value a_FLOAT = Grammar.Entry.create gram "a_FLOAT";
 value a_STRING = Grammar.Entry.create gram "a_STRING";
 value a_CHAR = Grammar.Entry.create gram "a_CHAR";
@ -626,6 +629,9 @@ EXTEND
            [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "~-."]; e] ]
    | "simple"
      [ s = a_INT -> Qast.Node "ExInt" [Qast.Loc; s]
+      | s = a_INT32 -> Qast.Node  "ExInt32" [Qast.Loc; s]
+      | s = a_INT64 -> Qast.Node  "ExInt64" [Qast.Loc; s]
+      | s = a_NATIVEINT -> Qast.Node  "ExNativeInt" [Qast.Loc; s]
      | s = a_FLOAT -> Qast.Node "ExFlo" [Qast.Loc; s]
      | s = a_STRING -> Qast.Node "ExStr" [Qast.Loc; s]
      | s = a_CHAR -> Qast.Node "ExChr" [Qast.Loc; s]
@ -715,10 +721,16 @@ EXTEND
      [ s = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; s]
      | s = a_UIDENT -> Qast.Node "PaUid" [Qast.Loc; s]
      | s = a_INT -> Qast.Node "PaInt" [Qast.Loc; s]
+      | s = a_INT32 -> Qast.Node  "PaInt32" [Qast.Loc; s]
+      | s = a_INT64 -> Qast.Node  "PaInt64" [Qast.Loc; s]
+      | s = a_NATIVEINT -> Qast.Node  "PaNativeInt" [Qast.Loc; s]
      | s = a_FLOAT -> Qast.Node "PaFlo" [Qast.Loc; s]
      | s = a_STRING -> Qast.Node "PaStr" [Qast.Loc; s]
      | s = a_CHAR -> Qast.Node "PaChr" [Qast.Loc; s]
      | "-"; s = a_INT -> mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool True) s
+      | "-"; s = a_INT32 -> mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool True) s
+      | "-"; s = a_INT64 -> mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool True) s
+      | "-"; s = a_NATIVEINT -> mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool True) s
      | "-"; s = a_FLOAT ->
          mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool False) s
      | "["; "]" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "[]"]
@ -1335,6 +1347,21 @@ EXTEND
      | a = ANTIQUOT -> antiquot "" loc a
      | s = INT -> Qast.Str s ] ]
  ;
+  a_INT32:
+    [ [ a = ANTIQUOT "int32" -> antiquot "int32" loc a
+      | a = ANTIQUOT -> antiquot "" loc a
+      | s = INT32 -> Qast.Str s ] ]
+  ;
+  a_INT64:
+    [ [ a = ANTIQUOT "int64" -> antiquot "int64" loc a
+      | a = ANTIQUOT -> antiquot "" loc a
+      | s = INT64 -> Qast.Str s ] ]
+  ;
+  a_NATIVEINT:
+    [ [ a = ANTIQUOT "nativeint" -> antiquot "nativeint" loc a
+      | a = ANTIQUOT -> antiquot "" loc a
+      | s = NATIVEINT -> Qast.Str s ] ]
+  ;
  a_FLOAT:
    [ [ a = ANTIQUOT "flo" -> antiquot "flo" loc a
      | a = ANTIQUOT -> antiquot "" loc a
--- a/camlp4/ocaml_src/camlp4/ast2pt.ml
+++ b/camlp4/ocaml_src/camlp4/ast2pt.ml
@ -640,6 +640,14 @@ let rec expr =
      mkexp loc (Pexp_letmodule (i, module_expr me, expr e))
  | ExMat (loc, e, pel) -> mkexp loc (Pexp_match (expr e, List.map mkpwe pel))
  | ExNew (loc, id) -> mkexp loc (Pexp_new (long_id_of_string_list loc id))
+  | ExObj (loc, po, cfl) ->
+      let p =
+        match po with
+          Some p -> p
+        | None -> PaAny loc
+      in
+      let cil = List.fold_right class_str_item cfl [] in
+      mkexp loc (Pexp_object (patt p, cil))
  | ExOlb (loc, _, _) -> error loc "labeled expression not allowed here"
  | ExOvr (loc, iel) -> mkexp loc (Pexp_override (List.map mkideexp iel))
  | ExRec (loc, lel, eo) ->
--- a/camlp4/ocaml_src/camlp4/mLast.mli
+++ b/camlp4/ocaml_src/camlp4/mLast.mli
@ -104,6 +104,7 @@ and expr =
  | ExLmd of loc * string * module_expr * expr
  | ExMat of loc * expr * (patt * expr option * expr) list
  | ExNew of loc * string list
+  | ExObj of loc * patt option * class_str_item list
  | ExOlb of loc * string * expr option
  | ExOvr of loc * (string * expr) list
  | ExRec of loc * (patt * expr) list * expr option
--- a/camlp4/ocaml_src/camlp4/reloc.ml
+++ b/camlp4/ocaml_src/camlp4/reloc.ml
@ -239,6 +239,11 @@ and expr floc sh =
                patt floc sh x1, option_map self x2, self x3)
             x2)
    | ExNew (loc, x1) -> let nloc = floc loc in ExNew (nloc, x1)
+    | ExObj (loc, x1, x2) ->
+        let nloc = floc loc in
+        ExObj
+          (nloc, option_map (patt floc sh) x1,
+           List.map (class_str_item floc sh) x2)
    | ExOlb (loc, x1, x2) ->
        let nloc = floc loc in ExOlb (nloc, x1, option_map self x2)
    | ExOvr (loc, x1) ->
--- a/camlp4/ocaml_src/meta/pa_r.ml
+++ b/camlp4/ocaml_src/meta/pa_r.ml
@ -722,7 +722,20 @@ Grammar.extend
           (MLast.WcTyp (loc, i, tpl, t) : 'with_constr))]];
    Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), None,
    [Some "top", Some Gramext.RightA,
-     [[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do");
+     [[Gramext.Stoken ("", "object");
+       Gramext.Sopt
+         (Gramext.Snterm
+            (Grammar.Entry.obj
+               (class_self_patt : 'class_self_patt Grammar.Entry.e)));
+       Gramext.Snterm
+         (Grammar.Entry.obj
+            (class_structure : 'class_structure Grammar.Entry.e));
+       Gramext.Stoken ("", "end")],
+      Gramext.action
+        (fun _ (cf : 'class_structure) (cspo : 'class_self_patt option) _
+           (loc : Lexing.position * Lexing.position) ->
+           (MLast.ExObj (loc, cspo, cf) : 'expr));
+      [Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do");
       Gramext.Stoken ("", "{");
       Gramext.Snterm
         (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e));
--- a/camlp4/ocaml_src/meta/q_MLast.ml
+++ b/camlp4/ocaml_src/meta/q_MLast.ml
@ -158,6 +158,9 @@ let a_opt = Grammar.Entry.create gram "a_opt";;
 let a_UIDENT = Grammar.Entry.create gram "a_UIDENT";;
 let a_LIDENT = Grammar.Entry.create gram "a_LIDENT";;
 let a_INT = Grammar.Entry.create gram "a_INT";;
+let a_INT32 = Grammar.Entry.create gram "a_INT32";;
+let a_INT64 = Grammar.Entry.create gram "a_INT64";;
+let a_NATIVEINT = Grammar.Entry.create gram "a__NATIVEINT";;
 let a_FLOAT = Grammar.Entry.create gram "a_FLOAT";;
 let a_STRING = Grammar.Entry.create gram "a_STRING";;
 let a_CHAR = Grammar.Entry.create gram "a_CHAR";;
@ -656,7 +659,7 @@ Grammar.extend
           (let (_, c, tl) =
              match ctl with
                Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3
-              | _ -> match () with _ -> raise (Match_failure ("", 305, 19))
+              | _ -> match () with _ -> raise (Match_failure ("", 308, 19))
            in
            Qast.Node ("StExc", [Qast.Loc; c; tl; b]) :
            'str_item));
@ -950,7 +953,7 @@ Grammar.extend
           (let (_, c, tl) =
              match ctl with
                Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3
-              | _ -> match () with _ -> raise (Match_failure ("", 363, 19))
+              | _ -> match () with _ -> raise (Match_failure ("", 366, 19))
            in
            Qast.Node ("SgExc", [Qast.Loc; c; tl]) :
            'sig_item));
@ -1838,6 +1841,21 @@ Grammar.extend
      Gramext.action
        (fun (s : 'a_FLOAT) (loc : Lexing.position * Lexing.position) ->
           (Qast.Node ("ExFlo", [Qast.Loc; s]) : 'expr));
+      [Gramext.Snterm
+         (Grammar.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Grammar.Entry.e))],
+      Gramext.action
+        (fun (s : 'a_NATIVEINT) (loc : Lexing.position * Lexing.position) ->
+           (Qast.Node ("ExNativeInt", [Qast.Loc; s]) : 'expr));
+      [Gramext.Snterm
+         (Grammar.Entry.obj (a_INT64 : 'a_INT64 Grammar.Entry.e))],
+      Gramext.action
+        (fun (s : 'a_INT64) (loc : Lexing.position * Lexing.position) ->
+           (Qast.Node ("ExInt64", [Qast.Loc; s]) : 'expr));
+      [Gramext.Snterm
+         (Grammar.Entry.obj (a_INT32 : 'a_INT32 Grammar.Entry.e))],
+      Gramext.action
+        (fun (s : 'a_INT32) (loc : Lexing.position * Lexing.position) ->
+           (Qast.Node ("ExInt32", [Qast.Loc; s]) : 'expr));
      [Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))],
      Gramext.action
        (fun (s : 'a_INT) (loc : Lexing.position * Lexing.position) ->
@ -2178,6 +2196,24 @@ Grammar.extend
      Gramext.action
        (fun (s : 'a_FLOAT) _ (loc : Lexing.position * Lexing.position) ->
           (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool false) s : 'patt));
+      [Gramext.Stoken ("", "-");
+       Gramext.Snterm
+         (Grammar.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Grammar.Entry.e))],
+      Gramext.action
+        (fun (s : 'a_NATIVEINT) _ (loc : Lexing.position * Lexing.position) ->
+           (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) s : 'patt));
+      [Gramext.Stoken ("", "-");
+       Gramext.Snterm
+         (Grammar.Entry.obj (a_INT64 : 'a_INT64 Grammar.Entry.e))],
+      Gramext.action
+        (fun (s : 'a_INT64) _ (loc : Lexing.position * Lexing.position) ->
+           (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) s : 'patt));
+      [Gramext.Stoken ("", "-");
+       Gramext.Snterm
+         (Grammar.Entry.obj (a_INT32 : 'a_INT32 Grammar.Entry.e))],
+      Gramext.action
+        (fun (s : 'a_INT32) _ (loc : Lexing.position * Lexing.position) ->
+           (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) s : 'patt));
      [Gramext.Stoken ("", "-");
       Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))],
      Gramext.action
@ -2197,6 +2233,21 @@ Grammar.extend
      Gramext.action
        (fun (s : 'a_FLOAT) (loc : Lexing.position * Lexing.position) ->
           (Qast.Node ("PaFlo", [Qast.Loc; s]) : 'patt));
+      [Gramext.Snterm
+         (Grammar.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Grammar.Entry.e))],
+      Gramext.action
+        (fun (s : 'a_NATIVEINT) (loc : Lexing.position * Lexing.position) ->
+           (Qast.Node ("PaNativeInt", [Qast.Loc; s]) : 'patt));
+      [Gramext.Snterm
+         (Grammar.Entry.obj (a_INT64 : 'a_INT64 Grammar.Entry.e))],
+      Gramext.action
+        (fun (s : 'a_INT64) (loc : Lexing.position * Lexing.position) ->
+           (Qast.Node ("PaInt64", [Qast.Loc; s]) : 'patt));
+      [Gramext.Snterm
+         (Grammar.Entry.obj (a_INT32 : 'a_INT32 Grammar.Entry.e))],
+      Gramext.action
+        (fun (s : 'a_INT32) (loc : Lexing.position * Lexing.position) ->
+           (Qast.Node ("PaInt32", [Qast.Loc; s]) : 'patt));
      [Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))],
      Gramext.action
        (fun (s : 'a_INT) (loc : Lexing.position * Lexing.position) ->
@ -4917,6 +4968,48 @@ Grammar.extend
     Gramext.action
       (fun (a : string) (loc : Lexing.position * Lexing.position) ->
          (antiquot "int" loc a : 'a_INT))]];
+   Grammar.Entry.obj (a_INT32 : 'a_INT32 Grammar.Entry.e), None,
+   [None, None,
+    [[Gramext.Stoken ("INT32", "")],
+     Gramext.action
+       (fun (s : string) (loc : Lexing.position * Lexing.position) ->
+          (Qast.Str s : 'a_INT32));
+     [Gramext.Stoken ("ANTIQUOT", "")],
+     Gramext.action
+       (fun (a : string) (loc : Lexing.position * Lexing.position) ->
+          (antiquot "" loc a : 'a_INT32));
+     [Gramext.Stoken ("ANTIQUOT", "int32")],
+     Gramext.action
+       (fun (a : string) (loc : Lexing.position * Lexing.position) ->
+          (antiquot "int32" loc a : 'a_INT32))]];
+   Grammar.Entry.obj (a_INT64 : 'a_INT64 Grammar.Entry.e), None,
+   [None, None,
+    [[Gramext.Stoken ("INT64", "")],
+     Gramext.action
+       (fun (s : string) (loc : Lexing.position * Lexing.position) ->
+          (Qast.Str s : 'a_INT64));
+     [Gramext.Stoken ("ANTIQUOT", "")],
+     Gramext.action
+       (fun (a : string) (loc : Lexing.position * Lexing.position) ->
+          (antiquot "" loc a : 'a_INT64));
+     [Gramext.Stoken ("ANTIQUOT", "int64")],
+     Gramext.action
+       (fun (a : string) (loc : Lexing.position * Lexing.position) ->
+          (antiquot "int64" loc a : 'a_INT64))]];
+   Grammar.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Grammar.Entry.e), None,
+   [None, None,
+    [[Gramext.Stoken ("NATIVEINT", "")],
+     Gramext.action
+       (fun (s : string) (loc : Lexing.position * Lexing.position) ->
+          (Qast.Str s : 'a_NATIVEINT));
+     [Gramext.Stoken ("ANTIQUOT", "")],
+     Gramext.action
+       (fun (a : string) (loc : Lexing.position * Lexing.position) ->
+          (antiquot "" loc a : 'a_NATIVEINT));
+     [Gramext.Stoken ("ANTIQUOT", "nativeint")],
+     Gramext.action
+       (fun (a : string) (loc : Lexing.position * Lexing.position) ->
+          (antiquot "nativeint" loc a : 'a_NATIVEINT))]];
   Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e), None,
   [None, None,
    [[Gramext.Stoken ("FLOAT", "")],