printing dynamic values

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

9 files changed, 94 insertions, 21 deletions

diff --git a/.depend b/.depend
index a3f1417265..8b6405e30d 100644
--- a/.depend
+++ b/.depend
@@ -212,15 +212,15 @@ typing/typedtree.cmo: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \
 typing/typedtree.cmx: parsing/asttypes.cmi typing/env.cmx typing/ident.cmx \
     parsing/location.cmx utils/misc.cmx typing/path.cmx typing/primitive.cmx \
     typing/types.cmx typing/typedtree.cmi 
-typing/typemod.cmo: utils/clflags.cmo utils/config.cmi typing/ctype.cmi \
-    typing/env.cmi typing/ident.cmi typing/includemod.cmi \
+typing/typemod.cmo: typing/btype.cmi utils/clflags.cmo utils/config.cmi \
+    typing/ctype.cmi typing/env.cmi typing/ident.cmi typing/includemod.cmi \
     parsing/location.cmi parsing/longident.cmi utils/misc.cmi \
     typing/mtype.cmi parsing/parsetree.cmi typing/path.cmi \
     typing/printtyp.cmi typing/subst.cmi typing/typeclass.cmi \
     typing/typecore.cmi typing/typedecl.cmi typing/typedtree.cmi \
     typing/types.cmi typing/typemod.cmi 
-typing/typemod.cmx: utils/clflags.cmx utils/config.cmx typing/ctype.cmx \
-    typing/env.cmx typing/ident.cmx typing/includemod.cmx \
+typing/typemod.cmx: typing/btype.cmx utils/clflags.cmx utils/config.cmx \
+    typing/ctype.cmx typing/env.cmx typing/ident.cmx typing/includemod.cmx \
     parsing/location.cmx parsing/longident.cmx utils/misc.cmx \
     typing/mtype.cmx parsing/parsetree.cmi typing/path.cmx \
     typing/printtyp.cmx typing/subst.cmx typing/typeclass.cmx \
diff --git a/Changes.dynamics b/Changes.dynamics
index 93d7d54193..7c9feb21f3 100644
--- a/Changes.dynamics
+++ b/Changes.dynamics
@@ -147,4 +147,15 @@ Ok, syntax is done.
 	  - added Ident.stamp to retrieve stamp
 		(for conversion from ident to rident)
 
-	* added Translcore.make_block
\ No newline at end of file
+	* added Translcore.make_block
+
+*************************************************************** printer for dyn
+
+	* added type_expr_of_rtype to Transltype
+
+	* Outcometree
+		* Oval_dynamic is added
+
+	* Genprintval
+		* O.magic is added 
+		* added printer for dyn
diff --git a/bytecomp/transltype.ml b/bytecomp/transltype.ml
index 9f16e0d2c4..5aa52c92f4 100644
--- a/bytecomp/transltype.ml
+++ b/bytecomp/transltype.ml
@@ -5,6 +5,7 @@ open Asttypes
 open Types
 open Longident
 open Misc
+open Outcometree
 
 let dbg = try ignore (Sys.getenv "DEBUG_TRANSLTYPE"); true with _ -> false
 
@@ -163,6 +164,36 @@ let transl_rtype_of_type (* env *) t =
   in
   sub t
 
+(* rtype -> type_expr *)
+
+let type_expr_of_rtype rt =
+  let tvars = ref [] in
+  let rec path_of_rpath = function
+      RPident (name,stamp) -> Pident (Ident.create_with_stamp name stamp)
+    | RPdot (RPident ("*toplevel*",0), s, x) ->
+	Pident (Ident.create_with_stamp s x)
+    | RPdot (rp, s, x) -> Pdot (path_of_rpath rp, s, x)
+    | RPapply (p1,p2) -> Papply (path_of_rpath p1, path_of_rpath p2)
+  in
+  let rec sub = function
+    | RTvar x -> 
+	begin 
+	  try List.assoc x !tvars with Not_found ->
+	    let tv = Btype.newgenty Tvar in
+	    tvars := (x,tv) :: !tvars;
+	    tv
+	end
+    | RTarrow (l,f,t) ->
+	Btype.newgenty (Tarrow (l, sub f, sub t, Cunknown))
+    | RTtuple tls ->
+	Btype.newgenty (Ttuple (List.map sub tls))
+    | RTconstr (rp, args) ->
+	Btype.newgenty (Tconstr (path_of_rpath rp, 
+				 List.map sub args, ref Mnil))
+  in
+  sub rt
+;;
+
 (* dynamic/coerce primitive compilaiton are stored in stdlib/rtype.ml *)
 let rtype_prim name =
   try
@@ -170,3 +201,4 @@ let rtype_prim name =
       (fst (Env.lookup_value (Ldot (Lident "Rtype", name)) Env.empty))
   with Not_found ->
     fatal_error ("Primitive " ^ name ^ " not found.")
+
diff --git a/bytecomp/transltype.mli b/bytecomp/transltype.mli
index 2faaf40d03..7fb61a9d30 100644
--- a/bytecomp/transltype.mli
+++ b/bytecomp/transltype.mli
@@ -6,4 +6,7 @@ val transl_rpath : Rtype.rpath -> Lambda.structured_constant
 val transl_rpath_of_ident : Lambda.lambda -> Ident.t -> Lambda.lambda
 val transl_rpath_of_path : Path.t -> Lambda.structured_constant
 val transl_rtype_of_type : Types.type_expr -> Lambda.lambda
+
+val type_expr_of_rtype : Rtype.rtype -> Types.type_expr
+
 val rtype_prim : string -> Lambda.lambda
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 34c8f4fe1a..cde7a76ba2 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -20,6 +20,7 @@ open Longident
 open Path
 open Types
 open Outcometree
+open Rtype
 
 module type OBJ =
   sig
@@ -29,6 +30,9 @@ module type OBJ =
     val tag : t -> int
     val size : t -> int
     val field : t -> int -> t
+    (* DYN *)
+    val magic : t -> 'a
+    (* /DYN *)
   end
 
 module type EVALPATH =
@@ -187,6 +191,14 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
               Oval_tuple (tree_of_val_list 0 depth obj ty_list)
           | Tconstr(path, [], _) when Path.same path Predef.path_exn ->
               tree_of_exception depth obj
+(* DYN *)
+	  | Tconstr(path, [], _) 
+	    when Path.same path Predef.path_dyn ->
+	      let rt = (O.magic (O.field obj 1) : rtype) in
+	      let ty = Transltype.type_expr_of_rtype rt in
+	      Oval_dynamic (tree_of_val depth (O.field obj 0) ty,
+			    Printtyp.tree_of_type_scheme ty)
+(* /DYN *)
           | Tconstr(path, [ty_arg], _)
             when Path.same path Predef.path_list ->
               if O.is_block obj then
@@ -400,7 +412,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
             fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
         | Oval_ellipsis -> raise Ellipsis
         | Oval_printer f -> f ppf
-        | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree) tree
+	(* DYN *)
+	| Oval_dynamic (v,t) -> fprintf ppf "<%a : %a>" 
+	      print_tree v
+	      !Printtyp.outcome_type t
+        (* /DYN *)
+	| tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree) tree
       and print_fields first ppf =
         function
           [] -> ()
diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli
index 76b091e786..a3c74a6f93 100644
--- a/toplevel/genprintval.mli
+++ b/toplevel/genprintval.mli
@@ -25,6 +25,9 @@ module type OBJ =
     val tag : t -> int
     val size : t -> int
     val field : t -> int -> t
+    (* DYN *)
+    val magic : t -> 'a
+    (* /DYN *)
   end
 
 module type EVALPATH =
diff --git a/typing/ident.ml b/typing/ident.ml
index 058b049070..e51dcca8a1 100644
--- a/typing/ident.ml
+++ b/typing/ident.ml
@@ -27,6 +27,11 @@ let create s =
 let create_persistent s =
   { name = s; stamp = 0; global = true }
 
+(* DYN *)
+let create_with_stamp s stamp =
+  { name = s; stamp = stamp; global= false}
+(* /DYN *)
+
 let rename i =
   incr currentstamp;
   { i with stamp = !currentstamp }
diff --git a/typing/ident.mli b/typing/ident.mli
index 3da2331c04..bb8a75cb00 100644
--- a/typing/ident.mli
+++ b/typing/ident.mli
@@ -22,6 +22,7 @@ val rename: t -> t
 val name: t -> string
 (* DYN *)
 val stamp: t -> int
+val create_with_stamp: string -> int -> t
 (* /DYN *)
 val unique_name: t -> string
 val persistent: t -> bool
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index b1be465c4b..75a0319730 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -26,21 +26,6 @@ type out_ident =
   | Oide_dot of out_ident * string
   | Oide_ident of string
 
-type out_value =
-  | Oval_array of out_value list
-  | Oval_char of char
-  | Oval_constr of out_ident * out_value list
-  | Oval_ellipsis
-  | Oval_float of float
-  | Oval_int of int
-  | Oval_list of out_value list
-  | Oval_printer of (Format.formatter -> unit)
-  | Oval_record of (out_ident * out_value) list
-  | Oval_string of string
-  | Oval_stuff of string
-  | Oval_tuple of out_value list
-  | Oval_variant of string * out_value option
-
 type out_type =
   | Otyp_abstract
   | Otyp_alias of out_type * string
@@ -60,6 +45,22 @@ and out_variant =
   | Ovar_fields of (string * bool * out_type list) list
   | Ovar_name of out_ident * out_type list
 
+type out_value =
+  | Oval_array of out_value list
+  | Oval_char of char
+  | Oval_constr of out_ident * out_value list
+  | Oval_ellipsis
+  | Oval_float of float
+  | Oval_int of int
+  | Oval_list of out_value list
+  | Oval_printer of (Format.formatter -> unit)
+  | Oval_record of (out_ident * out_value) list
+  | Oval_string of string
+  | Oval_stuff of string
+  | Oval_tuple of out_value list
+  | Oval_variant of string * out_value option
+  | Oval_dynamic of out_value * out_type
+
 type out_class_type =
   | Octy_constr of out_ident * out_type list
   | Octy_fun of string * out_type * out_class_type