Merge ocaml-jst

ocaml/lambda/translmod.ml

@@ -781,8 +781,19 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function
                 size
           in
           let body, size = rebind_idents 0 fields ids in
-          Llet(pure_module modl, Pgenval, mid,
-               transl_module ~scopes Tcoerce_none None modl, body),
+          let loc = of_location ~scopes incl.incl_loc in
+          let let_kind, modl =
+            match incl.incl_kind with
+            | Tincl_structure ->
+                pure_module modl, transl_module ~scopes Tcoerce_none None modl
+            | Tincl_functor ccs ->
+                Strict, transl_include_functor ~generative:false modl ccs
+                          scopes loc
+            | Tincl_gen_functor ccs ->
+                Strict, transl_include_functor ~generative:true modl ccs
+                          scopes loc
+          in
+          Llet(let_kind, Pgenval, mid, modl, body),
           size
 
       | Tstr_open od ->
@@ -819,6 +830,32 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function
       | Tstr_attribute _ ->
           transl_structure ~scopes loc fields cc rootpath final_env rem
 
+(* construct functor application in "include functor" case *)
+and transl_include_functor ~generative modl params scopes loc =
+  let inlined_attribute, modl =
+    Translattribute.get_and_remove_inlined_attribute_on_module modl
+  in
+  let modl = transl_module ~scopes Tcoerce_none None modl in
+  let params = if generative then [params;[]] else [params] in
+  let params = List.map (fun coercion ->
+    Lprim(Pmakeblock(0, Immutable, None, alloc_heap),
+          List.map (fun (name, cc) ->
+            apply_coercion loc Strict cc (Lvar name))
+            coercion,
+          loc))
+    params
+  in
+  Lapply {
+    ap_loc = loc;
+    ap_func = modl;
+    ap_args = params;
+    ap_region_close=Rc_normal;
+    ap_mode = alloc_heap;
+    ap_tailcall = Default_tailcall;
+    ap_inlined = inlined_attribute;
+    ap_specialised = Default_specialise;
+    ap_probe = None;}
+
 (* Update forward declaration in Translcore *)
 let _ =
   Translcore.transl_module := transl_module
@@ -1065,7 +1102,7 @@ let transl_store_structure ~scopes glob map prims aliases str =
             let lam =
               transl_let ~scopes ~in_structure:true rec_flag pat_expr_list
                  Pintval (* unit *)
-                (store_idents Loc_unknown ids)
+                 (store_idents Loc_unknown ids)
             in
             Lsequence(Lambda.subst no_env_update subst lam,
                       transl_store ~scopes rootpath
@@ -1276,24 +1313,30 @@ let transl_store_structure ~scopes glob map prims aliases str =
               | _ -> assert false
             in
             Lsequence(lam, loop ids0 map)
-
         | Tstr_include incl ->
             let ids = bound_value_identifiers incl.incl_type in
             let modl = incl.incl_mod in
             let mid = Ident.create_local "include" in
-            let loc = incl.incl_loc in
+            let loc = of_location ~scopes incl.incl_loc in
             let rec store_idents pos = function
               | [] -> transl_store
                         ~scopes rootpath (add_idents true ids subst) cont rem
               | id :: idl ->
                   Llet(Alias, Pgenval, id, Lprim(mod_field pos, [Lvar mid],
-                                                 of_location ~scopes loc),
-                       Lsequence(store_ident (of_location ~scopes loc) id,
+                                                 loc),
+                       Lsequence(store_ident loc id,
                                  store_idents (pos + 1) idl))
             in
+            let modl =
+              match incl.incl_kind with
+              | Tincl_structure -> transl_module ~scopes Tcoerce_none None modl
+              | Tincl_functor ccs ->
+                  transl_include_functor ~generative:false modl ccs scopes loc
+              | Tincl_gen_functor ccs ->
+                  transl_include_functor ~generative:true modl ccs scopes loc
+            in
             Llet(Strict, Pgenval, mid,
-                 Lambda.subst no_env_update subst
-                   (transl_module ~scopes Tcoerce_none None modl),
+                 Lambda.subst no_env_update subst modl,
                  store_idents 0 ids)
         | Tstr_open od ->
             begin match od.open_expr.mod_desc with
@@ -1620,7 +1663,17 @@ let transl_toplevel_item ~scopes item =
         Lletrec(class_bindings, body)
   | Tstr_include incl ->
       let ids = bound_value_identifiers incl.incl_type in
+      let loc = of_location ~scopes incl.incl_loc in
       let modl = incl.incl_mod in
+      let modl =
+        match incl.incl_kind with
+        | Tincl_structure ->
+            transl_module ~scopes Tcoerce_none None modl
+        | Tincl_functor ccs ->
+            transl_include_functor ~generative:false modl ccs scopes loc
+        | Tincl_gen_functor ccs ->
+            transl_include_functor ~generative:true modl ccs scopes loc
+      in
       let mid = Ident.create_local "include" in
       let rec set_idents pos = function
         [] ->
@@ -1629,8 +1682,7 @@ let transl_toplevel_item ~scopes item =
           Lsequence(toploop_setvalue id
                       (Lprim(mod_field pos, [Lvar mid], Loc_unknown)),
                     set_idents (pos + 1) ids) in
-      Llet(Strict, Pgenval, mid,
-           transl_module ~scopes Tcoerce_none None modl, set_idents 0 ids)
+      Llet(Strict, Pgenval, mid, modl, set_idents 0 ids)
   | Tstr_primitive descr ->
       record_primitive descr.val_val;
       lambda_unit

ocaml/parsing/builtin_attributes.ml

@@ -435,3 +435,13 @@ let tailcall attr =
   | false, true -> Ok (Some `Nontail)
   | false, false -> Ok None
   | true, true -> Error `Conflict
+
+let has_include_functor attr =
+  if List.exists (check ["extension.include_functor"]) attr then
+    if not (Clflags.Extension.is_enabled Include_functor) then
+      Error ()
+    else
+      Ok true
+  else
+    Ok false
+

ocaml/parsing/builtin_attributes.mli

@@ -99,5 +99,6 @@ val has_nonlocal: Parsetree.attributes -> bool
 (* These functions report Error if the builtin extension.* attributes
    are present despite the extension being disabled *)
 val has_local: Parsetree.attributes -> (bool,unit) result
-
 val tailcall : Parsetree.attributes -> ([`Tail|`Nontail] option, [`Conflict]) result
+val has_include_functor : Parsetree.attributes -> (bool,unit) result
+

ocaml/parsing/parser.mly

@@ -166,6 +166,11 @@ let local_attr =
 let local_extension =
   Exp.mk ~loc:Location.none (Pexp_extension(local_ext_loc, PStr []))
 
+let include_functor_ext_loc = mknoloc "extension.include_functor"
+
+let include_functor_attr =
+  Attr.mk ~loc:Location.none include_functor_ext_loc (PStr [])
+
 let mkexp_stack ~loc exp =
   ghexp ~loc (Pexp_apply(local_extension, [Nolabel, exp]))
 
@@ -827,6 +832,8 @@ The precedences must be listed from low to high.
 %left     BAR                           /* pattern (p|p|p) */
 %nonassoc below_COMMA
 %left     COMMA                         /* expr/expr_comma_list (e,e,e) */
+%nonassoc below_FUNCTOR                 /* include M */
+%nonassoc FUNCTOR                       /* include functor M */
 %right    MINUSGREATER                  /* function_type (t -> t -> t) */
 %right    OR BARBAR                     /* expr (e || e || e) */
 %right    AMPERSAND AMPERAMPER          /* expr (e && e && e) */
@@ -1507,16 +1514,23 @@ module_binding_body:
 
 (* Shared material between structures and signatures. *)
 
+include_and_functor_attr:
+  | INCLUDE %prec below_FUNCTOR
+      { [] }
+  | INCLUDE FUNCTOR
+      { [include_functor_attr] }
+;
+
 (* An [include] statement can appear in a structure or in a signature,
    which is why this definition is parameterized. *)
 %inline include_statement(thing):
-  INCLUDE
+  attrs0 = include_and_functor_attr
   ext = ext
   attrs1 = attributes
   thing = thing
   attrs2 = post_item_attributes
   {
-    let attrs = attrs1 @ attrs2 in
+    let attrs = attrs0 @ attrs1 @ attrs2 in
     let loc = make_loc $sloc in
     let docs = symbol_docs $sloc in
     Incl.mk thing ~attrs ~loc ~docs, ext
@@ -2415,11 +2429,11 @@ comprehension_tail(bracket):
 %inline comprehension_expr:
 | LBRACKET expr comprehension_tail(RBRACKET)
       { Pexp_extension(
-          Extensions.payload_of_extension_expr 
+          Extensions.payload_of_extension_expr
             ~loc:(make_loc $sloc) (Eexp_list_comprehension($2, $3))) }
 | LBRACKETBAR expr comprehension_tail(BARRBRACKET)
       { Pexp_extension(
-          Extensions.payload_of_extension_expr 
+          Extensions.payload_of_extension_expr
             ~loc:(make_loc $sloc) (Eexp_arr_comprehension($2, $3))) }
 ;
 
@@ -2490,7 +2504,7 @@ comprehension_tail(bracket):
       { fst (mktailexp $loc($3) $2) }
   | LBRACKET expr_semi_list error
       { unclosed "[" $loc($1) "]" $loc($3) }
-  | comprehension_expr { $1 } 
+  | comprehension_expr { $1 }
   | od=open_dot_declaration DOT comprehension_expr
       { Pexp_open(od, mkexp ~loc:($loc($3)) $3) }
   | od=open_dot_declaration DOT LBRACKET expr_semi_list RBRACKET

ocaml/parsing/pprintast.ml

@@ -129,6 +129,14 @@ let check_local_attr attrs =
   | [], _ -> attrs, false
   | _::_, rest -> rest, true
 
+let check_include_functor_attr attrs =
+  match
+    List.partition (fun attr ->
+        attr.attr_name.txt = "extension.include_functor") attrs
+  with
+  | [], _ -> attrs, false
+  | _::_, rest -> rest, true
+
 type space_formatter = (unit, Format.formatter, unit) format
 
 let override = function
@@ -304,6 +312,9 @@ let maybe_local_type pty ctxt f c =
   else
     pty ctxt f c
 
+let maybe_functor f has_functor_attr =
+  if has_functor_attr then pp f "@ functor" else ()
+
 (* c ['a,'b] *)
 let rec class_params_def ctxt f =  function
   | [] -> ()
@@ -1191,9 +1202,12 @@ and signature_item ctxt f x : unit =
         longident_loc od.popen_expr
         (item_attributes ctxt) od.popen_attributes
   | Psig_include incl ->
-      pp f "@[<hov2>include@ %a@]%a"
+      (* Print "include functor" rather than attribute *)
+      let attrs, incl_fun = check_include_functor_attr incl.pincl_attributes in
+      pp f "@[<hov2>include%a@ %a@]%a"
+        maybe_functor incl_fun
         (module_type ctxt) incl.pincl_mod
-        (item_attributes ctxt) incl.pincl_attributes
+        (item_attributes ctxt) attrs
   | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
       pp f "@[<hov2>module@ type@ %s%a@]%a"
         s.txt
@@ -1479,9 +1493,12 @@ and structure_item ctxt f x =
         (value_description ctxt) vd
         (item_attributes ctxt) vd.pval_attributes
   | Pstr_include incl ->
-      pp f "@[<hov2>include@ %a@]%a"
+      (* Print "include functor" rather than attribute *)
+      let attrs, incl_fun = check_include_functor_attr incl.pincl_attributes in
+      pp f "@[<hov2>include%a@ %a@]%a"
+        maybe_functor incl_fun
         (module_expr ctxt) incl.pincl_mod
-        (item_attributes ctxt) incl.pincl_attributes
+        (item_attributes ctxt) attrs
   | Pstr_recmodule decls -> (* 3.07 *)
       let aux f = function
         | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) ->

ocaml/testsuite/tests/parsing/include_functor.ml

@@ -0,0 +1,48 @@
+(* TEST
+    flags = "-dsource -extension include_functor"
+    * expect
+*)
+
+(* Test that include functor is printed with a keyword and not an attribute *)
+module type S1 = sig
+  type t
+  val x : t
+end
+
+
+module type F = functor (X : S1) -> sig val z : X.t end
+
+module type S2 = sig
+  type t
+  val x : t
+  include functor F
+end
+
+module G (X : S1) = struct
+  let z = X.x
+end
+
+module M : S2 = struct
+  type t = int
+  let x = 3
+  include functor G
+end;;
+[%%expect {|
+
+module type S1  = sig type t val x : t end;;
+module type S1 = sig type t val x : t end
+
+module type F  = functor (X : S1) -> sig val z : X.t end;;
+module type F = functor (X : S1) -> sig val z : X.t end
+
+module type S2  = sig type t val x : t include functor F end;;
+module type S2 = sig type t val x : t val z : t end
+
+module G(X:S1) = struct let z = X.x end;;
+module G : functor (X : S1) -> sig val z : X.t end
+
+module M : S2 = struct type t = int
+                       let x = 3
+                       include functor G end ;;
+module M : S2
+|}];;