Merge pull request #273 from diml/get-extension-slot

Get extension slot

Changes

@@ -60,6 +60,9 @@ Language features:
 - GPR#282: change short-paths penalty heuristic to assign the same cost to
   idents containing double underscores as to idents starting with an underscore
   (Thomas Refis, Leo White)
+- GPR#273: allow to get the extension slot of an extension constructor
+  by writing [%extension_constructor <path>]
+  (Jérémie Dimino)
 
 Compilers:
 - PR#4800: better compilation of tuple assignment (Gabriel Scherer and

bytecomp/translcore.ml

@@ -825,6 +825,8 @@ and transl_exp0 e =
             Lprim(Pmakeblock(0, Immutable),
                   transl_path e.exp_env path :: ll)
       end
+  | Texp_extension_constructor (_, path) ->
+      transl_path e.exp_env path
   | Texp_variant(l, arg) ->
       let tag = Btype.hash_variant l in
       begin match arg with

stdlib/obj.ml

@@ -60,32 +60,21 @@ let int_tag = 1000
 let out_of_heap_tag = 1001
 let unaligned_tag = 1002
 
-let extension_slot x =
+let extension_constructor x =
   let x = repr x in
   let slot =
     if (is_block x) && (tag x) <> object_tag && (size x) >= 1 then field x 0
     else x
   in
   let name =
     if (is_block slot) && (tag slot) = object_tag then field slot 0
-    else raise Not_found
+    else invalid_arg "Obj.extension_constructor"
   in
-    if (tag name) = string_tag then slot
-    else raise Not_found
+    if (tag name) = string_tag then (obj slot : extension_constructor)
+    else invalid_arg "Obj.extension_constructor"
 
-let extension_name x =
-  try
-    let slot = extension_slot x in
-      (obj (field slot 0) : string)
-  with Not_found -> invalid_arg "Obj.extension_name"
+let extension_name (slot : extension_constructor) =
+  (obj (field (repr slot) 0) : string)
 
-let extension_id x =
-  try
-    let slot = extension_slot x in
-      (obj (field slot 1) : int)
-  with Not_found -> invalid_arg "Obj.extension_id"
-
-let extension_slot x =
-  try
-    extension_slot x
-  with Not_found -> invalid_arg "Obj.extension_slot"
+let extension_id (slot : extension_constructor) =
+  (obj (field (repr slot) 1) : int)

stdlib/obj.mli

@@ -57,9 +57,9 @@ val int_tag : int
 val out_of_heap_tag : int
 val unaligned_tag : int   (* should never happen @since 3.11.0 *)
 
-val extension_name : 'a -> string
-val extension_id : 'a -> int
-val extension_slot : 'a -> t
+val extension_constructor : 'a -> extension_constructor
+val extension_name : extension_constructor -> string
+val extension_id : extension_constructor -> int
 
 (** The following two functions are deprecated.  Use module {!Marshal}
     instead. *)

testsuite/tests/extension-constructor/Makefile

@@ -0,0 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

testsuite/tests/extension-constructor/test.ml

@@ -0,0 +1,29 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                 Jeremie Dimino, Jane Street Europe                  *)
+(*                                                                     *)
+(*  Copyright 2015 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+type t = ..
+
+module M = struct
+  type t += A
+  type t += B of int
+end
+
+type t += C
+type t += D of int * string
+
+let () =
+  assert (Obj.extension_constructor M.A          == [%extension_constructor M.A]);
+  assert (Obj.extension_constructor (M.B 42)     == [%extension_constructor M.B]);
+  assert (Obj.extension_constructor C            == [%extension_constructor C  ]);
+  assert (Obj.extension_constructor (D (42, "")) == [%extension_constructor D  ])
+
+let () = print_endline "OK"

testsuite/tests/extension-constructor/test.reference

@@ -0,0 +1 @@
+OK

testsuite/tests/typing-extension-constructor/Makefile

@@ -0,0 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common

testsuite/tests/typing-extension-constructor/test.ml

@@ -0,0 +1,21 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                 Jeremie Dimino, Jane Street Europe                  *)
+(*                                                                     *)
+(*  Copyright 2015 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+type t = ..;;
+type t += A;;
+
+[%extension_constructor A];;
+([%extension_constructor A] : extension_constructor);;
+
+type extension_constructor = int;;
+
+([%extension_constructor A] : extension_constructor);;

testsuite/tests/typing-extension-constructor/test.ml.reference

@@ -0,0 +1,13 @@
+
+#                         type t = ..
+# type t += A
+#   - : extension_constructor = <abstr>
+# - : extension_constructor = <abstr>
+#   type extension_constructor = int
+#   Characters 2-28:
+  ([%extension_constructor A] : extension_constructor);;
+   ^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This expression has type extension_constructor/16
+       but an expression was expected of type
+         extension_constructor/1214 = int
+# 

testsuite/tests/typing-extensions/extensions.ml

@@ -296,28 +296,31 @@ type foo +=
   | Bar of int
 ;;
 
-let n1 = Obj.extension_name Foo
+let extension_name e = Obj.extension_name (Obj.extension_constructor e);;
+let extension_id e = Obj.extension_id (Obj.extension_constructor e);;
+
+let n1 = extension_name Foo
 ;;
 
-let n2 = Obj.extension_name (Bar 1)
+let n2 = extension_name (Bar 1)
 ;;
 
-let t = (Obj.extension_id (Bar 2)) = (Obj.extension_id (Bar 3)) (* true *)
+let t = (extension_id (Bar 2)) = (extension_id (Bar 3)) (* true *)
 ;;
 
-let f = (Obj.extension_id (Bar 2)) = (Obj.extension_id Foo) (* false *)
+let f = (extension_id (Bar 2)) = (extension_id Foo) (* false *)
 ;;
 
-let is_foo x = (Obj.extension_id Foo) = (Obj.extension_id x)
+let is_foo x = (extension_id Foo) = (extension_id x)
 
 type foo += Foo
 ;;
 
 let f = is_foo Foo
 ;;
 
-let _ = Obj.extension_name 7 (* Invald_arg *)
+let _ = Obj.extension_constructor 7 (* Invald_arg *)
 ;;
 
-let _ = Obj.extension_id (object method m = 3 end) (* Invald_arg *)
+let _ = Obj.extension_constructor (object method m = 3 end) (* Invald_arg *)
 ;;

testsuite/tests/typing-extensions/extensions.ml.reference

@@ -119,13 +119,15 @@ Error: This extension does not match the definition of type bar
 #     val y : exn * exn = (Foo (3, _), Bar (Some 5))
 #         type foo = ..
 #         type foo += Foo | Bar of int
+#   val extension_name : 'a -> string = <fun>
+# val extension_id : 'a -> int = <fun>
 #     val n1 : string = "Foo"
 #     val n2 : string = "Bar"
 #     val t : bool = true
 #     val f : bool = false
 #         val is_foo : 'a -> bool = <fun>
 type foo += Foo
 #     val f : bool = false
-#     Exception: Invalid_argument "Obj.extension_name".
-#     Exception: Invalid_argument "Obj.extension_id".
+#     Exception: Invalid_argument "Obj.extension_constructor".
+#     Exception: Invalid_argument "Obj.extension_constructor".
 # 

tools/depend.ml

@@ -200,6 +200,12 @@ let rec add_expr bv exp =
   | Pexp_newtype (_, e) -> add_expr bv e
   | Pexp_pack m -> add_module bv m
   | Pexp_open (_ovf, m, e) -> open_module bv m.txt; add_expr bv e
+  | Pexp_extension ({ txt = ("ocaml.extension_constructor"|"extension_constructor"); _ },
+                    PStr [item]) ->
+    begin match item.pstr_desc with
+    | Pstr_eval ({ pexp_desc = Pexp_construct (c, None) }, _) -> add bv c
+    | _ -> ()
+    end
   | Pexp_extension _ -> ()
   | Pexp_unreachable -> ()
 

typing/predef.ml

@@ -41,6 +41,7 @@ and ident_int32 = ident_create "int32"
 and ident_int64 = ident_create "int64"
 and ident_lazy_t = ident_create "lazy_t"
 and ident_string = ident_create "string"
+and ident_extension_constructor = ident_create "extension_constructor"
 
 let path_int = Pident ident_int
 and path_char = Pident ident_char
@@ -57,6 +58,7 @@ and path_int32 = Pident ident_int32
 and path_int64 = Pident ident_int64
 and path_lazy_t = Pident ident_lazy_t
 and path_string = Pident ident_string
+and path_extension_constructor = Pident ident_extension_constructor
 
 let type_int = newgenty (Tconstr(path_int, [], ref Mnil))
 and type_char = newgenty (Tconstr(path_char, [], ref Mnil))
@@ -73,6 +75,7 @@ and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil))
 and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil))
 and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil))
 and type_string = newgenty (Tconstr(path_string, [], ref Mnil))
+and type_extension_constructor = newgenty (Tconstr(path_extension_constructor, [], ref Mnil))
 
 let ident_match_failure = ident_create_predef_exn "Match_failure"
 and ident_out_of_memory = ident_create_predef_exn "Out_of_memory"
@@ -198,7 +201,8 @@ let common_initial_env add_type add_extension empty_env =
   add_type ident_string decl_abstr (
   add_type ident_char decl_abstr (
   add_type ident_int decl_abstr (
-    empty_env))))))))))))))))))))))))))
+  add_type ident_extension_constructor decl_abstr (
+    empty_env)))))))))))))))))))))))))))
 
 let build_initial_env add_type add_exception empty_env =
   let common = common_initial_env add_type add_exception empty_env in

typing/predef.mli

@@ -29,6 +29,7 @@ val type_nativeint: type_expr
 val type_int32: type_expr
 val type_int64: type_expr
 val type_lazy_t: type_expr -> type_expr
+val type_extension_constructor:type_expr
 
 val path_int: Path.t
 val path_char: Path.t
@@ -45,6 +46,7 @@ val path_nativeint: Path.t
 val path_int32: Path.t
 val path_int64: Path.t
 val path_lazy_t: Path.t
+val path_extension_constructor: Path.t
 
 val path_match_failure: Path.t
 val path_assert_failure : Path.t

typing/printtyped.ml

@@ -373,6 +373,8 @@ and expression i ppf x =
       module_expr i ppf me
   | Texp_unreachable ->
       line i ppf "Texp_unreachable"
+  | Texp_extension_constructor (li, _) ->
+      line i ppf "Texp_extension_constructor %a" fmt_longident li
 
 and value_description i ppf x =
   line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location

typing/tast_mapper.ml

@@ -330,6 +330,8 @@ let expr sub x =
         Texp_pack (sub.module_expr sub mexpr)
     | Texp_unreachable ->
         Texp_unreachable
+    | Texp_extension_constructor _ as e ->
+        e
   in
   {x with exp_extra; exp_desc; exp_env}
 

typing/typecore.ml

@@ -69,6 +69,8 @@ type error =
   | Exception_pattern_below_toplevel
   | Inlined_record_escape
   | Unrefuted_pattern of pattern
+  | Invalid_extension_constructor_payload
+  | Not_an_extension_constructor
 
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
@@ -2839,6 +2841,27 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
                      sexp.pexp_attributes) ::
                       exp.exp_extra;
       }
+
+  | Pexp_extension ({ txt = ("ocaml.extension_constructor"|"extension_constructor"); _ },
+                    payload) ->
+      begin match payload with
+      | PStr [ { pstr_desc =
+                   Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _)
+               } ] ->
+          let path =
+            match (Typetexp.find_constructor env lid.loc lid.txt).cstr_tag with
+            | Cstr_extension (path, _) -> path
+            | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor))
+          in
+          rue {
+            exp_desc = Texp_extension_constructor (lid, path);
+            exp_loc = loc; exp_extra = [];
+            exp_type = instance_def Predef.type_extension_constructor;
+            exp_attributes = sexp.pexp_attributes;
+            exp_env = env }
+      | _ ->
+          raise (Error (loc, env, Invalid_extension_constructor_payload))
+      end
   | Pexp_extension ext ->
       raise (Error_forward (Typetexp.error_of_extension ext))
 
@@ -4213,6 +4236,12 @@ let report_error env ppf = function
         "This match case could not be refuted."
         "Here is an example of a value that would reach it:"
         Parmatch.top_pretty pat
+  | Invalid_extension_constructor_payload ->
+      fprintf ppf
+        "Invalid [%%extension_constructor] payload, a constructor is expected."
+  | Not_an_extension_constructor ->
+      fprintf ppf
+        "This constructor is not an extension constructor."
 
 let report_error env ppf err =
   wrap_printing_env env (fun () -> report_error env ppf err)

typing/typecore.mli

@@ -114,6 +114,8 @@ type error =
   | Exception_pattern_below_toplevel
   | Inlined_record_escape
   | Unrefuted_pattern of Typedtree.pattern
+  | Invalid_extension_constructor_payload
+  | Not_an_extension_constructor
 
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error

typing/typedtree.ml

@@ -105,6 +105,7 @@ and expression_desc =
   | Texp_object of class_structure * string list
   | Texp_pack of module_expr
   | Texp_unreachable
+  | Texp_extension_constructor of Longident.t loc * Path.t
 
 and meth =
     Tmeth_name of string

typing/typedtree.mli

@@ -205,6 +205,7 @@ and expression_desc =
   | Texp_object of class_structure * string list
   | Texp_pack of module_expr
   | Texp_unreachable
+  | Texp_extension_constructor of Longident.t loc * Path.t
 
 and meth =
     Tmeth_name of string

typing/typedtreeIter.ml

@@ -347,6 +347,8 @@ module MakeIterator(Iter : IteratorArgument) : sig
             iter_module_expr mexpr
         | Texp_unreachable ->
             ()
+        | Texp_extension_constructor _ ->
+            ()
       end;
       Iter.leave_expression exp;