Detection des types sommes avec trop de constructeurs.

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

12 files changed, 34 insertions, 17 deletions

diff --git a/bytecomp/dectree.ml b/bytecomp/dectree.ml
index d847fac70..66e07611b 100644
--- a/bytecomp/dectree.ml
+++ b/bytecomp/dectree.ml
@@ -19,7 +19,8 @@ let make_decision_tree casei =
   let rec partition start =
     if start >= n then [] else
     let stop = ref (n-1) in
-    while keyv.(!stop) - keyv.(start) > 4 * (!stop - start) do
+    while let span = keyv.(!stop) - keyv.(start) in
+          span >= 256 or span > 4 * (!stop - start) do
       decr stop
     done;
     (* We've found a dense enough segment.
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index ace2a0c5b..77ee1fd18 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -60,8 +60,8 @@ let divide_constant {cases = cl; args = al} =
 let make_constr_matching cstr (arg :: argl) =
   let (first_pos, last_pos) =
     match cstr.cstr_tag with
-      Cstr_tag n -> (0, cstr.cstr_arity - 1)
-    | Cstr_exception p -> (1, cstr.cstr_arity) in
+      Cstr_tag _ -> (0, cstr.cstr_arity - 1)
+    | Cstr_exception _ -> (1, cstr.cstr_arity) in
   let rec make_args pos =
     if pos > last_pos
     then argl
@@ -176,7 +176,7 @@ let combine_constructor arg cstr (tag_lambda_list, total1) (lambda2, total2) =
   end else begin
     (* Regular concrete type *)
     let caselist =
-      List.map (fun (Cstr_tag n, act) -> (n, act)) tag_lambda_list in
+      List.map (function (Cstr_tag n, act) -> (n, act)) tag_lambda_list in
     let lambda1 =
       match (caselist, cstr.cstr_span) with
         ([0, act], 1) -> act
@@ -184,7 +184,10 @@ let combine_constructor arg cstr (tag_lambda_list, total1) (lambda2, total2) =
       | ([1, act], 2) -> Lifthenelse(arg, act, Lstaticfail)
       | ([0, act0; 1, act1], 2) -> Lifthenelse(arg, act1, act0)
       | ([1, act1; 0, act0], 2) -> Lifthenelse(arg, act1, act0)
-      | _ -> Lswitch(Lprim(Ptagof, [arg]), 0, cstr.cstr_span, caselist) in
+      | _ ->
+          if cstr.cstr_span < Config.max_tag
+          then Lswitch(Lprim(Ptagof, [arg]), 0, cstr.cstr_span, caselist)
+          else Lswitch(Lprim(Pfield 0, [arg]), 0, cstr.cstr_span, caselist) in
     if total1 & List.length tag_lambda_list = cstr.cstr_span
     then (lambda1, true)
     else (Lcatch(lambda1, lambda2), total2)
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 35499b524..7650ed5da 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -37,7 +37,9 @@ let rec bind_pattern env pat arg mut =
       bind_pattern_list env patl arg mut 0
   | Tpat_construct(cstr, patl) ->
       bind_pattern_list env patl arg mut
-        (match cstr.cstr_tag with Cstr_tag _ -> 0 | Cstr_exception _ -> 1)
+        (match cstr.cstr_tag with
+            Cstr_tag _ -> 0
+          | Cstr_exception _ -> 1)
   | Tpat_record lbl_pat_list ->
       bind_label_pattern env lbl_pat_list arg mut
   | _ ->
diff --git a/stdlib/Makefile b/stdlib/Makefile
index 2c88ffaa4..e6b845e0e 100644
--- a/stdlib/Makefile
+++ b/stdlib/Makefile
@@ -1,7 +1,7 @@
 include ../Makefile.config
 
 COMPILER=../camlc
-CAMLC=../boot/camlrun $(COMPILER)
+CAMLC=../byterun/camlrun $(COMPILER)
 CAMLDEP=../tools/camldep
 
 OBJS=pervasives.cmo list.cmo string.cmo char.cmo array.cmo sys.cmo \
diff --git a/tools/Makefile b/tools/Makefile
index e4ca7290a..b89a26d9d 100644
--- a/tools/Makefile
+++ b/tools/Makefile
@@ -5,10 +5,10 @@ LINKFLAGS=$(INCLUDES)
 
 all: dumpobj
 
-DUMPOBJ=opnames.zo dumpobj.zo
+DUMPOBJ=opnames.cmo dumpobj.cmo
 
 dumpobj: $(DUMPOBJ)
-	$(CAMLC) $(LINKFLAGS) -o dumpobj misc.zo tbl.zo config.zo ident.zo opcodes.zo runtimedef.zo $(DUMPOBJ)
+	$(CAMLC) $(LINKFLAGS) -o dumpobj misc.cmo tbl.cmo config.cmo ident.cmo opcodes.cmo runtimedef.cmo $(DUMPOBJ)
 
 clean::
 	rm -f dumpobj
@@ -27,16 +27,16 @@ clean::
 beforedepend:: opnames.ml
 
 .SUFFIXES:
-.SUFFIXES: .ml .zo .mli .zi
+.SUFFIXES: .ml .cmo .mli .cmi
 
-.ml.zo:
+.ml.cmo:
 	$(CAMLC) -c $(COMPFLAGS) $<
 
-.mli.zi:
+.mli.cmi:
 	$(CAMLC) -c $(COMPFLAGS) $<
 
 clean::
-	rm -f *.zo *.zi
+	rm -f *.cmo *.cmi
 
 depend: beforedepend
 	camldep $(INCLUDES) *.mli *.ml > .depend
diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml
index 30baf82dd..2645cef6f 100644
--- a/tools/dumpobj.ml
+++ b/tools/dumpobj.ml
@@ -31,7 +31,7 @@ let inputs ic =
 type global_table_entry =
     Empty
   | Global of Ident.t
-  | Constant of obj
+  | Constant of Obj.t
 
 let start = ref 0                             (* Position of beg. of code *)
 let reloc = ref ([] : (reloc_info * int) list)  (* Relocation table *)
@@ -277,7 +277,7 @@ let dump_exe ic =
   let symbol_size = input_binary_int ic in
   let debug_size = input_binary_int ic in
   seek_in ic (trailer_pos - debug_size - symbol_size - data_size);
-  let init_data = (input_value ic : obj array) in
+  let init_data = (input_value ic : Obj.t array) in
   globals := Array.new (Array.length init_data) Empty;
   for i = 0 to Array.length init_data - 1 do
     !globals.(i) <- Constant (init_data.(i))
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 3b813b6ab..ef25c8315 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -8,6 +8,7 @@ open Typetexp
 type error =
     Repeated_parameter
   | Duplicate_constructor of string
+  | Too_many_constructors
   | Duplicate_label of string
   | Recursive_abbrev of string
 
@@ -51,6 +52,8 @@ let transl_declaration env (name, sdecl) id =
               raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
             all_constrs := Cset.add name !all_constrs)
           cstrs;
+        if List.length cstrs > Config.max_tag then
+          raise(Error(sdecl.ptype_loc, Too_many_constructors));
         Type_variant(List.map
           (fun (name, args) ->
                   (name, List.map (transl_simple_type env true) args))
@@ -111,6 +114,9 @@ let report_error = function
       print_string "A type parameter occurs several times"
   | Duplicate_constructor s ->
       print_string "Two constructors are named "; print_string s
+  | Too_many_constructors ->
+      print_string "Too many constructors -- maximum is ";
+      print_int Config.max_tag; print_string " constructors"
   | Duplicate_label s ->
       print_string "Two labels are named "; print_string s
   | Recursive_abbrev s ->
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index 840492505..2507e6fc8 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -11,6 +11,7 @@ val transl_exception:
 type error =
     Repeated_parameter
   | Duplicate_constructor of string
+  | Too_many_constructors
   | Duplicate_label of string
   | Recursive_abbrev of string
 
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index ff44fd0fb..2390d9fbb 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -35,7 +35,7 @@ type constructor_description =
 
 and constructor_tag =
     Cstr_tag of int                     (* Regular constructor *)
-  | Cstr_exception of Path.t         (* Exception constructor *)
+  | Cstr_exception of Path.t            (* Exception constructor *)
 
 (* Record label descriptions *)
 
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 1c52b126f..976feb496 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -35,7 +35,7 @@ type constructor_description =
 
 and constructor_tag =
     Cstr_tag of int                     (* Regular constructor *)
-  | Cstr_exception of Path.t         (* Exception constructor *)
+  | Cstr_exception of Path.t            (* Exception constructor *)
 
 (* Record label descriptions *)
 
diff --git a/utils/config.mli b/utils/config.mli
index 05e6528fc..483de0b51 100644
--- a/utils/config.mli
+++ b/utils/config.mli
@@ -21,3 +21,6 @@ val cmo_magic_number: string
         (* Magic number for object bytecode files *)
 val cma_magic_number: string
         (* Magic number for archive files *)
+
+val max_tag: int
+        (* Biggest tag that can be stored in the header of a block. *)
diff --git a/utils/config.mlp b/utils/config.mlp
index 5cee74284..59b2d050a 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -13,3 +13,4 @@ and cma_magic_number = "Caml1999A001"
 
 let load_path = ref ([] : string list)
 
+let max_tag = 251