API tools faq
paste
Guest User

Untitled

a guest
Feb 16th, 2019
121
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 8.31 KB | None | 0 0
raw download clone embed print report
  1. diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
  2. index 8bf2608..3b94a91 100644
  3. --- a/bytecomp/translmod.ml
  4. +++ b/bytecomp/translmod.ml
  5. @@ -228,6 +228,19 @@ let compile_recmodule compile_rhs bindings cont =
  6. bindings))
  7. cont
  8.  
  9. +(* Extract the list of "value" identifiers bound by a signature.
  10. + "Value" identifiers are identifiers for signature components that
  11. + correspond to a run-time value: values, exceptions, modules, classes.
  12. + Note: manifest primitives do not correspond to a run-time value! *)
  13. +
  14. +let rec bound_value_identifiers = function
  15. + [] -> []
  16. + | Sig_value(id, {val_kind = Val_reg}) :: rem ->
  17. + id :: bound_value_identifiers rem
  18. + | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem
  19. + | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem
  20. + | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem
  21. + | _ :: rem -> bound_value_identifiers rem
  22.  
  23. (* Compile a module expression *)
  24.  
  25. @@ -329,7 +342,8 @@ and transl_structure fields cc rootpath = function
  26. transl_structure (List.rev ids @ fields) cc rootpath rem)
  27. | Tstr_class_type cl_list ->
  28. transl_structure fields cc rootpath rem
  29. - | Tstr_include(modl, ids) ->
  30. + | Tstr_include(modl, sg) ->
  31. + let ids = bound_value_identifiers sg in
  32. let mid = Ident.create "include" in
  33. let rec rebind_idents pos newfields = function
  34. [] ->
  35. @@ -377,7 +391,7 @@ let rec defined_idents = function
  36. | Tstr_class cl_list ->
  37. List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem
  38. | Tstr_class_type cl_list -> defined_idents rem
  39. - | Tstr_include(modl, ids) -> ids @ defined_idents rem
  40. + | Tstr_include(modl, sg) -> bound_value_identifiers sg @ defined_idents rem
  41.  
  42. (* second level idents (module M = struct ... let id = ... end),
  43. and all sub-levels idents *)
  44. @@ -396,7 +410,7 @@ let rec more_idents = function
  45. | Tstr_open _ -> more_idents rem
  46. | Tstr_class cl_list -> more_idents rem
  47. | Tstr_class_type cl_list -> more_idents rem
  48. - | Tstr_include(modl, ids) -> more_idents rem
  49. + | Tstr_include(modl, _) -> more_idents rem
  50. | Tstr_module(id, _, { mod_desc = Tmod_structure str }) ->
  51. all_idents str.str_items @ more_idents rem
  52. | Tstr_module(id, _, _) -> more_idents rem
  53. @@ -419,7 +433,7 @@ and all_idents = function
  54. | Tstr_class cl_list ->
  55. List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ all_idents rem
  56. | Tstr_class_type cl_list -> all_idents rem
  57. - | Tstr_include(modl, ids) -> ids @ all_idents rem
  58. + | Tstr_include(modl, sg) -> bound_value_identifiers sg @ all_idents rem
  59. | Tstr_module(id, _, { mod_desc = Tmod_structure str }) ->
  60. id :: all_idents str.str_items @ all_idents rem
  61. | Tstr_module(id, _, _) -> id :: all_idents rem
  62. @@ -526,7 +540,8 @@ let transl_store_structure glob map prims str =
  63. transl_store rootpath (add_idents false ids subst) rem)
  64. | Tstr_class_type cl_list ->
  65. transl_store rootpath subst rem
  66. - | Tstr_include(modl, ids) ->
  67. + | Tstr_include(modl, sg) ->
  68. + let ids = bound_value_identifiers sg in
  69. let mid = Ident.create "include" in
  70. let rec store_idents pos = function
  71. [] -> transl_store rootpath (add_idents true ids subst) rem
  72. @@ -719,7 +734,8 @@ let transl_toplevel_item item =
  73. cl_list)
  74. | Tstr_class_type cl_list ->
  75. lambda_unit
  76. - | Tstr_include(modl, ids) ->
  77. + | Tstr_include(modl, sg) ->
  78. + let ids = bound_value_identifiers sg in
  79. let mid = Ident.create "include" in
  80. let rec set_idents pos = function
  81. [] ->
  82. diff --git a/tools/untypeast.ml b/tools/untypeast.ml
  83. index e1719d9..c1b4264 100644
  84. --- a/tools/untypeast.ml
  85. +++ b/tools/untypeast.ml
  86. @@ -319,7 +319,7 @@ and untype_signature_item item =
  87. | Tsig_modtype (_id, name, mdecl) ->
  88. Psig_modtype (name, untype_modtype_declaration mdecl)
  89. | Tsig_open (ovf, _path, lid) -> Psig_open (ovf, lid)
  90. - | Tsig_include (mty, _lid) -> Psig_include (untype_module_type mty)
  91. + | Tsig_include (mty, _) -> Psig_include (untype_module_type mty)
  92. | Tsig_class list ->
  93. Psig_class (List.map untype_class_description list)
  94. | Tsig_class_type list ->
  95. diff --git a/typing/typedtree.ml b/typing/typedtree.ml
  96. index 89ac527..405e56b 100644
  97. --- a/typing/typedtree.ml
  98. +++ b/typing/typedtree.ml
  99. @@ -202,7 +202,7 @@ and structure_item_desc =
  100. | Tstr_open of override_flag * Path.t * Longident.t loc
  101. | Tstr_class of (class_declaration * string list * virtual_flag) list
  102. | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
  103. - | Tstr_include of module_expr * Ident.t list
  104. + | Tstr_include of module_expr * Types.signature
  105.  
  106. and module_coercion =
  107. Tcoerce_none
  108. diff --git a/typing/typedtree.mli b/typing/typedtree.mli
  109. index 70e79b0..a263c90 100644
  110. --- a/typing/typedtree.mli
  111. +++ b/typing/typedtree.mli
  112. @@ -201,7 +201,7 @@ and structure_item_desc =
  113. | Tstr_open of override_flag * Path.t * Longident.t loc
  114. | Tstr_class of (class_declaration * string list * virtual_flag) list
  115. | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list
  116. - | Tstr_include of module_expr * Ident.t list
  117. + | Tstr_include of module_expr * Types.signature
  118.  
  119. and module_coercion =
  120. Tcoerce_none
  121. diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
  122. index 2b6f641..7c8c633 100644
  123. --- a/typing/typedtreeMap.ml
  124. +++ b/typing/typedtreeMap.ml
  125. @@ -139,8 +139,8 @@ module MakeMap(Map : MapArgument) = struct
  126. (id, name, Map.leave_class_infos { ct with ci_expr = ci_expr})
  127. ) list in
  128. Tstr_class_type list
  129. - | Tstr_include (mexpr, idents) ->
  130. - Tstr_include (map_module_expr mexpr, idents)
  131. + | Tstr_include (mexpr, sg) ->
  132. + Tstr_include (map_module_expr mexpr, sg)
  133. in
  134. Map.leave_structure_item { item with str_desc = str_desc}
  135.  
  136. @@ -402,7 +402,7 @@ module MakeMap(Map : MapArgument) = struct
  137. | Tsig_modtype (id, name, mdecl) ->
  138. Tsig_modtype (id, name, map_modtype_declaration mdecl)
  139. | Tsig_open _ -> item.sig_desc
  140. - | Tsig_include (mty, lid) -> Tsig_include (map_module_type mty, lid)
  141. + | Tsig_include (mty, sg) -> Tsig_include (map_module_type mty, sg)
  142. | Tsig_class list -> Tsig_class (List.map map_class_description list)
  143. | Tsig_class_type list ->
  144. Tsig_class_type (List.map map_class_type_declaration list)
  145. diff --git a/typing/typemod.ml b/typing/typemod.ml
  146. index 475cb9b..521b078 100644
  147. --- a/typing/typemod.ml
  148. +++ b/typing/typemod.ml
  149. @@ -688,20 +688,6 @@ let check_nongen_scheme env str =
  150. let check_nongen_schemes env str =
  151. List.iter (check_nongen_scheme env) str
  152.  
  153. -(* Extract the list of "value" identifiers bound by a signature.
  154. - "Value" identifiers are identifiers for signature components that
  155. - correspond to a run-time value: values, exceptions, modules, classes.
  156. - Note: manifest primitives do not correspond to a run-time value! *)
  157. -
  158. -let rec bound_value_identifiers = function
  159. - [] -> []
  160. - | Sig_value(id, {val_kind = Val_reg}) :: rem ->
  161. - id :: bound_value_identifiers rem
  162. - | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem
  163. - | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem
  164. - | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem
  165. - | _ :: rem -> bound_value_identifiers rem
  166. -
  167. (* Helpers for typing recursive modules *)
  168.  
  169. let anchor_submodule name anchor =
  170. @@ -1146,7 +1132,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
  171. List.iter
  172. (check_sig_item type_names module_names modtype_names loc) sg;
  173. let new_env = Env.add_signature sg env in
  174. - let item = mk (Tstr_include (modl, bound_value_identifiers sg)) in
  175. + let item = mk (Tstr_include (modl, sg)) in
  176. let (str_rem, sig_rem, final_env) = type_struct new_env srem in
  177. (item :: str_rem,
  178. sg @ sig_rem,
  179. diff --git a/typing/typemod.mli b/typing/typemod.mli
  180. index d34bde8..cda0069 100644
  181. --- a/typing/typemod.mli
  182. +++ b/typing/typemod.mli
  183. @@ -39,8 +39,6 @@ val save_signature : string -> Typedtree.signature -> string -> string ->
  184. val package_units:
  185. string list -> string -> string -> Typedtree.module_coercion
  186.  
  187. -val bound_value_identifiers : Types.signature_item list -> Ident.t list
  188. -
  189. type error =
  190. Cannot_apply of module_type
  191. | Not_included of Includemod.error list
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!