-

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@4318 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

camlp4/CHANGES

@@ -1,6 +1,8 @@
 Camlp4 Version 3.04+1
 ---------------------
 
+- [26 Jan 02] The printer pr_extend.cmo try now also to rebuild GEXTEND
+  statements (before it tried only the EXTEND).
 - [23 Jan 02] The empty functional stream "fstream [: :]" is now of type
   'a Fstream.t thanks to the new implementation of lazies allowing to
   create polymorphic lazy values.

camlp4/etc/pr_extend.ml

@@ -53,9 +53,11 @@ value rec listwbws elem b sep el dg k =
 
 value rec get_globals =
   fun
-  [ [(<:patt< _ >>, <:expr< ($e$ : Grammar.Entry.e '$_$) >>) :: pel] ->
-      [e :: get_globals pel]
-  | [] -> []
+  [ [(<:patt< _ >>, <:expr< ($e$ : $uid:gmod1$.Entry.e '$_$) >>) :: pel] ->
+      let (gmod, gl) = get_globals pel in
+      if gmod = "" || gmod = gmod1 then (gmod1, [e :: gl])
+      else raise Not_found
+  | [] -> ("", [])
   | _ -> raise Not_found ]
 ;
 
@@ -135,10 +137,10 @@ type symbol =
 
 value rec unsymbol =
   fun
-  [ <:expr< Gramext.Snterm (Grammar.Entry.obj ($e$ : $_$)) >> -> Snterm e
-  | <:expr< Gramext.Snterml (Grammar.Entry.obj ($e$ : $_$)) $str:s$ >> ->
+  [ <:expr< Gramext.Snterm ($uid:_$.Entry.obj ($e$ : $_$)) >> -> Snterm e
+  | <:expr< Gramext.Snterml ($uid:_$.Entry.obj ($e$ : $_$)) $str:s$ >> ->
       Snterml e s
-  | <:expr< Gramext.Snterml (Grammar.Entry.obj ($e$ : $_$), $str:s$) >> ->
+  | <:expr< Gramext.Snterml ($uid:_$.Entry.obj ($e$ : $_$), $str:s$) >> ->
       Snterml e s
   | <:expr< Gramext.Slist0 $e$ >> -> Slist0 (unsymbol e)
   | <:expr< Gramext.Slist0sep $e1$ $e2$ >> ->
@@ -214,12 +216,12 @@ value rec unentry_list =
 ;
 
 value unextend_body e =
-  let (globals, e) =
+  let ((_, globals), e) =
     match e with
     [ <:expr< let $list:pel$ in $e1$ >> ->
         try (get_globals pel, e1) with
-        [ Not_found -> ([], e) ]
-    | _ -> ([], e) ]
+        [ Not_found -> (("", []), e) ]
+    | _ -> (("", []), e) ]
   in
   let e =
     match e with
@@ -242,6 +244,27 @@ value unextend_body e =
   (globals, el)
 ;
 
+value ungextend_body e =
+  let e =
+    match e with
+    [ <:expr<
+        let grammar_entry_create = Gram.Entry.create in
+        let $list:ll$ in $e$
+      >> ->
+        let _ = get_locals ll in e
+    | _ -> e ]
+  in
+  match e with
+  [ <:expr< do { $list:el$ } >> ->
+      List.map
+        (fun
+         [ <:expr< $uid:_$.extend ($e$ : $uid:_$.Entry.e '$_$) $pos$ $ll$ >> ->
+             (e, unposition pos, unlevel_list ll)
+         | _ -> raise Not_found ])
+        el
+  | _ -> raise Not_found ]
+;
+
 (* Printing *)
 
 value ident s k = HVbox [: `S LR s; k :];
@@ -302,7 +325,7 @@ value rec symbol s k =
       [([(Some <:patt< a >>, Snterm <:expr< a_list >>)], Some <:expr< a >>);
        ([(Some <:patt< a >>,
           ((Slist0 _ | Slist1 _ | Slist0sep _ _ | Slist1sep _ _) as s))],
-          Some <:expr< List a >>)]
+          Some <:expr< Qast.List a >>)]
     when not no_slist.val
     ->
       match s with
@@ -319,7 +342,7 @@ value rec symbol s k =
       | _ -> assert False ]
   | Srules
       [([(Some <:patt< a >>, Snterm <:expr< a_opt >>)], Some <:expr< a >>);
-       ([(Some <:patt< a >>, Sopt s)], Some <:expr< Option a >>)]
+       ([(Some <:patt< a >>, Sopt s)], Some <:expr< Qast.Option a >>)]
     when not no_slist.val
     ->
       HVbox [: `S LR "SOPT"; `simple_symbol s k :]
@@ -386,7 +409,7 @@ value level_list ll k =
          [: `S LR "]"; k :] :]
 ;
 
-value entry  (e, pos, ll) k =
+value entry (e, pos, ll) k =
   BEbox
     [: `HVbox [: `expr e "" [: `S RO ":" :]; position pos :];
        `level_list  ll [: :];
@@ -429,8 +452,41 @@ value extend e dg k =
   | _ -> expr e "" k ]
 ;
 
+value get_gextend =
+  fun
+  [ <:expr< let $list:gl$ in $e$ >> ->
+      try
+        let (gmod, gl) = get_globals gl in
+        let el = ungextend_body e in
+        Some (gmod, gl, el)
+      with
+      [ Not_found -> None ]
+  | _ -> None ]
+;
+
+value gextend e dg k =
+  match get_gextend e with
+  [ Some (gmod, gl, el) ->
+      BEbox
+        [: `HVbox [: `S LR "GEXTEND"; `S LR gmod :];
+           `extend_body (gl, el) [: :];
+           `HVbox [: `S LR "END"; k :] :]
+  | None -> expr e "" k ]
+;
+
+value is_gextend e = get_gextend e <> None;
+
 (* Printer extensions *)
 
+let lev =
+  try find_pr_level "expr1" pr_expr.pr_levels with
+  [ Failure _ -> find_pr_level "top" pr_expr.pr_levels ]
+in
+lev.pr_rules :=
+  extfun lev.pr_rules with
+  [ <:expr< let $list:_$ in $_$ >> as e when is_gextend e ->
+      fun curr next _ k -> [: `next e "" k :] ];
+
 let lev = find_pr_level "apply" pr_expr.pr_levels in
 lev.pr_rules :=
   extfun lev.pr_rules with
@@ -441,7 +497,9 @@ let lev = find_pr_level "simple" pr_expr.pr_levels in
 lev.pr_rules :=
   extfun lev.pr_rules with
   [ <:expr< Grammar.extend $_$ >> as e ->
-      fun curr next _ k -> [: `extend e "" k :] ];
+      fun curr next _ k -> [: `extend e "" k :]
+  | <:expr< let $list:_$ in $_$ >> as e when is_gextend e ->
+      fun curr next _ k -> [: `gextend e "" k :] ];
 
 Pcaml.add_option "-no_slist" (Arg.Set no_slist)
   "    Don't reconstruct SLIST";

camlp4/etc/pr_r.ml

@@ -520,7 +520,7 @@ value rec sequence_loop =
            [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :];
          sequence_loop el :]
   | [(<:expr< let $rec:_$ $list:_$ in $_$ >> as e) :: el] ->
-      [: `HVbox [: `S LO "("; `expr e [: `S RO ")"; `S LR "in" :] :];
+      [: `HVbox [: `S LO "("; `expr e [: `S RO ");" :] :];
          sequence_loop el :]
   | [e] -> [: `expr e [: :] :]
   | [e :: el] -> [: `expr e [: `S RO ";" :]; sequence_loop el :]

camlp4/meta/pa_extend.ml

@@ -275,22 +275,24 @@ value rec expr_fa al =
 value rec quot_expr e =
   let loc = MLast.loc_of_expr e in
   match e with
-  [ <:expr< None >> -> <:expr< Option None >>
-  | <:expr< Some $e$ >> -> <:expr< Option (Some $quot_expr e$) >>
-  | <:expr< False >> -> <:expr< Bool False >>
-  | <:expr< True >> -> <:expr< Bool True >>
-  | <:expr< List $_$ >> -> e
-  | <:expr< Option $_$ >> -> e
-  | <:expr< Str $_$ >> -> e
-  | <:expr< [] >> -> <:expr< List [] >>
-  | <:expr< [$e$] >> -> <:expr< List [$quot_expr e$] >>
-  | <:expr< [$e1$ :: $e2$] >> -> <:expr< Cons $quot_expr e1$  $quot_expr e2$ >>
+  [ <:expr< None >> -> <:expr< Qast.Option None >>
+  | <:expr< Some $e$ >> -> <:expr< Qast.Option (Some $quot_expr e$) >>
+  | <:expr< False >> -> <:expr< Qast.Bool False >>
+  | <:expr< True >> -> <:expr< Qast.Bool True >>
+  | <:expr< Qast.List $_$ >> -> e
+  | <:expr< Qast.Option $_$ >> -> e
+  | <:expr< Qast.Str $_$ >> -> e
+  | <:expr< [] >> -> <:expr< Qast.List [] >>
+  | <:expr< [$e$] >> -> <:expr< Qast.List [$quot_expr e$] >>
+  | <:expr< [$e1$ :: $e2$] >> ->
+      <:expr< Qast.Cons $quot_expr e1$  $quot_expr e2$ >>
   | <:expr< $_$ $_$ >> ->
       let (f, al) = expr_fa [] e in
       let al = List.map quot_expr al in
       match f with
-      [ <:expr< $uid:c$ >> -> <:expr< Node $str:c$ $mklistexp loc al$ >>
-      | <:expr< $_$.$uid:c$ >> -> <:expr< Node $str:c$ $mklistexp loc al$ >>
+      [ <:expr< $uid:c$ >> -> <:expr< Qast.Node $str:c$ $mklistexp loc al$ >>
+      | <:expr< $_$.$uid:c$ >> ->
+          <:expr< Qast.Node $str:c$ $mklistexp loc al$ >>
       | _ -> e ]
   | <:expr< {$list:pel$} >> ->
       try
@@ -306,14 +308,15 @@ value rec quot_expr e =
                <:expr< ($lab$, $quot_expr e$) >>)
             pel
         in
-        <:expr< Record $mklistexp loc lel$>>
+        <:expr< Qast.Record $mklistexp loc lel$>>
       with
       [ Not_found -> e ]
-  | <:expr< $lid:s$ >> -> if s = Stdpp.loc_name.val then <:expr< Loc >> else e
-  | <:expr< $str:s$ >> -> <:expr< Str $str:s$ >>
+  | <:expr< $lid:s$ >> ->
+      if s = Stdpp.loc_name.val then <:expr< Qast.Loc >> else e
+  | <:expr< $str:s$ >> -> <:expr< Qast.Str $str:s$ >>
   | <:expr< ($list:el$) >> ->
       let el = List.map quot_expr el in
-      <:expr< Tuple $mklistexp loc el$ >>
+      <:expr< Qast.Tuple $mklistexp loc el$ >>
   | _ -> e ]
 ;
 
@@ -350,7 +353,7 @@ value quotify_action psl act =
            <:expr<
               let ($list:pl$) =
                 match $lid:pname$ with
-                [ Tuple $mklistpat loc pl1$ -> ($list:el1$)
+                [ Qast.Tuple $mklistpat loc pl1$ -> ($list:el1$)
                 | _ -> match () with [] ]
               in $e$ >>
        | _ -> e ])
@@ -513,12 +516,12 @@ value sslist_aux loc min sep s =
         let patt = <:patt< a >> in
         {pattern = Some patt; symbol = symb}
       in
-      let act = <:expr< List a >> in
+      let act = <:expr< Qast.List a >> in
       {prod = [psymb]; action = Some act}
     in
     [r1; r2]
   in
-  TXrules loc (srules loc "anti" rl "")
+  TXrules loc (srules loc "a_list" rl "")
 ;
 
 value sslist loc min sep s =
@@ -550,12 +553,12 @@ value ssopt loc s =
         let patt = <:patt< a >> in
         {pattern = Some patt; symbol = symb}
       in
-      let act = <:expr< Option a >> in
+      let act = <:expr< Qast.Option a >> in
       {prod = [psymb]; action = Some act}
     in
     [r1; r2]
   in
-  TXrules loc (srules loc "anti" rl "")
+  TXrules loc (srules loc "a_opt" rl "")
 ;
 
 value is_global e =

camlp4/meta/pa_extend_m.ml

@@ -26,9 +26,9 @@ EXTEND
           in
           let used = [mk_name loc <:expr< a_list >> :: used] in
           {used = used; text = sslist loc min sep s;
-           styp = STlid loc "ast"}
+           styp = STquo loc "a_list"}
       | UIDENT "SOPT"; s = SELF ->
           let used = [mk_name loc <:expr< a_opt >> :: s.used] in
-          {used = used; text = ssopt loc s; styp = STlid loc "ast"} ] ]
+          {used = used; text = ssopt loc s; styp = STquo loc "a_opt"} ] ]
   ;
 END;

camlp4/ocaml_src/meta/pa_extend.ml

@@ -615,30 +615,63 @@ let rec quot_expr e =
   match e with
     MLast.ExUid (_, "None") ->
       MLast.ExApp
-        (loc, MLast.ExUid (loc, "Option"), MLast.ExUid (loc, "None"))
+        (loc,
+         MLast.ExAcc
+           (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")),
+         MLast.ExUid (loc, "None"))
   | MLast.ExApp (_, MLast.ExUid (_, "Some"), e) ->
       MLast.ExApp
-        (loc, MLast.ExUid (loc, "Option"),
+        (loc,
+         MLast.ExAcc
+           (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")),
          MLast.ExApp (loc, MLast.ExUid (loc, "Some"), quot_expr e))
   | MLast.ExUid (_, "False") ->
-      MLast.ExApp (loc, MLast.ExUid (loc, "Bool"), MLast.ExUid (loc, "False"))
+      MLast.ExApp
+        (loc,
+         MLast.ExAcc
+           (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Bool")),
+         MLast.ExUid (loc, "False"))
   | MLast.ExUid (_, "True") ->
-      MLast.ExApp (loc, MLast.ExUid (loc, "Bool"), MLast.ExUid (loc, "True"))
-  | MLast.ExApp (_, MLast.ExUid (_, "List"), _) -> e
-  | MLast.ExApp (_, MLast.ExUid (_, "Option"), _) -> e
-  | MLast.ExApp (_, MLast.ExUid (_, "Str"), _) -> e
+      MLast.ExApp
+        (loc,
+         MLast.ExAcc
+           (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Bool")),
+         MLast.ExUid (loc, "True"))
+  | MLast.ExApp
+      (_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "List")),
+       _) ->
+      e
+  | MLast.ExApp
+      (_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "Option")),
+       _) ->
+      e
+  | MLast.ExApp
+      (_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "Str")),
+       _) ->
+      e
   | MLast.ExUid (_, "[]") ->
-      MLast.ExApp (loc, MLast.ExUid (loc, "List"), MLast.ExUid (loc, "[]"))
+      MLast.ExApp
+        (loc,
+         MLast.ExAcc
+           (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")),
+         MLast.ExUid (loc, "[]"))
   | MLast.ExApp
       (_, MLast.ExApp (_, MLast.ExUid (_, "::"), e), MLast.ExUid (_, "[]")) ->
       MLast.ExApp
-        (loc, MLast.ExUid (loc, "List"),
+        (loc,
+         MLast.ExAcc
+           (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")),
          MLast.ExApp
            (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), quot_expr e),
             MLast.ExUid (loc, "[]")))
   | MLast.ExApp (_, MLast.ExApp (_, MLast.ExUid (_, "::"), e1), e2) ->
       MLast.ExApp
-        (loc, MLast.ExApp (loc, MLast.ExUid (loc, "Cons"), quot_expr e1),
+        (loc,
+         MLast.ExApp
+           (loc,
+            MLast.ExAcc
+              (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Cons")),
+            quot_expr e1),
          quot_expr e2)
   | MLast.ExApp (_, _, _) ->
       let (f, al) = expr_fa [] e in
@@ -648,13 +681,19 @@ let rec quot_expr e =
           MLast.ExApp
             (loc,
              MLast.ExApp
-               (loc, MLast.ExUid (loc, "Node"), MLast.ExStr (loc, c)),
+               (loc,
+                MLast.ExAcc
+                  (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
+                MLast.ExStr (loc, c)),
              mklistexp loc al)
       | MLast.ExAcc (_, _, MLast.ExUid (_, c)) ->
           MLast.ExApp
             (loc,
              MLast.ExApp
-               (loc, MLast.ExUid (loc, "Node"), MLast.ExStr (loc, c)),
+               (loc,
+                MLast.ExAcc
+                  (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
+                MLast.ExStr (loc, c)),
              mklistexp loc al)
       | _ -> e
       end
@@ -673,17 +712,31 @@ let rec quot_expr e =
                MLast.ExTup (loc, [lab; quot_expr e]))
             pel
         in
-        MLast.ExApp (loc, MLast.ExUid (loc, "Record"), mklistexp loc lel)
+        MLast.ExApp
+          (loc,
+           MLast.ExAcc
+             (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Record")),
+           mklistexp loc lel)
       with
         Not_found -> e
       end
   | MLast.ExLid (_, s) ->
-      if s = !(Stdpp.loc_name) then MLast.ExUid (loc, "Loc") else e
+      if s = !(Stdpp.loc_name) then
+        MLast.ExAcc (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Loc"))
+      else e
   | MLast.ExStr (_, s) ->
-      MLast.ExApp (loc, MLast.ExUid (loc, "Str"), MLast.ExStr (loc, s))
+      MLast.ExApp
+        (loc,
+         MLast.ExAcc
+           (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Str")),
+         MLast.ExStr (loc, s))
   | MLast.ExTup (_, el) ->
       let el = List.map quot_expr el in
-      MLast.ExApp (loc, MLast.ExUid (loc, "Tuple"), mklistexp loc el)
+      MLast.ExApp
+        (loc,
+         MLast.ExAcc
+           (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Tuple")),
+         mklistexp loc el)
   | _ -> e
 ;;
 
@@ -723,7 +776,11 @@ let quotify_action psl act =
                MLast.ExMat
                  (loc, MLast.ExLid (loc, pname),
                   [MLast.PaApp
-                     (loc, MLast.PaUid (loc, "Tuple"), mklistpat loc pl1),
+                     (loc,
+                      MLast.PaAcc
+                        (loc, MLast.PaUid (loc, "Qast"),
+                         MLast.PaUid (loc, "Tuple")),
+                      mklistpat loc pl1),
                    None, MLast.ExTup (loc, el1);
                    MLast.PaAny loc, None,
                    MLast.ExMat (loc, MLast.ExUid (loc, "()"), [])])],
@@ -1008,13 +1065,17 @@ let sslist_aux loc min sep s =
         {pattern = Some patt; symbol = symb}
       in
       let act =
-        MLast.ExApp (loc, MLast.ExUid (loc, "List"), MLast.ExLid (loc, "a"))
+        MLast.ExApp
+          (loc,
+           MLast.ExAcc
+             (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")),
+           MLast.ExLid (loc, "a"))
       in
       {prod = [psymb]; action = Some act}
     in
     [r1; r2]
   in
-  TXrules (loc, srules loc "anti" rl "")
+  TXrules (loc, srules loc "a_list" rl "")
 ;;
 
 let sslist loc min sep s =
@@ -1047,13 +1108,17 @@ let ssopt loc s =
         {pattern = Some patt; symbol = symb}
       in
       let act =
-        MLast.ExApp (loc, MLast.ExUid (loc, "Option"), MLast.ExLid (loc, "a"))
+        MLast.ExApp
+          (loc,
+           MLast.ExAcc
+             (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")),
+           MLast.ExLid (loc, "a"))
       in
       {prod = [psymb]; action = Some act}
     in
     [r1; r2]
   in
-  TXrules (loc, srules loc "anti" rl "")
+  TXrules (loc, srules loc "a_opt" rl "")
 ;;
 
 let is_global e =

camlp4/ocaml_src/meta/pa_extend_m.ml

@@ -22,7 +22,7 @@ Grammar.extend
      Gramext.action
        (fun (s : 'symbol) _ (loc : int * int) ->
           (let used = mk_name loc (MLast.ExLid (loc, "a_opt")) :: s.used in
-           {used = used; text = ssopt loc s; styp = STlid (loc, "ast")} :
+           {used = used; text = ssopt loc s; styp = STquo (loc, "a_opt")} :
            'symbol));
      [Gramext.srules
         [[Gramext.Stoken ("UIDENT", "SLIST1")],
@@ -47,5 +47,5 @@ Grammar.extend
            in
            let used = mk_name loc (MLast.ExLid (loc, "a_list")) :: used in
            {used = used; text = sslist loc min sep s;
-            styp = STlid (loc, "ast")} :
+            styp = STquo (loc, "a_list")} :
            'symbol))]]];;