Commits

Anonymous committed d700ef6

Detection des types sommes avec trop de constructeurs.

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

Comments (0)

Files changed (12)

bytecomp/dectree.ml

   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.

bytecomp/matching.ml

 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
   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
       | ([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)

bytecomp/translcore.ml

       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
   | _ ->
 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 \
 
 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
 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
 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 *)
   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))

typing/typedecl.ml

 type error =
     Repeated_parameter
   | Duplicate_constructor of string
+  | Too_many_constructors
   | Duplicate_label of string
   | Recursive_abbrev of string
 
               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))
       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 ->

typing/typedecl.mli

 type error =
     Repeated_parameter
   | Duplicate_constructor of string
+  | Too_many_constructors
   | Duplicate_label of string
   | Recursive_abbrev of string
 

typing/typedtree.ml

 
 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 *)
 

typing/typedtree.mli

 
 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 *)
 
         (* 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. *)
 
 let load_path = ref ([] : string list)
 
+let max_tag = 251