Ajout du module Types et d'infos d'environnement dans Typedtree.

Translcore: meilleur tests de types pour determiner le kind d'un tableau.


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

bytecomp/bytegen.ml

@@ -16,7 +16,7 @@
 open Misc
 open Asttypes
 open Primitive
-open Typedtree
+open Types
 open Lambda
 open Instruct
 

bytecomp/lambda.ml

@@ -14,7 +14,6 @@
 open Misc
 open Path
 open Asttypes
-open Typedtree
 
 type primitive =
     Pidentity

bytecomp/lambda.mli

@@ -14,7 +14,6 @@
 (* The "lambda" intermediate code *)
 
 open Asttypes
-open Typedtree
 
 type primitive =
     Pidentity

bytecomp/matching.ml

@@ -17,6 +17,7 @@ open Misc
 open Location
 open Asttypes
 open Primitive
+open Types
 open Typedtree
 open Lambda
 

bytecomp/printlambda.ml

@@ -14,7 +14,7 @@
 open Format
 open Asttypes
 open Primitive
-open Typedtree
+open Types
 open Lambda
 
 

bytecomp/translclass.ml

@@ -13,6 +13,7 @@
 
 open Misc
 open Asttypes
+open Types
 open Typedtree
 open Lambda
 open Translobj

bytecomp/translcore.ml

@@ -18,6 +18,7 @@ open Misc
 open Asttypes
 open Primitive
 open Path
+open Types
 open Typedtree
 open Lambda
 open Translobj
@@ -139,31 +140,35 @@ let primitives_table = create_hashtable 31 [
   "%obj_set_field", Parraysetu Paddrarray
 ]
 
-let same_base_type ty1 ty2 =
-  match ((Ctype.repr ty1).desc, (Ctype.repr ty2).desc) with
+let has_base_type exp base_ty =
+  let ty = Ctype.expand_root exp.exp_env exp.exp_type in
+  match ((Ctype.repr ty).desc, (Ctype.repr base_ty).desc) with
     (Tconstr(p1, [], _), Tconstr(p2, [], _)) -> Path.same p1 p2
   | (_, _) -> false
 
 let maybe_pointer arg =
-  not(same_base_type arg.exp_type Predef.type_int or
-      same_base_type arg.exp_type Predef.type_char)
+  not(has_base_type arg Predef.type_int or has_base_type arg Predef.type_char)
 
 let array_kind arg =
-  match (Ctype.repr arg.exp_type).desc with
+  let ty = Ctype.expand_root arg.exp_env arg.exp_type in
+  match (Ctype.repr ty).desc with
     Tconstr(p, [ty], _) when Path.same p Predef.path_array ->
-      begin match (Ctype.repr ty).desc with
+      begin match (Ctype.repr(Ctype.expand_root arg.exp_env ty)).desc with
         Tvar -> Pgenarray
       | Tconstr(p, _, _) ->
           if Path.same p Predef.path_int or Path.same p Predef.path_char then
             Pintarray
           else if Path.same p Predef.path_float then
             Pfloatarray
-          else
-            Paddrarray
+          else begin
+            match Env.find_type p arg.exp_env with
+              {type_kind = Type_abstract} -> Pgenarray
+            | {type_kind = _} -> Paddrarray
+          end
       | _ -> Paddrarray
       end
-  | _ -> Pgenarray (* This can happen with abbreviations that we can't expand
-                      here because the typing environment is lost *)
+  | _ ->
+    fatal_error "Translcore.array_kind"
 
 let prim_makearray =
   { prim_name = "make_vect"; prim_arity = 2; prim_alloc = true;
@@ -178,12 +183,12 @@ let transl_prim prim args =
         intcomp
     | [{exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}; arg2] ->
         intcomp
-    | [arg1; arg2] when same_base_type arg1.exp_type Predef.type_int
-                     or same_base_type arg1.exp_type Predef.type_char ->
+    | [arg1; arg2] when has_base_type arg1 Predef.type_int
+                     or has_base_type arg1 Predef.type_char ->
         intcomp
-    | [arg1; arg2] when same_base_type arg1.exp_type Predef.type_float ->
+    | [arg1; arg2] when has_base_type arg1 Predef.type_float ->
         floatcomp
-    | [arg1; arg2] when same_base_type arg1.exp_type Predef.type_string ->
+    | [arg1; arg2] when has_base_type arg1 Predef.type_string ->
         stringcomp
     | _ ->
         gencomp

bytecomp/translcore.mli

@@ -15,10 +15,11 @@
    for the core language *)
 
 open Asttypes
+open Types
 open Typedtree
 open Lambda
 
-val name_pattern: string -> (Typedtree.pattern * 'a) list -> Ident.t
+val name_pattern: string -> (pattern * 'a) list -> Ident.t
 val maybe_pointer: expression -> bool
 
 val transl_exp: expression -> lambda

bytecomp/translmod.ml

@@ -16,6 +16,7 @@
 
 open Misc
 open Asttypes
+open Types
 open Typedtree
 open Lambda
 open Translobj